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 [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 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 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 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
[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 Function
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)
Pulsa en este link para ir a la página con el ejemplo.
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
