API de Windows (2º)

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

Actualizado el 26/May/2004

Pulsa aquí para ver todos los links del API



Funciones y ejemplos:

  1. Buscar en un ComboBox o ListBox usando el API
  2. SHFormatDrive: Formatear un disco usando el API (y GetDriveType para saber que tipo de unidad es)
  3. Sobre los recursos en 32bits (un código de Joe LeVasseur)
  4. Saber el tipo de una unidad de disco y si es un CDROM (16 y 32 bits)
  5. Averiguar el espacio libre de una unidad de disco (32 bits)
  6. Nombre del usuario actual de Windows (32 bits)
  7. Número de líneas, posición del primer caracter de una línea y longitud (en un TextBox)
  8. Bitmaps en los menús, usando API ¡claro!
  9. Ejecutar cualquier programa usando el API (un truco de Joe LeVasseur)
  10. Cambiar el fondo del escritorio de Windows (WallPaper)
  11. Usando MSGBLAST para manejar mensajes de Windows (VB3/VB4-16 y VB4-32)
  12. Reiniciar Windows (listados para 16 y 32 bits)
  13. ¿Cómo evitar el uso de CTRL+ALT+SUPR y ALT+TAB? (sólo Win95)
  14. ¿Cómo enviar archivos a la papelera de reciclaje? (VB-32 bits) (rev. 26/May/04)
  15. ¿Cómo desplegar y contraer el contenido de un ComboBox? (16 y 32 bits)
  16. Esperar a que un programa termine (incluso si es de MS-DOS) (32 bits)
  17. Comprobar si existe un fichero, usando el API, claro. (FileExist)
  18. Reiniciar Windows (2ª parte) revisado para Windows NT
  19. Averiguar el espacio libre de una unidad de disco (16 bits)
  20. Tocar un archivo de forma indefinida y repetitiva (sólo WAVs)
  21. Un ejemplo, usando API, de cómo tocar de forma indefinida un fichero MIDI
  22. Saber el nombre de nuestro equipo (32 bits)

 

 

1.- Buscar en un ComboBox o ListBox usando el API (1/Mar)

La función que se encarga de esta tarea, como casi siempre, es SendMessage y se deben especificar las siguientes constantes como el mensaje que queremos enviar, según lo que queramos hacer:

Const CB_FINDSTRINGEXACT = &H158        'Buscar cadena completa en un ComboBox
Const LB_FINDSTRINGEXACT = &H1A2        'Buscar cadena completa en un ListBox
Const CB_FINDSTRING = &H14C		'Buscar cadena desde el principio en un ComboBox
Const LB_FINDSTRING = &H18F		'Buscar cadena desde el principio en un ListBox

La declaración de la función SendMessage, debe quedar de esta manera, fijate que el parámetro lParam está definido como Any, de esta forma, aceptará cualquier tipo de dato, Long o ByVal...

#If Win32 Then
    Declare Function SendMessage Lib "User32" Alias "SendMessageA" _
        (ByVal hWnd As Long, ByVal wMsg As Long, _
         ByVal wParam As Long, lParam As Any) As Long
#Else
    Declare Function SendMessage Lib "User" _
        (ByVal hWnd As Integer, ByVal wMsg As Integer, _
         ByVal wParam As Integer, lParam As Any) As Long
#End If

El siguiente ejemplo es una función que inserta un nuevo elemento en una lista o un combo, si es que no existe, claro.

Public Function ActualizarLista(sTexto As String, cList As Control) As Long
    'Esta función comprobará si el texto indicado existe en la lista
    'Si no es así, lo añadirá
    'El valor devuelto, será la posición dentro de la lista ó -1 si hay "fallos"
    '
    'Para buscar en el List/combo usaremos una llamada al API
    '(si ya hay una forma de hacerlo, ¿para que re-hacerla?)
    '
    Const CB_FINDSTRINGEXACT = &H158        'Mensaje para los combos
    Const LB_FINDSTRINGEXACT = &H1A2        'Mensaje para las Listas
    Dim L As Long

    If cList.ListCount = 0 Then
        'Seguro que no está, así que añadirla
        L = -1
    Else
        'Si el control es un Combo
        If TypeOf cList Is ComboBox Then
            L = SendMessage(cList.hWnd, CB_FINDSTRINGEXACT, -1, ByVal sTexto)
        'Si el control es un list
        ElseIf TypeOf cList Is ListBox Then
            L = SendMessage(cList.hWnd, LB_FINDSTRINGEXACT, -1, ByVal sTexto)
        Else
            'no es un control List o Combo, salir
            ActualizarLista = -1
            Exit Function
        End If
    End If

    'Si no está, añadirla
    If L = -1 Then
        cList.AddItem sTexto
        L = ActualizarLista(sTexto, cList)
    End If
    ActualizarLista = L
End Function

Este otro ejemplo es para efectuar una búsqueda en el Combo/List, al estilo de la ayuda de Windows, es una versión a la aparecida en los trucos, pero usando SendMessage.
Para usarlo en un ListBox, debes indicar la constante LB_FINDSTRING, en lugar de CB_FINDSTRING

(Este "truco" está sacado del MSDN Library: Tip 115: Performing Smart Searches in Combo Box Controls)

Private Sub Combo1_KeyPress(KeyAscii As Integer)
    Dim CB As Long
    Dim FindString As String
    Const CB_ERR = (-1)
    Const CB_FINDSTRING = &H14C


    If KeyAscii < 32 Or KeyAscii > 127 Then Exit Sub

    If Combo1.SelLength = 0 Then
        FindString = Combo1.Text & Chr$(KeyAscii)
    Else
        FindString = Left$(Combo1.Text, Combo1.SelStart) & Chr$(KeyAscii)
    End If

    CB = SendMessage(Combo1.hWnd, CB_FINDSTRING, -1, ByVal FindString)

    If CB <> CB_ERR Then
        Combo1.ListIndex = CB
        Combo1.SelStart = Len(FindString)
        Combo1.SelLength = Len(Combo1.Text) - Combo1.SelStart
    End If
    KeyAscii = 0
End Sub

 

2.- SHFormatDrive: Formatear un disco usando el API, GetDriveType para saber que tipo de unidad (10/Abr)

Esta función es la que Joe LeVasseur ha usado para su utilidad de formatear y copiar discos.
La declaración es:

Declare Function SHFormatDrive Lib "shell32" _
    (ByVal hwnd As Long, ByVal Drive As Long, ByVal fmtID As Long, _
    ByVal options As Long) As Long

La forma de usarla:

    Dim DriveLetter$, DriveNumber&, DriveType&
    Dim RetVal&, RetFromMsg%
    DriveLetter = UCase(Drive1.Drive)
    DriveNumber = (Asc(DriveLetter) - 65) ' Cambiar la letra a número: A=0
    DriveType = GetDriveType(DriveLetter)
    'If DriveType = 2 Then  'Disquetes, etc
    RetVal = SHFormatDrive(Me.hwnd, DriveNumber, 0&, 0&)

La declaración del API para GetDriveType:

Declare Function GetDriveType Lib "kernel32" Alias "GetDriveTypeA" _
		(ByVal nDrive As String) As Long

 

3.- Sobre los recursos en 32bits (un código de Joe LeVasseur) (31/May)

Pues eso, el amigo Joe me ha enviado una función "wrapera" que sirve para mostrar los recursos en aplicaciones de 32 bits.
Aquí te pongo las declaración de la función y un ejemplo de cómo usarla.

Gracias Joe.

'--------
' RSRC32.DLL es el DLL 32Bit que use Win95/NT para "Thunking"
' del API antiguo. Windows lo use con RSRCMTR.EXE .
' (Otro API sin documentacion...) JTL (;-)
'---------
Private Declare Function RecursosDeSistema Lib "rsrc32.dll" _
Alias "_MyGetFreeSystemResources32@4" (ByVal restype As Integer) As Integer
'---------
Const GFSR_SYSTEMRESOURCES = &H0
Const GFSR_GDIRESOURCES = &H1
Const GFSR_USERRESOURCES = &H2
    Dim iSystem%, iGDI%, iUser%
    iSystem = RecursosDeSistema(GFSR_SYSTEMRESOURCES)
    iGDI = RecursosDeSistema(GFSR_GDIRESOURCES)
    iUser = RecursosDeSistema(GFSR_USERRESOURCES)
    lblRecursos(3) = iSystem & "%"
    lblRecursos(4) = iGDI & "%"
    lblRecursos(5) = iUser & "%"

 

5.- Averiguar el espacio libre de una unidad de disco (32 bits) (20/Jun)

Esta es otra función del API de 32 bits, la pongo aquí a resultas de una respuesta de las news sobre el API (en inglés)
Está en una función a la que hay que pasarle como parámetro el nombre de la unidad y devuelve el tamaño disponible.

'Declaración del API de 32 bits.
Declare Function GetDiskFreeSpace Lib "kernel32" Alias "GetDiskFreeSpaceA" _
(ByVal lpRootPathName As String, lpSectorsPerCluster As Long, lpBytesPerSector As Long, _
lpNumberOfFreeClusters As Long, lpTotalNumberOfClusters As Long) As Long
Private Function EspacioLibre(ByVal lpRootPathName As String)
'lpRootPathName= Directorio raiz de la unidad a examinar

'Valores devueltos por la función:
'lpSectorsPerCluster = sectores por cluster
'lpBytesPerSector = bytes por sector
'lpNumberOfFreeClusters = número de clusters libres
'lpTotalNumberOfClusters = número de clusters en el disco

Dim lpSectorsPerCluster As Long
Dim lpBytesPerSector As Long
Dim lpNumberOfFreeClusters As Long
Dim lpTotalNumberOfClusters As Long
Dim ret&
Dim TotalBytes As Long

    ret = GetDiskFreeSpace(lpRootPathName, lpSectorsPerCluster, _
            lpBytesPerSector, lpNumberOfFreeClusters, lpTotalNumberOfClusters)

    TotalBytes = lpTotalNumberOfClusters * lpSectorsPerCluster * lpBytesPerSector
    EspacioLibre = Format(TotalBytes, "###,###,###")
End Function

Nota 18/Abr/98: Para averiguar el espacio libre en unidades de más de 2GB échale un vistazo a esto:
El espacio de las unidades grandes (más de 2GB)


 

6.- Nombre del usuario actual de Windows (32bits) (8/Jul)

Otra rutinilla del API de Windows, en esta ocasión para saber el nombre del usuario actual. Es decir el que ha empezado la sesión de Windows. Lo he probado con Windows 95, pero con NT debería funcionar pero no está comprobado.

El código mostrado supone que tienes la declaración en un módulo BAS, en caso de que lo uses en un FRM o CLS, deberás poner delante Private.

Si quieres bajar los listados y un form de comprobación, pulsa este link (usuario.zip 1.38 KB)

'API para obtener el usuario actual
Declare Function GetUserName Lib "advapi32.dll" Alias "GetUserNameA" _
    (ByVal lpbuffer As String, nSize As Long) As Long

'Esta función devuelve el nombre del Usuario
Public Function UsuarioActual() As String
    Dim sBuffer As String
    Dim lSize As Long
    Dim sUsuario As String

    sBuffer = Space$(260)
    lSize = Len(sBuffer)
    Call GetUserName(sBuffer, lSize)
    If lSize > 0 Then
        sUsuario = Left$(sBuffer, lSize)
        'Quitarle el CHR$(0) del final...
        lSize = InStr(sUsuario, Chr$(0))
        If lSize Then
            sUsuario = Left$(sUsuario, lSize - 1)
        End If
    Else
        sUsuario = ""
    End If
    UsuarioActual = sUsuario
End Function

 

7.- Número de líneas, posición del primer caracter de una línea y longitud (en un TextBox) (3/Sep)

Esta es una variante de la ya presentada anteriormente. Pero además permite saber la longitud en caracteres de una línea.
Lo he usado en la
rutina genérica de impresión.
Una de las cosas que algunos habéis consultado, a mí y en otros sitios, es cómo poder obtener cada una de las líneas de un control TextBox Multiline, creo que para el RichTextBox no serviría, pero es cuestión de comprobarlo.
Como esta sección/apartado está dedicada al API, como comprobarás es precisamente la función SendMessage la que se usa para conseguir nuestro propósito. La declaración la tienes en la otra
página del API, así que aquí sólo voy a poner la forma de usarla y el valor de las constantes para cada una de estas tres cosas.

'Las constantes:
    Const EM_GETLINECOUNT = &HBA	'Número de líneas
    Const EM_LINEINDEX = &HBB		'Posición del primer caracter de la línea actual
    Const EM_LINELENGTH = &HC1		'Longitud de una línea

'Número de líneas del TextBox:
NumLineas = SendMessage(unTextBox.hWnd, EM_GETLINECOUNT, 0, 0&)
'Posición del primer carácter de la línea X:
L1 = SendMessage(unTextBox.hWnd, EM_LINEINDEX, X, 0&) + 1
'Longitud, en caracteres, de la línea que empieza por el caracter L1:
L2 = SendMessage(unTextBox.hWnd, EM_LINELENGTH, L1, 0&)


'Forma de usarlo todo junto:
NumLineas = SendMessage(unTextBox.hWnd, EM_GETLINECOUNT, 0, 0&)

For X = 0 To NumLineas - 1
    L1 = SendMessage(unTextBox.hWnd, EM_LINEINDEX, X, 0&) + 1
    L2 = SendMessage(unTextBox.hWnd, EM_LINELENGTH, L1, 0&)
    'Contenido de la línea X:
    Linea$ = Mid$(unTextBox.Text, L1, L2)
    '...
Next

 

8.- Bitmaps en los menús, usando API ¡claro! (15/Sep)

Este ejemplo lo mandaron a la lista de VB-ESP y lo pongo en este link para el que quiera usarlo, es para VB5.
Según parece es de Alexander Forbes.
Si tienes VB3 o VB4-16 bits, puedes usar el ejemplo de
Jordi Garcia Busquets (API-Menú).

Baja los listados de ejemplo. (IcoMenu.zip 2.85 KB)


 

9.- Ejecutar cualquier programa usando el API (un truco de Joe LeVasseur) (15/Sep)

Este es un código del amigo Joe LeVasseur y sirve para ejecutar cualquier programa, archivo asociado, lo que quieras.
Aquí pongo el código y el comentario del colega Joe.

 ShellExecute es como hacer doble-click
sobre un archivo en el Explorer.
 Un saludo desde Connecticut, EEUU
 Joe LeVasseur

PS - Para VB4/5 32bit

***********************************************************
Joe LeVasseur lvasseur@tiac.net  a0@null.net
Microsoft Dev MVP- Visual Basic
"To none will we sell, to none deny or delay,
right or justice." Magna Carta  (June 15, 1215)
**********************************************************


Option Explicit

Private Declare Function ShellExecute Lib "shell32.dll" Alias _
    "ShellExecuteA" (ByVal hwnd As Long, ByVal lpOperation As String, _
    ByVal lpFile As String, ByVal lpParameters As String, _
    ByVal lpDirectory As String, ByVal nShowCmd As Long) As Long

Private Sub Command1_Click()
    Dim lValDev     As Long
    lValDev = ShellExecute(Me.hwnd, "Open", "c:\splash.mid", _
        "", "", 1)
End Sub

 

10.- Cambiar el fondo del escritorio de Windows (WallPaper) (17/Sep)

Con este código podrás cambiar la imagen del fondo de Windows, está tomado de los Tips de Microsoft:
Tip 211: Changing or Removing the Desktop Wallpaper in Visual Basic 4.0
Este es el código a usar:

Private Declare Function SystemParametersInfo Lib "user32" Alias "SystemParametersInfoA" _
	(ByVal uAction As Long, ByVal uParam As Long, _
	ByVal lpvParam As String, ByVal fuWinIni As Long) As Long
Const SPIF_UPDATEINIFILE = &H1
Const SPI_SETDESKWALLPAPER = 20
Const SPIF_SENDWININICHANGE = &H2


Private Sub Command1_Click()
    Dim X As Long

    X = SystemParametersInfo(SPI_SETDESKWALLPAPER, 0&, "(None)", _
       SPIF_UPDATEINIFILE Or SPIF_SENDWININICHANGE)

    MsgBox "Wallpaper was removed"
End Sub


Private Sub Command2_Click()
    Dim FileName As String
    Dim X As Long

    'Usa aquí el bitmap que quieres usar
    FileName = "c:\windows\pinstripe.bmp"

    X = SystemParametersInfo(SPI_SETDESKWALLPAPER, 0&, FileName, _
       SPIF_UPDATEINIFILE Or SPIF_SENDWININICHANGE)

    MsgBox "Wallpaper was changed"
End Sub

 

11.- Usando MSGBLAST para manejar mensajes de Windows (VB3/VB4-16 y VB4-32) (22/Sep)

Unos listados de ejemplo para mostrar un mensaje en algún tipo de Status-Bar cuando nos movemos por los items de un menú.
Los listados de ejemplo son para VB3 (o VB4-16 bits) y para VB4-32 bits.
Pulsa estos links para bajarlos:
Ejemplo de 16 bits (1.89 KB) - Ejemplo de 32 bits (2.21 KB)

Para el ejemplo de 16 bits necesitas el Msgblast.VBX que puedes bajarte del ejemplo de Jordi García Busquets: (27.5 KB)

Para el de 32 bits necesitas bajarte e instalar el MsgBlast.OCX (caduca a los 30 días de instalarlo), el archivo está comprimido y ocupa un mega aprox., por tanto lo he "troceado" con
el Cut-It (23.4 KB), el cual necesitarás para poder unirlos:
Estos links bajarán cada uno de los trozos:
Trozo 1, Trozo 2, Trozo 3, Tozo 4, Trozo 5, el de configuración.

Si tienes problemas con el archivo de configuración, copia esto y lo pegas con el nombre: msgBlastOCX.cIt

D:\WareWithAll\Controls\Samples\MenuStuf\msgBlastOCX.zip
 1051351  ;Tamaño original del archivo
23/09/97 0:48:04
 5  ;Número de trozos
Archivo troceado el 23/09/1997 02:10:53
 224  ;Tamaño máximo de cada trozo
 32  ;KB por bucle

Nota: También puedes unir los trozos de esta forma:
copy /B msgBlastOCX.C01+msgBlastOCX.C02+msgBlastOCX.C03+msgBlastOCX.C04+msgBlastOCX.C05 msgBlastOCX.zip


 

13.- ¿Cómo evitar el uso de CTRL+ALT+SUPR y ALT+TAB? (sólo en Win95) (5/Oct)

Pues usando el API, como casi siempre.
Este truco/comentario, está sacado de las Knowledge Base de Microsoft:
HOWTO: Block CTRL+ALT+DEL and ALT+TAB in Windows 95 - Article ID: Q161133
Así que si quieres el original en inglés ya sabes dónde buscarlo. Resumiendo lo que dicen es que sólo es posible hacerlo en Windows 95 y que seguramente en futuras versiones no estará soportado. Además de las habituales precauciones, ya que si no se pueden usar estas teclas y "casca" el programa... no te digo lo que tendrás que hacer...
Aquí está la declaración de la función que lo permite y un poco de ejemplo para poder hacerla funcionar.

'Declaración de la función:
Private Const SPI_SCREENSAVERRUNNING = 97&
Private Declare Function SystemParametersInfo Lib "User32" Alias "SystemParametersInfoA" _
		(ByVal uAction As Long, ByVal uParam As Long, _
		lpvParam As Any, ByVal fuWinIni As Long) As Long

'Para deshabilitar estas teclas:
    Dim lngRet As Long
    Dim blnOld As Boolean
    lngRet = SystemParametersInfo(SPI_SCREENSAVERRUNNING, _
				  True, blnOld, 0&)

'Para volver a habilitarlas:
    Dim lngRet As Long
    Dim blnOld As Boolean
    lngRet = SystemParametersInfo(SPI_SCREENSAVERRUNNING, _
				  False, blnOld, 0&)

Como recomendación final: asegúrate que en el Form_Unload que tengas, haga una llamada a la rutina que vuelve a habilitar estas teclas, así todo volverá a estar como debiera.


 

14.- ¿Cómo enviar archivos a la papelera de reciclaje? (VB-32 bits) (12/Oct)

Nota del 26/May/2004:
Para Windows XP mira las declaraciones de esta otra página.

Otro truco sacado de las Knowledge Base de Microsoft:
HOWTO: Use the Windows 95 Copy and Recycle Functions in VB - Article ID: Q165919
También: Tip 176: Sending Files to the Recycle Bin in Visual Basic 4.0

De este segundo es este listado, que he modificado a mis preferencias, sobre todo en el tema de la ubicación de las declaraciones y eso, poca cosa, lo sé, pero algo es algo.
Voy a preparar un ejemplo/utilidad para poder usar las funciones del API para copiar/mover/borrar, etc. que es lo que más o menos se explica en el primero de los dos artículos mencionados, pero no lo veo lo suficientemente claro como para que sea fácilmente "usable" y entendible... (a lo mejor es que soy demasiado torpe...)

'Crea un módulo BAS e inserta estas declaraciones:

Type SHFILEOPSTRUCT
    hWnd As Long
    wFunc As Long
    pFrom As String
    pTo As String
    fFlags As Integer ' As Long para que funcione en Windows XP con VB6
    fAborted As Boolean
    hNameMaps As Long
    sProgress As String
End Type


Public Const FO_DELETE = &H3
Public Const FOF_ALLOWUNDO = &H40
Declare Function SHFileOperation Lib "shell32.dll" Alias "SHFileOperationA" _
	(lpFileOp As SHFILEOPSTRUCT) As Long


Public Function ShellDelete(ParamArray vntFileName() As Variant) As Long

    Dim I As Integer
    Dim sFileNames As String
    Dim SHFileOp As SHFILEOPSTRUCT

    For I = LBound(vntFileName) To UBound(vntFileName)
	sFileNames = sFileNames & vntFileName(I) & vbNullChar
    Next
    sFileNames = sFileNames & vbNullChar

    With SHFileOp
        .wFunc = FO_DELETE
        .pFrom = sFileNames
        .fFlags = FOF_ALLOWUNDO
    End With

    ShellDelete = SHFileOperation(SHFileOp)

End Function


'En un formulario, inserta un botón Command y escribe esto:

Private Sub Command1_Click()
    Dim FileToKill As String

    'Escribe aquí el archivo a borrar
    FileToKill = "c:\test*.txt"
    ShellDelete FileToKill
    MsgBox "File(s) deleted"
End Sub

Para probarlo, simplemente pulsa F5, deberás tener el archivo que quieres borrar... sino ¿cómo lo vas a borrar? 8-)


 

15.- ¿Cómo desplegar y contraer el contenido de un ComboBox? (16 y 32 bits) (29/Oct)

Seguimos con los trucos que estoy "recogiendo" de las Knowledge Base de Microsoft. En este caso es para hacer que se despliegue o se contraiga el contenido de un ComboBox. Nuevamente gracias a nuestra amiga SendMessage.
Este es el listado de ejemplo y las declaraciones.

#If Win32 Then
'Declaraciones para 32 bits
Declare Function SendMessage Lib "user32" Alias "SendMessageA" _
	(ByVal hwnd As Long, ByVal wMsg As Long, _
	ByVal wParam As Long, lParam As Any) As Long

Const CB_SHOWDROPDOWN = &H14F

#Else
'Declaraciones para 16 bits
Declare Function SendMessage Lib "User" _
	(ByVal hWnd As Integer, ByVal wMsg As Integer, _
	ByVal wParam As Integer, lParam As Any) As Long

Const WM_USER = &H400
Const CB_SHOWDROPDOWN = (WM_USER + 15)

#End If

'Para que se despliegue:
Call SendMessage(Combo1.hWnd, CB_SHOWDROPDOWN, 1, 0&)

'Para que se contraiga:
Call SendMessage(Combo1.hWnd, CB_SHOWDROPDOWN, 0, 0&)

 

16.- Esperar a que un programa termine (incluso si es de MS-DOS) (32 bits) (31/Oct)

Una forma muchísimo más simplificada de la rutina que usaba hasta ahora, por supuesto, gracias al API.
Esta forma de hacerlo sólo es para 32 bits, para 16 bits lo puedes ver en:
Especial Shell
La ventana se mostrará minimizada y sin foco.
No recuerdo si esta rutina la saqué de la Knowledge Base, lo que si es seguro es que fue del CD del MSDN-Library.


NOTA: Si se va a enviar un comando del DOS, se debe usar con:
Command /C <orden a ejecutar|fichero.bat>
sino, no se cerrará la ventana y el proceso no terminará, al menos algunas veces.

'Las declaraciones
Private Declare Function OpenProcess Lib "kernel32" _
    (ByVal dwDesiredAccess As Long, ByVal bInheritHandle As Long, _
    ByVal dwProcessId As Long) As Long

Private Declare Function GetExitCodeProcess Lib "kernel32" _
    (ByVal hProcess As Long, lpExitCode As Long) As Long

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

Const STILL_ACTIVE = &H103
Const PROCESS_QUERY_INFORMATION = &H400


'Un procedimiento para ejecutar y esperar a que termine
Private Sub ExecCmdNoFocus(ByVal CmdLine As String)
    'Esperar a que un proceso termine,
    'la ventana se mostrará minimizada sin foco
    Dim hProcess As Long
    Dim RetVal As Long

    'The next line launches CmdLine as icon,
    'captures process ID
    hProcess = OpenProcess(PROCESS_QUERY_INFORMATION, False, _
			Shell(CmdLine, vbMinimizedNoFocus))
    Do
        'Get the status of the process
        GetExitCodeProcess hProcess, RetVal
        'Sleep command recommended as well
        'as DoEvents
        DoEvents
        Sleep 100
    'Loop while the process is active
    Loop While RetVal = STILL_ACTIVE
End Sub

 

17.- Comprobar si existe un fichero, usando el API, claro. (FileExist) (32 bits) (31/Oct)

Realmente no es necesaria, ya que es fácil de hacer con el DIR$, pero es bastante, al menos debería serlo, más rápida que la susodicha instrucción del VB.
Aquí tienes las declaraciones del API y la función.

'Tipos, constantes y funciones para FileExist
Const MAX_PATH = 260
Const INVALID_HANDLE_VALUE = -1

Private Type FILETIME
        dwLowDateTime       As Long
        dwHighDateTime      As Long
End Type

Private Type WIN32_FIND_DATA
        dwFileAttributes    As Long
        ftCreationTime      As FILETIME
        ftLastAccessTime    As FILETIME
        ftLastWriteTime     As FILETIME
        nFileSizeHigh       As Long
        nFileSizeLow        As Long
        dwReserved0         As Long
        dwReserved1         As Long
        cFileName           As String * MAX_PATH
        cAlternate          As String * 14
End Type

Private Declare Function FindFirstFile Lib "kernel32" Alias "FindFirstFileA" _
    (ByVal lpFileName As String, lpFindFileData As WIN32_FIND_DATA) As Long
Private Declare Function FindClose Lib "kernel32" _
    (ByVal hFindFile As Long) As Long



Public Function FileExist(ByVal sFile As String) As Boolean
    'comprobar si existe este fichero
    Dim WFD As WIN32_FIND_DATA
    Dim hFindFile As Long

    hFindFile = FindFirstFile(sFile, WFD)
    'Si no se ha encontrado
    If hFindFile = INVALID_HANDLE_VALUE Then
        FileExist = False
    Else
        FileExist = True
        'Cerrar el handle de FindFirst
        hFindFile = FindClose(hFindFile)
    End If

End Function


'Para usarla:
If FileExist("lo que quieras comprobar") Then
	'El archivo existe
Else
	'El archivo no existe
End If

 

18.- Reiniciar Windows (2ª parte) revisado para Windows NT (22/Nov)

Aquí incluyo un poco de más información sobre como reiniciar Windows, en esta ocasión está comprobado en el NT, gracias a Ignacio Sanz iiss@hotmail.com, por haber hecho la comprobación.
Este código de ejemplo está sacado de la Microsoft Knowledge Base, es el artículo titulado: HOWTO: Shutdown Windows NT and Windows 95 from Visual Basic Code. Que tampoco me gusta marcarme "faroles".

 

'El código

      ' Tipos definidos
      Private Type LUID
         UsedPart As Long
         IgnoredForNowHigh32BitPart As Long
      End Type

      Private Type TOKEN_PRIVILEGES
         PrivilegeCount As Long
         TheLuid As LUID
         Attributes As Long
      End Type

      ' Las constantes
      Private Const EWX_SHUTDOWN As Long = 1
      Private Const EWX_FORCE As Long = 4
      Private Const EWX_REBOOT = 2

      ' Las funciones del API
      Private Declare Function ExitWindowsEx Lib "user32" ( _
         ByVal dwOptions As Long, ByVal dwReserved As Long) As Long

      Private Declare Function GetCurrentProcess Lib "kernel32" () As Long
      Private Declare Function OpenProcessToken Lib "advapi32" _
	(ByVal ProcessHandle As Long, ByVal DesiredAccess As Long, _
         TokenHandle As Long) As Long
      Private Declare Function LookupPrivilegeValue Lib "advapi32" Alias "LookupPrivilegeValueA" _
	(ByVal lpSystemName As String, ByVal lpName As String, lpLuid As LUID) As Long
      Private Declare Function AdjustTokenPrivileges Lib "advapi32" _
	(ByVal TokenHandle As Long, ByVal DisableAllPrivileges As Long, _
         NewState As TOKEN_PRIVILEGES, ByVal BufferLength As Long, _
         PreviousState As TOKEN_PRIVILEGES, ReturnLength As Long) As Long

      ' Código para poner en el formulario
      Private Sub AdjustToken()
         Const TOKEN_ADJUST_PRIVILEGES = &H20
         Const TOKEN_QUERY = &H8
         Const SE_PRIVILEGE_ENABLED = &H2
         Dim hdlProcessHandle As Long
         Dim hdlTokenHandle As Long
         Dim tmpLuid As LUID
         Dim tkp As TOKEN_PRIVILEGES
         Dim tkpNewButIgnored As TOKEN_PRIVILEGES
         Dim lBufferNeeded As Long

         hdlProcessHandle = GetCurrentProcess()
         OpenProcessToken hdlProcessHandle, (TOKEN_ADJUST_PRIVILEGES Or _
            TOKEN_QUERY), hdlTokenHandle

         ' Get the LUID for shutdown privilege.
         LookupPrivilegeValue "", "SeShutdownPrivilege", tmpLuid

         tkp.PrivilegeCount = 1    ' One privilege to set
         tkp.TheLuid = tmpLuid
         tkp.Attributes = SE_PRIVILEGE_ENABLED

         ' Enable the shutdown privilege in the access token of this
         ' process.
         AdjustTokenPrivileges hdlTokenHandle, False, tkp, _
            Len(tkpNewButIgnored), tkpNewButIgnored, lBufferNeeded

      End Sub

      Private Sub cmdForceShutdown_Click()
         AdjustToken
         ExitWindowsEx (EWX_SHUTDOWN Or EWX_FORCE Or EWX_REBOOT), &HFFFF
      End Sub

 


 

19.- Averiguar el espacio libre de una unidad de disco (16 bits) (16/Dic)

Esto ya está en el listado del Sentinel (en la página de Gratisware) y está sacado/adaptado del Setup que se incluye con el VB.
La función usada está en la librería StKit416.dll

 
'Función para leer el espacio libre de los discos (del Setup1 de Visual Basic
Private Declare Function DiskSpaceFree Lib "StKit416.dll" () As Long


Function EspacioLibre(D As String) As Currency
    Dim TSpace As Long

    TSpace = GetDiskSpaceFree(D)

    'Devuelve el valor em Megas
    EspacioLibre = TSpace / (1024& * 1024&)
End Function


'-----------------------------------------------------------
' FUNCTION: GetDiskSpaceFree
' Get the amount of free disk space for the specified drive
'
' IN: [strDrive] - drive to check space for
'
' Returns: Amount of free disk space, or -1 if an error occurs
'-----------------------------------------------------------
'
Function GetDiskSpaceFree(ByVal strDrive As String) As Long
    Dim strCurDrive As String
    Dim lDiskFree As Long
    Const gstrCOLON = ":"

    On Local Error Resume Next
    '
    'Save the current drive
    '
    strCurDrive = Left$(CurDir$, 2)
    '
    'Fixup drive so it includes only a drive letter and a colon
    '
    If InStr(strDrive, gstrCOLON) = 0 Or Len(strDrive) > 2 Then
        strDrive = Left$(strDrive, 1) & gstrCOLON
    End If
    '
    'Change to the drive we want to check space for.  The DiskSpaceFree() API
    'works on the current drive only.
    '
    ChDrive strDrive
    '
    'If we couldn't change to the request drive, it's an error, otherwise return
    'the amount of disk space free
    '
    If Err <> 0 Or (strDrive <> Left$(CurDir$, 2)) Then
        lDiskFree = -1
    Else
        lDiskFree = DiskSpaceFree()
        If Err <> 0 Then    'If Setup Toolkit's DLL couldn't be found
            lDiskFree = -1
        End If
    End If
    '
    GetDiskSpaceFree = lDiskFree
    '
    'Cleanup by setting the current drive back to the original
    '
    ChDrive strCurDrive

    Err = 0
End Function

 

20.- Tocar un archivo de forma indefinida y repetitiva (10/Abr/98)

Para conseguir esto de que un fichero de sonido se toque de forma "asíncrona" y que no acabe nunca, es decir que siga tocando cuando se acabe, se logra con unos parámetros que se le da a la función del API que hace sonar un fichero WAV.
NOTA: Sobre los MIDs estoy intentando encontrar la forma de que toquen de forma repetitiva...

Aquí tienes las declaraciones y los valores de las constantes a usar:

 
Declare Function sndPlaySound Lib "winmm.dll" Alias "sndPlaySoundA" _
	(ByVal lpszSoundName As String, ByVal uFlags As Long) As Long


Const SND_ASYNC = &H1     'modo asíncrono. La función retorna una vez iniciada la música (sonido en background).
Const SND_LOOP = &H8      'La música seguirá sonando repetidamente hasta
                          'que la función sndPlaySound sea llamada de nuevo con un valor nulo para NombreWav (NULL).


'Para tocar un WAV de forma repetitiva, lo llamas así:
Call sndPlaySound(Archivo, SND_ASYNC + SND_LOOP)

'Para detener lo que se esté tocando
Call sndPlaySound(ByVal "", 0)

 

21.- Un ejemplo, usando API, de cómo tocar de forma indefinida un fichero MIDI (10/Abr/98)

Pulsa en este link para ir a la página con el ejemplo.


 

22.- Saber el nombre de nuestro equipo (32 bits) (14/Abr/98)

Usa el siguiente código para averiguar el nombre de tu equipo...

Declare Function GetComputerName Lib "kernel32" Alias "GetComputerNameA" _
	(ByVal lpBuffer As String, nSize As Long) As Long

Public Const MAX_COMPUTERNAME_LENGTH = 255


Public Function ComputerName() As String
    'Devuelve el nombre del equipo actual
    Dim sComputerName As String
    Dim ComputerNameLength As Long

    sComputerName = String(MAX_COMPUTERNAME_LENGTH + 1, 0)
    ComputerNameLength = MAX_COMPUTERNAME_LENGTH
    Call GetComputerName(sComputerName, ComputerNameLength)
    ComputerName = Mid(sComputerName, 1, ComputerNameLength)
End Function

 


ir al índice