Actualizado el 26/May/2004
Pulsa aquí para ver todos los links del API
Funciones y ejemplos:
- Buscar en un ComboBox o ListBox usando el API
- SHFormatDrive: Formatear un disco usando el API (y GetDriveType para saber que tipo de unidad es)
- Sobre los recursos en 32bits (un código de Joe LeVasseur)
- Saber el tipo de una unidad de disco y si es un CDROM (16 y 32 bits)
- Averiguar el espacio libre de una unidad de disco (32 bits)
- Nombre del usuario actual de Windows (32 bits)
- Número de líneas, posición del primer caracter de una línea y longitud (en un TextBox)
- Bitmaps en los menús, usando API ¡claro!
- Ejecutar cualquier programa usando el API (un truco de Joe LeVasseur)
- Cambiar el fondo del escritorio de Windows (WallPaper)
- Usando MSGBLAST para manejar mensajes de Windows (VB3/VB4-16 y VB4-32)
- Reiniciar Windows (listados para 16 y 32 bits)
- ¿Cómo evitar el uso de CTRL+ALT+SUPR y ALT+TAB? (sólo Win95)
- ¿Cómo enviar archivos a la papelera de reciclaje? (VB-32 bits) (rev. 26/May/04)
- ¿Cómo desplegar y contraer el contenido de un ComboBox? (16 y 32 bits)
- Esperar a que un programa termine (incluso si es de MS-DOS) (32 bits)
- Comprobar si existe un fichero, usando el API, claro. (FileExist)
- Reiniciar Windows (2ª parte) revisado para Windows NT
- Averiguar el espacio libre de una unidad de disco (16 bits)
- Tocar un archivo de forma indefinida y repetitiva (sólo WAVs)
- Un ejemplo, usando API, de cómo tocar de forma indefinida un fichero MIDI
- 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 ListBoxLa 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 IfEl 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 FunctionEste 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 Sub2.- 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 LongLa 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 Long3.- 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 = &H2Dim 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 LongPrivate 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 FunctionNota 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 Function7.- 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) '... Next8.- 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 [email protected] [email protected] 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 Sub10.- 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 Sub11.- 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 bucleNota: También puedes unir los trozos de esta forma:
copy /B msgBlastOCX.C01+msgBlastOCX.C02+msgBlastOCX.C03+msgBlastOCX.C04+msgBlastOCX.C05 msgBlastOCX.zip13.- ¿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.0De 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 SubPara 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 Sub17.- 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 If18.- 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 [email protected], 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 Function20.- 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