API de Windows (1º)

Algunas funciones interesantes del API de Windows (16 y 32 bits)

Actualizado el 19-Feb-1997

Pulsa aquí para ver todos los links del API

Funciones y ejemplos:

SendMessage: la que siempre hay que tener a mano

SetWindowWord: crear ventanas flotantes

Manejo de ventanas...

GetVolumeInformation: leer el volumen de un disco (32 bits)

GetDriveType: comprobar el tipo de unidad

Dejar una ventana siempre visible

Usar Sleep en lugar de DoEvents

Manejo del Registro

Diálogos comunes del API

Iconos en la barra de tarea

Marcador de teléfonos de Win95

Sleep parece que no sirve para sustituir a DoEvents...

Usar GetTickCount en lugar de Timer
Ejemplo de GetTickCount()

Ficheros de declaraciones del API (16 y 32 bits)

Leer la etiqueta del volumen y el número de serie (sólo 32 bits)

La línea actual y el número de líneas de un text-box

Uso de PostMessage en lugar de SendMessage

1.- SendMessage: la que siempre hay que tener a mano

'Declaración del API de 16 bits
Declare Function SendMessage Lib "User" _
		(ByVal hWnd As Integer, ByVal wMsg As Integer, _
		 ByVal wParam As Integer, lParam As Any) As Long
'Declaración del API de 32 bits.
Declare Function SendMessage Lib "User32" Alias "SendMessageA" _
		(ByVal hwnd As Long, ByVal wMsg As Long, _
		 ByVal wParam As Long, lParam As Long) As Long


'Utilidades para un menú de edición:
'
'Declaración de las constantes
Global Const WM_USER = &H400
Global Const EM_GETSEL = WM_USER + 0
Global Const EM_SETSEL = WM_USER + 1
Global Const EM_REPLACESEL = WM_USER + 18
Global Const EM_UNDO = WM_USER + 23
Const EM_LINEFROMCHAR = WM_USER + 25
Const EM_GETLINECOUNT = WM_USER + 10
'
Global Const WM_CUT = &H300
Global Const WM_COPY = &H301
Global Const WM_PASTE = &H302
Global Const WM_CLEAR = &H303
'
'Deshacer:
    'Nota: si se hace de esta forma,
    'no es necesario usar una variable para asignar el valor devuelto.
    If SendMessage(Screen.ActiveForm.ActiveControl.hWnd, EM_UNDO, 0, ByVal 0&) Then
    End If
    'también: x = SendMessage(Screen.ActiveForm.ActiveControl.hWnd, EM_UNDO, 0, ByVal 0&)
'Copiar:
    If SendMessage(Screen.ActiveForm.ActiveControl.hWnd, WM_COPY, 0, ByVal 0&) Then
    End If
'Cortar:
    If SendMessage(Screen.ActiveForm.ActiveControl.hWnd, WM_CUT, 0, ByVal 0&) Then
    End If
'Borrar:
    If SendMessage(Screen.ActiveForm.ActiveControl.hWnd, WM_CLEAR, 0, ByVal 0&) Then
    End If
'Pegar:
    If SendMessage(Screen.ActiveForm.ActiveControl.hWnd, WM_PASTE, 0, ByVal 0&) Then
    End If
'Seleccionar Todo:
    If SendMessage(Screen.ActiveForm.ActiveControl.hWnd, EM_SETSEL, 0, ByVal &HFFFF0000) Then
    End If


'Crear un TextBox con 64 KB en lugar de 32
Global Const WM_USER = &H400
Global Const EM_LIMITTEXT = WM_USER + 21

Dim LTmp As long
LTmp = SendMessage(Text1.hWnd, EM_LIMITTEXT, 0, ByVal 0&)

2.- SetWindowWord: crear ventanas flotantes

Declare Function SetWindowWord Lib "User" (ByVal hWnd As Integer, ByVal nIndex As Integer, ByVal wNewWord As Integer) As Integer
Declare Function SetWindowWord Lib "User32" Alias "SetWindowWord" (ByVal hwnd As Long, ByVal nIndex As Long, ByVal wNewWord As Long) As Long


'Crear una ventana flotante al estilo de los tool-bar
'Cuando se minimiza la ventana padre, también lo hace ésta.
Const SWW_hParent = -8

'En Form_Load (suponiendo que la ventana padre es Form1)
If SetWindowWord(hWnd, SWW_hParent, form1.hWnd) Then
End If

3.- Manejo de ventanas...

'Declaración de Funciones para tomar las listas de tareas
Declare Function GetWindow Lib "user" (ByVal hWnd As Integer, ByVal wCmd As Integer) As Integer
Declare Function GetWindowText Lib "user" (ByVal hWnd As Integer, ByVal lpString As String, ByVal nMaxCount As Integer) As Integer
Declare Function GetWindowTextLength Lib "user" (ByVal hWnd As Integer) As Integer
Declare Function IsWindowVisible Lib "User" (ByVal hWnd As Integer) As Integer
'Declaraciones para 32 bits
Declare Function GetWindow Lib "user32" Alias "GetWindow" (ByVal hwnd As Long, ByVal wCmd As Long) As Long
Declare Function GetWindowText Lib "user32" Alias "GetWindowTextA" (ByVal hwnd As Long, ByVal lpString As String, ByVal cch As Long) As Long
Declare Function GetWindowTextLength Lib "user32" Alias "GetWindowTextLengthA" (ByVal hwnd As Long) As Long
Declare Function IsWindowVisible Lib "user32" (ByVal hwnd As Long) As Long

'Constantes para GetWindow
Const GW_HWNDFIRST = 0
Const GW_HWNDLAST = 1
Const GW_HWNDNEXT = 2
Const GW_HWNDPREV = 3
Const GW_OWNER = 4
Const GW_CHILD = 5

4.- GetVolumeInformation: volumen de un disco (sólo 32 bits)

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

Ejemplo para leer el volumen de un disco, esta función se puede usar para ¡catalogar los CD's musicales!

Dim lVSN As Long, n As Long, s1 As String, s2 As String
s1=String$(255,Chr$(0))
s2=String$(255,Chr$(0))
l= GetVolumeInformation("unidad", s1, Len(s1), lVSN, 0, 0, s2, Len(s2))
'lVSN tendrá el valor del Volume Serial Number (número de serie del volumen)

Si "unidad" es el CD-ROM y tenemos un disco de música, podemos usar el VSN para hacer un catálogo de CD's ya que cada CD tiene un número diferente.

5.- GetDriveType: comprobar el tipo de unidad

Para comprobar si es un CD-ROM (o CD-musical):

'Valores de retorno de GetDriveType
Public Const DRIVE_REMOVABLE = 2
Public Const DRIVE_FIXED = 3
Public Const DRIVE_REMOTE = 4
'Estos tipos no están en el fichero de las declaraciones del API de 16 bits
Public Const DRIVE_CDROM = 5
Public Const DRIVE_RAMDISK = 6
'
Declare Function GetDriveType Lib "Kernel" (ByVal nDrive As Integer) As Integer
Declare Function GetDriveType Lib "Kernel32" Alias "GetDriveTypeA" (ByVal nDrive As String) As Long


Dim lDrive As Long
Dim szRoot As String

szRoot="D:\" 'Poner aquí la unidad del CD-ROM o la que queramos comprobar
lDrive= GetDriveType(szRoot)
If lDrive = DRIVE_CDROM Then
    'Es un CD-ROM/Compact-Disc
End If

6.- Dejar una ventana siempre visible

De nuevo usaremos el API de Windows: SetWindowPos

'Declaración para usar ventanas siempre visibles
'Versión para 16 bits
Declare Function SetWindowPos Lib "User" (ByVal hWnd As Integer, ByVal hWndInsertAfter As Integer, ByVal X As Integer, ByVal Y As Integer, ByVal cx As Integer, ByVal cy As Integer, ByVal wFlags As Integer) As Integer
'Versión para 32 bits
Declare Function SetWindowPos Lib "User32" Alias "SetWindowPos" (ByVal hwnd As Long, ByVal hWndInsertAfter As Long, ByVal x As Long, ByVal y As Long, ByVal cx As Long, ByVal cy As Long, ByVal wFlags As Long) As Long


' SetWindowPos Flags
Const SWP_NOSIZE = &H1
Const SWP_NOMOVE = &H2
'Const SWP_NOZORDER = &H4
'Const SWP_NOREDRAW = &H8
Const SWP_NOACTIVATE = &H10
'Const SWP_DRAWFRAME = &H20
Const SWP_SHOWWINDOW = &H40
'Const SWP_HIDEWINDOW = &H80
'Const SWP_NOCOPYBITS = &H100
'Const SWP_NOREPOSITION = &H200
Const SWP_FLAGS = SWP_NOMOVE Or SWP_NOSIZE Or SWP_SHOWWINDOW Or SWP_NOACTIVATE


'Código para poner en Form_Load

'De esta forma no es necesario usar una variable para asignar el valor devuelto:
If SetWindowPos(hWnd, -1, 0, 0, 0, 0, SWP_FLAGS) Then
End if

7.- Usar Sleep en lugar de DoEvents

Por si alguno no lo sabe, DoEvents se usa cuando queremos que otros programas/procesos de Windows sigan funcionando, de forma que nuestro programa no se apodere de todo el tiempo de la CPU. Por ejemplo cuando hacemos un bucle que puede durar "mucho", al ejecutar DoEvents, Windows permite que otros programas sigan funcionando normalmente.
Es aconsejable siempre usar DoEvents ( o Sleep 0&) en los bucles largos. Yo también lo uso cuando quiero que se "refresque" la información de un control. ¿Cuantas veces has asignado a un Label un nuevo Caption y no lo ha mostrado?, prueba a poner DoEvents después de la asignación y verás como se muestra enseguida. (¡oye, esto debería aparecer en los trucos!)

Este truco está sacado de Tips & Tricks, from Visual Basic Web Magazine. Según el autor la función DoEvents hace lo siguiente:

while (PeekMessage(&msg, NULL, 0, 0, PM_REMOVE)) {
	TranslateMessage(&msg);
	DispatchMessage(&msg);
}

Con lo cual gasta tiempo comprobandos otros mensajes en el mismo proceso. Este comportamiento no tiene valor en un sistema operativo multitarea. Sleep lo hace de forma más eficiente.
La declaración de Sleep es:

Public Declare Sub Sleep Lib "kernel32" Alias "Sleep" (ByVal dwMilliseconds As Long)

Y se puede llamar de la siguiente forma:

Sleep 0&

8.- Manejo del Registro del Sistema

Aquí os pongo algunos ejemplos para usar el Registro con el API de 32 bits.
Creo que también vale para 16 bits, no lo he probado, pero sólo habrá que cambiar la declaración de las funciones. Por si vale, pondré también las declaraciones de 16 bits. Pero que conste que no las he probado.

Si quieres un ejemplo con todas estas funciones, echale un vistazo al código del programa gsExecute, que está en gsExec.zip (19 KB) La explicación de cómo funciona este programa la encontrarás en Programas de Visual Basic.

Normalmente, para obtener los programas asociados a una extensión, sólo es necesario usar la función: RegQueryValue. La siguiente función de ejemplo, es la que uso para obtener información de una clave del registro:

Public Const HKEY_CLASSES_ROOT = &H80000000

Declare Function RegQueryValue Lib "advapi32.dll" Alias "RegQueryValueA" _
	(ByVal hKey As Long, ByVal lpSubKey As String, ByVal lpValue As String, _
	 lpcbValue As Long) As Long

'Busca una entrada en el registro
Private Function QueryRegBase(ByVal Entry As String, Optional vKey) As String
    Dim buf As String
    Dim buflen As Long
    Dim hKey As Long
    'Si no se especifica la clave del Registro, usar HKEY_CLASSES_ROOT
    If IsMissing(vKey) Then
        hKey = HKEY_CLASSES_ROOT
    Else
        hKey = CLng(vKey)
    End If

    On Local Error Resume Next
    buf = Space$(300)
    buflen = Len(buf)
    'Buscar la entrada especificada y devolver el valor asignado
    If RegQueryValue(hKey, Entry, buf, buflen) = 0 Then
        If buflen > 1 Then
            'El formato devuelto es ASCIIZ, así que quitar el último caracter
            QueryRegBase = Left$(buf, buflen - 1)
        Else
            QueryRegBase = ""
        End If
    Else
        QueryRegBase = ""
    End If
    'Desactivar la detección de errores
    On Local Error GoTo 0
End Function

Para usarla, por ejemplo para saber el programa asociado para abrir una determinada extensión, de que programa se obtiene el icono y que número de icono es:
NOTA: Para usar este ejemplo, hay que tener un control List2 en el Form y la rutina mostrada antes.

Private Sub BuscarExtensionID(sExt As String)
    Dim lRet As Long
    Dim sKey As String
    Dim sValue As String
    Dim hKey As Long
    Dim sExe As String
    Dim sIcon As String
    Dim lIcon As Long
    Dim sProgId As String
    Dim i As Integer

    Caption = "Mostrar asociaciones de la clave: " & sExt
    List2.Visible = True
    List2.Clear
    List2.AddItem "Valores del Registro para " & sExt
    '
    'Buscar en el registro la extensión...
    sProgId = QueryRegBase(sExt)
    If Len(sProgId) Then
        List2.AddItem "Clave: " & sProgId
        sKey = sProgId & "\DefaultIcon"
        List2.AddItem sKey
        sValue = QueryRegBase(sKey)
        If Len(sValue) Then
            i = InStr(sValue, ",")
            If i Then
                sIcon = Left$(sValue, i - 1)
                lIcon = Val(Mid$(sValue, i + 1))
            Else    'No tiene programa para Defaulticon
                sIcon = sValue
                lIcon = 0
                sValue = ""
            End If
        End If
        List2.AddItem "   Icono de: " & sIcon
        List2.AddItem "   Icono nº: " & lIcon
	'
        'Obtener el programa asociado por defecto para Abrir
	'no quiere decir que este sea el que se ejecute cuando se haga doble-click
        sKey = sProgId & "\Shell\Open\Command"
        sValue = QueryRegBase(sKey)
        If Len(sValue) Then
            i = InStr(sValue, ".")
            If i Then
                i = InStr(i, sValue, " ")
                If i Then
                    sExe = Trim$(Left$(sValue, i - 1))
                Else
                    sExe = Trim$(sValue)
                End If
            Else
                sExe = Trim$(sValue)
            End If
        End If
        List2.AddItem sKey
        List2.AddItem "   Programa asociado: " & sExe
    End If
End Sub

Ejemplo para crear claves en el Registro:
Para no alargar demasiado este fichero, aquí sólo están las declaraciones de las funciones; en los listados del programa gsExecute, hay ejemplos de cómo crear y borrar claves para asociar/desasociar un programa a una extensión determinada.

'Claves del Registro
Public Const HKEY_CLASSES_ROOT = &H80000000
Public Const HKEY_CURRENT_USER = &H80000001
Public Const HKEY_LOCAL_MACHINE = &H80000002
Public Const HKEY_USERS = &H80000003
'
'Para los valores devueltos por las funciones de manejo del Registro
Public Const ERROR_SUCCESS = 0&
Public Const ERROR_NO_MORE_ITEMS = 259&
'
' Tipos de datos Reg...
Public Const REG_SZ = 1
'
'Declaraciones del API de Windows para 32 bits
Declare Function RegQueryValue Lib "advapi32.dll" Alias "RegQueryValueA" (ByVal hKey As Long, ByVal lpSubKey As String, ByVal lpValue As String, lpcbValue As Long) As Long
Declare Function RegEnumKey Lib "advapi32" Alias "RegEnumKeyA" (ByVal hKey As Long, ByVal iSubKey As Long, ByVal lpszName As String, ByVal cchName As Long) As Long
Declare Function RegOpenKey Lib "advapi32" Alias "RegOpenKeyA" (ByVal hKey As Long, ByVal lpszSubKey As String, phkResult As Long) As Long
Declare Function RegCloseKey Lib "advapi32" (ByVal hKey As Long) As Long
Declare Function RegCreateKey Lib "advapi32.dll" Alias "RegCreateKeyA" (ByVal hKey As Long, ByVal lpSubKey As String, phkResult As Long) As Long
Declare Function RegSetValue Lib "advapi32.dll" Alias "RegSetValueA" (ByVal hKey As Long, ByVal lpSubKey As String, ByVal dwType As Long, ByVal lpData As String, ByVal cbData As Long) As Long
Declare Function RegDeleteKey Lib "advapi32.dll" Alias "RegDeleteKeyA" (ByVal hKey As Long, ByVal lpSubKey As String) As Long

'Declaraciones para el API de 16 bits
Declare Function RegQueryValue Lib "shell.dll" (ByVal hKey As Long, ByVal lpSubKey As String, ByVal lpValue As String, lpcbValue As Long) As Long
Declare Function RegEnumKey Lib "shell.dll" (ByVal hKey As Long, ByVal iSubKey As Long, ByVal lpszName As String, ByVal cchName As Long) As Long
Declare Function RegOpenKey Lib "shell.dll" (ByVal hKey As Long, ByVal lpszSubKey As String, phkResult As Long) As Long
Declare Function RegCloseKey Lib "shell.dll" (ByVal hKey As Long) As Long
Declare Function RegCreateKey Lib "shell.dll" (ByVal hKey As Long, ByVal lpSubKey As String, phkResult As Long) As Long
Declare Function RegSetValue Lib "shell.dll" (ByVal hKey As Long, ByVal lpSubKey As String, ByVal dwType As Long, ByVal lpData As String, ByVal cbData As Long) As Long
Declare Function RegDeleteKey Lib "shell.dll" (ByVal hKey As Long, ByVal lpSubKey As String) As Long

Una nota de precaución:
Si vas a trabajar con el registro del sistema, te recomiendo que antes hagas copia del mismo. En el CD de Windows 95, hay una utilidad: ERU.exe que copia los archivos del Sistema, así como Autoexec, etc. Si no tienes este programa, copia los archivos System.dat y User.dat que están el directorio de Windows.
Suerte y que no se te cuelgue!

9.- Diálogos comunes usando el API de Windows (16 y 32 bits)

Las funciones para manejar los diálogos comunes del API de Windows, son las siguientes:
Nota: En 16 bits no están todas las que son, es que no tengo ahora a mano el fichero con las declaraciones para seleccionar el color y las fuentes. Si las necesitas, no dudes en pedirlas, las buscaré. en algún sitio tengo que tenerlas. 8-)

'Declaraciones para el API de 16 bits
'Abrir y guardar
Declare Function GetOpenFileName Lib "commdlg.dll" (lpofn As tagOpenFileName) As Integer
Declare Function GetSaveFileName Lib "commdlg.dll" (lpofn As tagOpenFileName) As Integer
'Buscar y reemplazar (aún no he podido ponerlas en marcha???)
Declare Function FindText Lib "commdlg.dll" (lpFR As tagFindReplace) As Integer
Declare Function ReplaceText Lib "commdlg.dll" (lpFR As tagFindReplace) As Integer
'Para la impresora
Declare Function PrintDlg Lib "commdlg.dll" (tagPD As tagPrintDlg) As Integer
'

'Declaraciones para 32 bits
'Abrir y guardar
Declare Function GetOpenFileName Lib "comdlg32.dll" Alias "GetOpenFileNameA" (pOpenfilename As OPENFILENAME) As Long
Declare Function GetSaveFileName Lib "comdlg32.dll" Alias "GetSaveFileNameA" (pOpenfilename As OPENFILENAME) As Long
Declare Function GetFileTitle Lib "comdlg32.dll" Alias "GetFileTitleA" (ByVal lpszFile As String, ByVal lpszTitle As String, ByVal cbBuf As Integer) As Integer
'Buscar y reemplazar
Declare Function FindText Lib "comdlg32.dll" Alias "FindTextA " (pFindreplace As FINDREPLACE) As Long
Declare Function ReplaceText Lib "comdlg32.dll" Alias "ReplaceTextA" (pFindreplace As FINDREPLACE) As Long
'Para la impresora
Declare Function PrintDlg Lib "comdlg32.dll" Alias "PrintDlgA" (pPrintdlg As PRINTDLG) As Long
Declare Function PageSetupDlg Lib "comdlg32.dll" Alias "PageSetupDlgA" (pPagesetupdlg As PAGESETUPDLG) As Long
'Para los colores
Declare Function ChooseColor Lib "comdlg32.dll" Alias "ChooseColorA" (pChoosecolor As CHOOSECOLOR) As Long
'Las fuentes
Declare Function ChooseFont Lib "comdlg32.dll" Alias "ChooseFontA" (pChoosefont As CHOOSEFONT) As Long

No incluyo ejemplos ni las declaraciones de los tipos, por ser demasiado "grandes". Pero las incluyo en un listado con ejemplos para abrir, etc., aunque con las funciones para 16 bits, ya que desde que uso el VB para 32 bits, suelo hacerlo con el control que trae. Si quieres ver ejemplos usando el control de diálogos comunes, pasate por la página de trucos.

Listado con las declaraciones para diálogos comunes usando el API de Windows (cmdlgapi.zip 5.012 bytes)

10.- Mostrar un icono en la barra de tareas

Gracias a Joe LeVasseur por enviar este ejemplo de cómo crear un icono en la barra de tareas.
Baja el listado de ejemplo (EjemplBT.zip 6.717 bytes)

Aquí pongo parte del código, para los que sólo quieren echar un vistazo:

'---------------
Private Type TIPONOTIFICARICONO
    cbSize As Long
    hwnd As Long
    uId As Long
    uFlags As Long
    ucallbackMessage As Long
    hIcon As Long
    szTip As String * 64
End Type
'------------------
Private Const NIM_ADD = &H0
Private Const NIM_MODIFY = &H1
Private Const NIM_DELETE = &H2
Private Const WM_MOUSEMOVE = &H200
Private Const NIF_MESSAGE = &H1
Private Const NIF_ICON = &H2
Private Const NIF_TIP = &H4
Private Const WM_LBUTTONDBLCLK = &H203
Private Const WM_LBUTTONDOWN = &H201
Private Const WM_LBUTTONUP = &H202
Private Const WM_RBUTTONDBLCLK = &H206
Private Const WM_RBUTTONDOWN = &H204
Private Const WM_RBUTTONUP = &H205
'--------------------
Private Declare Function Shell_NotifyIcon Lib "shell32" _
    Alias "Shell_NotifyIconA" (ByVal dwMessage As Long, _
    pnid As TIPONOTIFICARICONO) As Boolean
'--------------------
Private Declare Function WinExec& Lib "kernel32" _
    (ByVal lpCmdLine As String, ByVal nCmdShow As Long)
'--------------------
Dim t As TIPONOTIFICARICONO


Private Sub Form_Load()
    If App.PrevInstance Then
        mnuAcerca_Click
        Unload Me
        End
    End If
'---------------------------------
    t.cbSize = Len(t)
    t.hwnd = picGancho.hwnd
    t.uId = 1&
    t.uFlags = NIF_ICON Or NIF_TIP Or NIF_MESSAGE
    t.ucallbackMessage = WM_MOUSEMOVE
    t.hIcon = Me.Icon
'---------------------------------
    t.szTip = "Ejemplo de barra de tareas..." & Chr$(0) ' Es un string de "C" ( \0 )
    Shell_NotifyIcon NIM_ADD, t
    Me.Hide
    App.TaskVisible = False
End Sub

11.- Cómo usar el marcador telefónico de Windows 95

Gracias de nuevo a Joe LeVasseur por enviar este ejemplo.
Aquí lo que se muestra es sólo la forma de usarlo.

Private Declare Function tapiRequestMakeCall& Lib "TAPI32.DLL" _
	(ByVal DestAddress&, ByVal AppName$, ByVal CalledParty$, ByVal Comment$)


Private Sub Command1_Click()
    Dim ValDev&, Numero$, NombreProg$, Quien$
    Numero = "123-4567"
    NombreProg = "Mi Programa"
    Quien = "Pepe"
    ValDev = tapiRequestMakeCall(Numero, NombreProg,Quien,"")
End Sub

12.- Sleep parece que no sirve para sustituir a DoEvents

He probado a usar Sleep en lugar de DoEvents, según se explica en el truco 7, y no funciona.
Al menos como yo espero que lo haga. Es decir, sustituir DoEvents por Sleep 0& no hace que el proceso continue, al menos en la misma aplicación.
He intentado hacer una prueba, para comprobar la función GetTickCount, y no salía del bucle; incluso cambiando Sleep 0& por Sleep 1&. ¿Alguien sabe por qué?

13.- Usar GetTickCount() en lugar de Timer

Esta función si la he probado. El efecto es similar a usar Timer, para saber los segundos transcurridos desde la medianoche. La diferencia principal, es que Timer devuelve un valor en segundos y GetTickCount() lo devuelve en milésimas de segundos. Por tanto para algunos cálculos, es más precisa la función del API.
Como nota adicional, decir que en el API de 16 bits, GetTickCount() es igual que GetCurrentTime()

'La declaración de esta función para 16 y 32 bits:
#If Win32 Then
    Declare Function GetTickCount Lib "kernel32" () As Long
#Else
    Declare Function GetTickCount Lib "User" () As Long
#End If

Por ejemplo, podemos usarla para saber la diferencia en el tiempo de ejecución de una serie de instrucciones, un bucle, etc.

Dim T1 As Long
Dim T2 As Long
Dim L As Long

T1 = GetTickCount()
For L = 1 to 320000
    DoEvents
Next
T2 = GetTickCount()
Print "Duración: "; T2 - T1 ; " milisegundos."

13.1.- Ejemplo de GetTickCount()

He hecho este ejemplo, para ver si había más exactitud en la función del API que en con el TimerControl, por si ayudaba a Pedro, ver Proyectos, pero no he notado ninguna. He repetido el bucle hasta 20.000 veces y nada, no ha mostrado diferencias. Lo siento Pedro.

Baja el listado en formato zip: (eje_Tick.zip 2.390 bytes)

Para usarlo, hay que crear un Form con los siguientes controles:

'
'Prueba de Timer,               (21:00 14/Ene/96)
Option Explicit

'Declaración del API
#If Win32 Then
    Private Declare Function GetTickCount Lib "Kernel32" () As Long
#Else
    Private Declare Function GetTickCount Lib "User" () As Long
#End If


'Para saber que acción debe tomar el botón
Dim Contando As Boolean
'Variables para el GetTickCount
Dim g1 As Long
Dim g2 As Long
Dim g3 As Long
'Variables para el Timer1
Dim t1 As Long
Dim t2 As Long
'valor para el timer
Dim vTimer As Long
'Flag para cancelar el bucle
Dim Cancelar As Boolean
'valor máximo de items a mostrar
Dim MaxBucle As Long

Private Sub cmdIniciar_Click()
    Contar
End Sub

Private Sub cmdSalir_Click()
    Cancelar = True
    DoEvents
    Contando = True
    Contar
    Unload Me
End Sub

Private Sub Form_Load()
    '
    Timer1.Interval = 1000
    Timer1.Enabled = False
    Text1 = "1000"
    MaxBucle = 20000
End Sub

Private Sub Text1_Change()
    '
    Dim vTmp
    Static YaEstoy As Boolean

    'No entrar mientras se procesa...
    If YaEstoy Then Exit Sub

    YaEstoy = True

    vTmp = Val(Text1) \ 10
    If vTmp > VScroll1.Min Then
        vTmp = VScroll1.Min
    End If
    If vTmp < VScroll1.Max Then
        vTmp = VScroll1.Max
    End If
    Text1 = CStr(vTmp * 10)
    VScroll1.Value = vTmp

    YaEstoy = False

End Sub

Private Sub Timer1_Timer()
    'número de segundos transcurridos
    t2 = Timer - t1
    Mostrar
    DoEvents
End Sub

Private Sub VScroll1_Change()
    Static YaEstoy As Boolean
    Dim vTmp As Variant

    If YaEstoy Then Exit Sub

    YaEstoy = True
    vTmp = VScroll1.Value * 10
    Text1 = CStr(vTmp)

    YaEstoy = False
End Sub

Private Sub Contar()
    'Si ya está contando, dejar de contar...
    If Contando Then
        Cancelar = True
        DoEvents
        Timer1.Enabled = False
        cmdIniciar.Caption = "Iniciar"
        Contando = False
        Text1.Enabled = True
    Else
    'Empezar la cuenta...
        Label2(0) = ""
        Label2(1) = ""
        cmdIniciar.Caption = "Detener"
        Cancelar = False
        Contando = True
        Text1.Enabled = False
        DoEvents
        t1 = Timer
        Timer1.Enabled = True
        Timer1.Interval = Val(Text1)
        OtraCosa
    End If
End Sub

Private Sub OtraCosa()
    'Este procedimiento es para hacer algo...
    'aunque no valga para nada
    Dim i As Long

    List1.Clear
    'Inicializar el temporizador "manual"
    g1 = GetTickCount()
    g3 = 0
    Do
        i = i + 1
        List1.AddItem CStr(i)
        List1.ListIndex = List1.ListCount - 1
        gTimer
        If Cancelar Then Exit Do
        If i = MaxBucle Then
            Exit Do
        End If
    Loop
    'Detener la acción...
    Contando = True
    Contar
    'Actualizar los resultados
    Mostrar
End Sub

Private Sub gTimer()
    g2 = GetTickCount() - g1
    'Este if, es para que se muestre cada segundo
    If g2 > (g3 + 1) * 1000 Then
        g3 = g3 + 1
        Mostrar
    End If
    DoEvents
End Sub

Private Sub Mostrar()
    Label2(0) = t2
    Label2(1) = g3
End Sub
'

14.- Ficheros con las declaraciones del API de Windows, para VB (16 y 32 bits)

Estos ficheros están en el directorio FTP de mi Web, pero no puedes entrar con un programa FTP, simplemente linka en el que te interese para poder bajártelo.
Son los siguientes:

API de 32 bits (win32api.zip 146 KB)
API de 16 bits para Windows 3.1 (win31api.zip 33,9 KB)
API de 16 bits para Windows 3.0 (win30api.zip 25,6 KB)
API de 16 bits extensiones para Windows 3.1 (Win31ext.zip 7,86 KB)

15.- Leer la etiqueta y el número de serie de un disco. (Sólo 32 bits) (18/Feb)

La función que se usa para esto, es GetVolumeInformation, que está en el punto 4, pero lo que ahora pongo, es un ejemplo de cómo usarla.
El ejemplo es un form con una caja de texto en la que se introduce la unidad (directorio raíz, realmente), de la que queremos mostrar la información.
Como no es un listado muy grande, lo pongo al completo.

'---------------------------------------------------------------------------
'Form de prueba para leer la etiqueta y el número de serie de un disco.
'                                                                (18/Feb/97)
'---------------------------------------------------------------------------
Option Explicit

'Declaración de la función, sólo está en el API de 32 bits
'
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()
    'Acción
    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

    'Se debe especificar el directorio raiz
    unidad = Trim$(Text1)

    'Reservar espacio para las cadenas que se pasarán al API
    s1 = String$(255, Chr$(0))
    s2 = String$(255, Chr$(0))
    n = GetVolumeInformation(unidad, s1, Len(s1), lVSN, 0, 0, s2, Len(s2))
    's1 será la etiqueta del volumen
    'lVSN tendrá el valor del Volume Serial Number (número de serie del volumen)
    's2 el tipo de archivos: FAT, etc.

    'Convertirlo a hexadecimal para mostrarlo como en el Dir.
    sTmp = Hex$(lVSN)

    Label3(0) = s1
    Label3(1) = Left$(sTmp, 4) & "-" & Right$(sTmp, 4)
    Label3(2) = s2
End Sub


Private Sub Command2_Click()
    Unload Me
    End
End Sub


Private Sub Form_Unload(Cancel As Integer)
    'Asegurarnos de "liberar" la memoria.
    Set Form1 = Nothing
End Sub

Ahora un "retrato" del Form:

16.- La línea actual y el número de líneas de un text-box (19/Feb)

Otras cosas más que se pueden hacer con SendMessage.
La declaración de esta función del API, para 16 y 32 bits, está en el punto 1

Const WM_USER = 1024
Const EM_GETLINECOUNT = WM_USER + 10
Const EM_LINEFROMCHAR = WM_USER + 25
TotalLineas = SendMessage(Text1.hWnd, EM_GETLINECOUNT, 0, 0&)
LineaActual = SendMessage(Text1.hWnd, EM_LINEFROMCHAR, -1, 0&) + 1

17.- Uso de PostMessage en lugar de SendMessage (19/Feb)

En la lista de distribución VB-ES, leí una respuesta sobre que es preferible, en 32 bits, usar PostMessage en lugar de SendMessage.
Quiero aclarar que el valor devuelto por la función PostMessage, es si ha podido poner el mensaje en la cola o no.
Por tanto, si usas SendMessage para recibir un valor, el ejemplo anterior es un caso, no se te ocurra cambiarla por PostMessage.
En los demás casos, en los que simplemente queremos enviar un mensaje a la cola de Windows y no necesitamos esperar a que la operación termine, si podemos usar PostMessage, ya que esta función trabaja de forma "asíncrona" y devolverá el control a VB antes que SendMessage, que trabaja de forma "síncrona" y hasta que no acabe "su tarea" no vuelve a casa.

La declaración de PostMessage para el API de 16 y 32 bits:

'Declaración del API de 32 bits
Declare Function PostMessage Lib "User32" Alias "PostMessageA" _
		(ByVal hwnd As Long, ByVal wMsg As Long, _
		 ByVal wParam As Long, ByVal lParam As Long) As Long

'Declaración del API de 16 bits
Declare Function PostMessage Lib "User" _
		(ByVal hWnd As Integer, ByVal wMsg As Integer, _
		 ByVal wParam As Integer, lParam As Any) As Integer

Lo que ya he dicho otras veces: ¡Animaros! Enviad funciones y ejemplos de su uso, yo iré "aportando" los que pueda, pero si me echáis un "cable", mejor...