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
'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 LongEjemplo 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 If6.- 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 if7.- 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 FunctionPara 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 SubEjemplo 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 LongUna 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 LongNo 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 Sub11.- 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 Sub12.- 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 IfPor 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 SubAhora 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 1Const 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&) + 117.- 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...