Codigos Fuente

|


Preguntar

|


Comunicaciones

|


Tutoriales

|


Contactenos

 


  Buscador del Site  

 

 Se Recomienda Resolución de 800x600 pixels


 

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

'Declaración del API de 16 bits

Declare Function SendMessage Lib "User" _

                (ByVal hWnd As Integer, ByVal wMsg As Integer, _

                 ByVal wParam As Integer, lParam As Any) As Long

'Declaración del API de 32 bits.

Declare Function SendMessage Lib "User32" Alias "SendMessageA" _

                (ByVal hwnd As Long, ByVal wMsg As Long, _

                 ByVal wParam As Long, lParam As Long) As Long

'Utilidades para un menú de edición:

'Declaración de las constantes

Global Const WM_USER = &H400

Global Const EM_GETSEL = WM_USER + 0

Global Const EM_SETSEL = WM_USER + 1

Global Const EM_REPLACESEL = WM_USER + 18

Global Const EM_UNDO = WM_USER + 23

Const EM_LINEFROMCHAR = WM_USER + 25

Const EM_GETLINECOUNT = WM_USER + 10

'

Global Const WM_CUT = &H300

Global Const WM_COPY = &H301

Global Const WM_PASTE = &H302

Global Const WM_CLEAR = &H303

'

'Deshacer:

    'Nota: si se hace de esta forma,

    'no es necesario usar una variable para asignar el valor devuelto.

    If SendMessage(Screen.ActiveForm.ActiveControl.hWnd, EM_UNDO, 0, ByVal 0&) Then

    End If

    'también: x = SendMessage(Screen.ActiveForm.ActiveControl.hWnd, EM_UNDO, 0, ByVal 0&)

'Copiar:

    If SendMessage(Screen.ActiveForm.ActiveControl.hWnd, WM_COPY, 0, ByVal 0&) Then

    End If

'Cortar:

    If SendMessage(Screen.ActiveForm.ActiveControl.hWnd, WM_CUT, 0, ByVal 0&) Then

    End If

'Borrar:

    If SendMessage(Screen.ActiveForm.ActiveControl.hWnd, WM_CLEAR, 0, ByVal 0&) Then

    End If

'Pegar:

    If SendMessage(Screen.ActiveForm.ActiveControl.hWnd, WM_PASTE, 0, ByVal 0&) Then

    End If

'Seleccionar Todo:

    If SendMessage(Screen.ActiveForm.ActiveControl.hWnd, EM_SETSEL, 0, ByVal &HFFFF0000) Then

    End If

  

'Crear un TextBox con 64 KB en lugar de 32

Global Const WM_USER = &H400

Global Const EM_LIMITTEXT = WM_USER + 21

 

Dim LTmp As long

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

2.- SetWindowWord: crear ventanas flotantes

Declare Function SetWindowWord Lib "User" (ByVal hWnd As Integer, ByVal nIndex As Integer, ByVal wNewWord As Integer) As Integer

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

  

'Crear una ventana flotante al estilo de los tool-bar

'Cuando se minimiza la ventana padre, también lo hace ésta.

Const SWW_hParent = -8

 

'En Form_Load (suponiendo que la ventana padre es Form1)

If SetWindowWord(hWnd, SWW_hParent, form1.hWnd) Then

End If

3.- Manejo de ventanas...

'Declaración de Funciones para tomar las listas de tareas

Declare Function GetWindow Lib "user" (ByVal hWnd As Integer, ByVal wCmd As Integer) As Integer

Declare Function GetWindowText Lib "user" (ByVal hWnd As Integer, ByVal lpString As String, ByVal nMaxCount As Integer) As Integer

Declare Function GetWindowTextLength Lib "user" (ByVal hWnd As Integer) As Integer

Declare Function IsWindowVisible Lib "User" (ByVal hWnd As Integer) As Integer

'Declaraciones para 32 bits

Declare Function GetWindow Lib "user32" Alias "GetWindow" (ByVal hwnd As Long, ByVal wCmd As Long) As Long

Declare Function GetWindowText Lib "user32" Alias "GetWindowTextA" (ByVal hwnd As Long, ByVal lpString As String, ByVal cch As Long) As Long

Declare Function GetWindowTextLength Lib "user32" Alias "GetWindowTextLengthA" (ByVal hwnd As Long) As Long

Declare Function IsWindowVisible Lib "user32" (ByVal hwnd As Long) As Long

 

'Constantes para GetWindow

Const GW_HWNDFIRST = 0

Const GW_HWNDLAST = 1

Const GW_HWNDNEXT = 2

Const GW_HWNDPREV = 3

Const GW_OWNER = 4

Const GW_CHILD = 5

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

Declare Function GetVolumeInformation Lib "Kernel32" Alias "GetVolumeInformationA" (ByVal lpRootPathName As String, ByVal lpVolumeNameBuffer As String, ByVal nVolumeNameSize As Long, lpVolumeSerialNumber As Long, lpMaximumComponentLength As Long, lpFileSystemFlags As Long, ByVal lpFileSystemNameBuffer As String, ByVal nFileSystemNameSize As Long) As Long

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

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

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

5.- GetDriveType: comprobar el tipo de unidad

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

'Valores de retorno de GetDriveType

Public Const DRIVE_REMOVABLE = 2

Public Const DRIVE_FIXED = 3

Public Const DRIVE_REMOTE = 4

'Estos tipos no están en el fichero de las declaraciones del API de 16 bits

Public Const DRIVE_CDROM = 5

Public Const DRIVE_RAMDISK = 6

'

Declare Function GetDriveType Lib "Kernel" (ByVal nDrive As Integer) As Integer

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

 

 

Dim lDrive As Long

Dim szRoot As String

 

szRoot="D:\" 'Poner aquí la unidad del CD-ROM o la que queramos comprobar

lDrive= GetDriveType(szRoot)

If lDrive = DRIVE_CDROM Then

    'Es un CD-ROM/Compact-Disc

End If

6.- Dejar una ventana siempre visible

De nuevo usaremos el API de Windows: SetWindowPos

'Declaración para usar ventanas siempre visibles

'Versión para 16 bits

Declare Function SetWindowPos Lib "User" (ByVal hWnd As Integer, ByVal hWndInsertAfter As Integer, ByVal X As Integer, ByVal Y As Integer, ByVal cx As Integer, ByVal cy As Integer, ByVal wFlags As Integer) As Integer

'Versión para 32 bits

Declare Function SetWindowPos Lib "User32" Alias "SetWindowPos" (ByVal hwnd As Long, ByVal hWndInsertAfter As Long, ByVal x As Long, ByVal y As Long, ByVal cx As Long, ByVal cy As Long, ByVal wFlags As Long) As Long

 

 

' SetWindowPos Flags

Const SWP_NOSIZE = &H1

Const SWP_NOMOVE = &H2

'Const SWP_NOZORDER = &H4

'Const SWP_NOREDRAW = &H8

Const SWP_NOACTIVATE = &H10

'Const SWP_DRAWFRAME = &H20

Const SWP_SHOWWINDOW = &H40

'Const SWP_HIDEWINDOW = &H80

'Const SWP_NOCOPYBITS = &H100

'Const SWP_NOREPOSITION = &H200

Const SWP_FLAGS = SWP_NOMOVE Or SWP_NOSIZE Or SWP_SHOWWINDOW Or SWP_NOACTIVATE

  

'Código para poner en Form_Load

 

'De esta forma no es necesario usar una variable para asignar el valor devuelto:

If SetWindowPos(hWnd, -1, 0, 0, 0, 0, SWP_FLAGS) Then

End if

  7.- Usar Sleep en lugar de DoEvents

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

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

while (PeekMessage(&msg, NULL, 0, 0, PM_REMOVE)) {

                TranslateMessage(&msg);

                DispatchMessage(&msg);

}  

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

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

Y se puede llamar de la siguiente forma:

Sleep 0&

 8.- Manejo del Registro del Sistema

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

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

Public Const HKEY_CLASSES_ROOT = &H80000000

 

Declare Function RegQueryValue Lib "advapi32.dll" Alias "RegQueryValueA" _

                (ByVal hKey As Long, ByVal lpSubKey As String, ByVal lpValue As String, _

                 lpcbValue As Long) As Long

 

'Busca una entrada en el registro

Private Function QueryRegBase(ByVal Entry As String, Optional vKey) As String

    Dim buf As String

    Dim buflen As Long

    Dim hKey As Long

    'Si no se especifica la clave del Registro, usar HKEY_CLASSES_ROOT

    If IsMissing(vKey) Then

        hKey = HKEY_CLASSES_ROOT

    Else

        hKey = CLng(vKey)

    End If

   

    On Local Error Resume Next

    buf = Space$(300)

    buflen = Len(buf)

    'Buscar la entrada especificada y devolver el valor asignado

    If RegQueryValue(hKey, Entry, buf, buflen) = 0 Then

        If buflen > 1 Then

            'El formato devuelto es ASCIIZ, así que quitar el último caracter

            QueryRegBase = Left$(buf, buflen - 1)

        Else

            QueryRegBase = ""

        End If

    Else

        QueryRegBase = ""

    End If

    'Desactivar la detección de errores

    On Local Error GoTo 0

End Function  

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

Private Sub BuscarExtensionID(sExt As String)

    Dim lRet As Long

    Dim sKey As String

    Dim sValue As String

    Dim hKey As Long

    Dim sExe As String

    Dim sIcon As String

    Dim lIcon As Long

    Dim sProgId As String

    Dim i As Integer

   

    Caption = "Mostrar asociaciones de la clave: " & sExt

    List2.Visible = True

    List2.Clear

    List2.AddItem "Valores del Registro para " & sExt

    '

    'Buscar en el registro la extensión...

    sProgId = QueryRegBase(sExt)

    If Len(sProgId) Then

        List2.AddItem "Clave: " & sProgId

        sKey = sProgId & "\DefaultIcon"

        List2.AddItem sKey

        sValue = QueryRegBase(sKey)

        If Len(sValue) Then

            i = InStr(sValue, ",")

            If i Then

                sIcon = Left$(sValue, i - 1)

                lIcon = Val(Mid$(sValue, i + 1))

            Else    'No tiene programa para Defaulticon

                sIcon = sValue

                lIcon = 0

                sValue = ""

            End If

        End If

        List2.AddItem "   Icono de: " & sIcon

        List2.AddItem "   Icono nº: " & lIcon

        '

        'Obtener el programa asociado por defecto para Abrir

        'no quiere decir que este sea el que se ejecute cuando se haga doble-click

        sKey = sProgId & "\Shell\Open\Command"

        sValue = QueryRegBase(sKey)

        If Len(sValue) Then

            i = InStr(sValue, ".")

            If i Then

                i = InStr(i, sValue, " ")

                If i Then

                    sExe = Trim$(Left$(sValue, i - 1))

                Else

                    sExe = Trim$(sValue)

                End If

            Else

                sExe = Trim$(sValue)

            End If

        End If

        List2.AddItem sKey

        List2.AddItem "   Programa asociado: " & sExe

    End If

End Sub

Ejemplo para crear claves en el Registro:
'Claves del Registro

Public Const HKEY_CLASSES_ROOT = &H80000000

Public Const HKEY_CURRENT_USER = &H80000001

Public Const HKEY_LOCAL_MACHINE = &H80000002

Public Const HKEY_USERS = &H80000003

'

'Para los valores devueltos por las funciones de manejo del Registro

Public Const ERROR_SUCCESS = 0&

Public Const ERROR_NO_MORE_ITEMS = 259&

'

' Tipos de datos Reg...

Public Const REG_SZ = 1

'

'Declaraciones del API de Windows para 32 bits

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

Declare Function RegEnumKey Lib "advapi32" Alias "RegEnumKeyA" (ByVal hKey As Long, ByVal iSubKey As Long, ByVal lpszName As String, ByVal cchName As Long) As Long

Declare Function RegOpenKey Lib "advapi32" Alias "RegOpenKeyA" (ByVal hKey As Long, ByVal lpszSubKey As String, phkResult As Long) As Long

Declare Function RegCloseKey Lib "advapi32" (ByVal hKey As Long) As Long

Declare Function RegCreateKey Lib "advapi32.dll" Alias "RegCreateKeyA" (ByVal hKey As Long, ByVal lpSubKey As String, phkResult As Long) As Long

Declare Function RegSetValue Lib "advapi32.dll" Alias "RegSetValueA" (ByVal hKey As Long, ByVal lpSubKey As String, ByVal dwType As Long, ByVal lpData As String, ByVal cbData As Long) As Long

Declare Function RegDeleteKey Lib "advapi32.dll" Alias "RegDeleteKeyA" (ByVal hKey As Long, ByVal lpSubKey As String) As Long

 

'Declaraciones para el API de 16 bits

Declare Function RegQueryValue Lib "shell.dll" (ByVal hKey As Long, ByVal lpSubKey As String, ByVal lpValue As String, lpcbValue As Long) As Long

Declare Function RegEnumKey Lib "shell.dll" (ByVal hKey As Long, ByVal iSubKey As Long, ByVal lpszName As String, ByVal cchName As Long) As Long

Declare Function RegOpenKey Lib "shell.dll" (ByVal hKey As Long, ByVal lpszSubKey As String, phkResult As Long) As Long

Declare Function RegCloseKey Lib "shell.dll" (ByVal hKey As Long) As Long

Declare Function RegCreateKey Lib "shell.dll" (ByVal hKey As Long, ByVal lpSubKey As String, phkResult As Long) As Long

Declare Function RegSetValue Lib "shell.dll" (ByVal hKey As Long, ByVal lpSubKey As String, ByVal dwType As Long, ByVal lpData As String, ByVal cbData As Long) As Long

Declare Function RegDeleteKey Lib "shell.dll" (ByVal hKey As Long, ByVal lpSubKey As String) As Long

 

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

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

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

'Declaraciones para el API de 16 bits

'Abrir y guardar

Declare Function GetOpenFileName Lib "commdlg.dll" (lpofn As tagOpenFileName) As Integer

Declare Function GetSaveFileName Lib "commdlg.dll" (lpofn As tagOpenFileName) As Integer

'Buscar y reemplazar (aún no he podido ponerlas en marcha???)

Declare Function FindText Lib "commdlg.dll" (lpFR As tagFindReplace) As Integer

Declare Function ReplaceText Lib "commdlg.dll" (lpFR As tagFindReplace) As Integer

'Para la impresora

Declare Function PrintDlg Lib "commdlg.dll" (tagPD As tagPrintDlg) As Integer

'

 

'Declaraciones para 32 bits

'Abrir y guardar

Declare Function GetOpenFileName Lib "comdlg32.dll" Alias "GetOpenFileNameA" (pOpenfilename As OPENFILENAME) As Long

Declare Function GetSaveFileName Lib "comdlg32.dll" Alias "GetSaveFileNameA" (pOpenfilename As OPENFILENAME) As Long

Declare Function GetFileTitle Lib "comdlg32.dll" Alias "GetFileTitleA" (ByVal lpszFile As String, ByVal lpszTitle As String, ByVal cbBuf As Integer) As Integer

'Buscar y reemplazar

Declare Function FindText Lib "comdlg32.dll" Alias "FindTextA " (pFindreplace As FINDREPLACE) As Long

Declare Function ReplaceText Lib "comdlg32.dll" Alias "ReplaceTextA" (pFindreplace As FINDREPLACE) As Long

'Para la impresora

Declare Function PrintDlg Lib "comdlg32.dll" Alias "PrintDlgA" (pPrintdlg As PRINTDLG) As Long

Declare Function PageSetupDlg Lib "comdlg32.dll" Alias "PageSetupDlgA" (pPagesetupdlg As PAGESETUPDLG) As Long

'Para los colores

Declare Function ChooseColor Lib "comdlg32.dll" Alias "ChooseColorA" (pChoosecolor As CHOOSECOLOR) As Long

'Las fuentes

Declare Function ChooseFont Lib "comdlg32.dll" Alias "ChooseFontA" (pChoosefont As CHOOSEFONT) As Long

No incluyo ejemplos ni las declaraciones de los tipos, por ser demasiado "grandes". Pero las incluyo en un listado con ejemplos para abrir, etc., aunque con las funciones para 16 bits, ya que desde que uso el VB para 32 bits, suelo hacerlo con el control que trae.

10.- Mostrar un icono en la barra de tareas

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

---------------

Private Type TIPONOTIFICARICONO

    cbSize As Long

    hwnd As Long

    uId As Long

    uFlags As Long

    ucallbackMessage As Long

    hIcon As Long

    szTip As String * 64

End Type

'------------------

Private Const NIM_ADD = &H0

Private Const NIM_MODIFY = &H1

Private Const NIM_DELETE = &H2

Private Const WM_MOUSEMOVE = &H200

Private Const NIF_MESSAGE = &H1

Private Const NIF_ICON = &H2

Private Const NIF_TIP = &H4

Private Const WM_LBUTTONDBLCLK = &H203

Private Const WM_LBUTTONDOWN = &H201

Private Const WM_LBUTTONUP = &H202

Private Const WM_RBUTTONDBLCLK = &H206

Private Const WM_RBUTTONDOWN = &H204

Private Const WM_RBUTTONUP = &H205

'--------------------

Private Declare Function Shell_NotifyIcon Lib "shell32" _

    Alias "Shell_NotifyIconA" (ByVal dwMessage As Long, _

    pnid As TIPONOTIFICARICONO) As Boolean

'--------------------

Private Declare Function WinExec& Lib "kernel32" _

    (ByVal lpCmdLine As String, ByVal nCmdShow As Long)

'--------------------

Dim t As TIPONOTIFICARICONO

Private Sub Form_Load()

    If App.PrevInstance Then

        mnuAcerca_Click

        Unload Me

        End

    End If

'---------------------------------

    t.cbSize = Len(t)

    t.hwnd = picGancho.hwnd

    t.uId = 1&

    t.uFlags = NIF_ICON Or NIF_TIP Or NIF_MESSAGE

    t.ucallbackMessage = WM_MOUSEMOVE

    t.hIcon = Me.Icon

'---------------------------------

    t.szTip = "Ejemplo de barra de tareas..." & Chr$(0) ' Es un string de "C" ( \0 )

    Shell_NotifyIcon NIM_ADD, t

    Me.Hide

    App.TaskVisible = False

End Sub

 

 

 

 

 

 

 

 

 

 

 

 

 

 

 

 

 

 

 

 

 

 

 

 

 

 

 

 

 

 

 

 

 

 

 

 

 

 


©1998-2001 FMC Webs® Todos los derechos Reservados. Ferraro Mauro - San Nicolás - Argentina

El Codigo del Mes

Aqui le mostraremos el Codigo Fuente del Mes, Votalo Ya!!!

Preguntar

Dudas

Trucos

API de windows

Tutoriales

Trucos

Api de Windows

Bajate el manual de VB

Contactenos

Enviar Codigos Fuente

Links y Banners

Publicite en nuestro Site

Pone Tu link Gratis!!!

Crea tu Web

Redirecciona tu Pagina Gratis!!!

Votanos en La web del Programador

Sugerencias