Programas y Utilidades
para Visual Basic

Actualizado el 03/Nov/2006

Nota:
Esta p�gina est� ya obsoleta... salvo que sigas usando las primeras versiones de Visual Basic (particularmente para 16 bits), por tanto te recomiendo que veas la p�gina de Mis Utilidades para Visual Basic 6.0 y anteriores.
 

Programas incluidos en esta p�gina desde el ya "remoto" 15/Dic/1997:

• Enviar correo desde Visual Basic usando el control Winsock (13/Sep/2001)

Salva pantallas de Joe LeVasseur. (Protpant.zip 8.667 bytes)

Ejemplo de un salva pantallas (screen saver) de Joe LeVasseur.
En sus p�ginas personales, (ya no existe esa p�gina), podr�s encontrar un salva-pantallas que muestra el icono en la barra de tareas. Joe ha prometido que enviar� el c�digo para mostrar un programa en la barra de tareas. Est�s obligado a hacerlo. 8-)
En el fichero comprimido encontrar�s el c�digo fuente y el ejecutable con la extensi�n .SCR
Copia el fichero Protpant.scr en el directorio System de Windows y podr�s usarlo desde el di�logo de Propiedades de Pantalla, solapa Protector de pantalla.

Listados y fichero ejecutable del salva pantallas, nueva versi�n, (Protpan1.zip 8.890 bytes)

---

Reinicia Windows y muestra los recursos y la memoria disponible. (22/Mar/97)

S�lo para 16 bits.

El listado:

'----------------------------------------------------------
' gsIniW (Reiniciar Windows)                Versi�n 16 bits
'
' (c) Guillermo Som Cerezo                      (18/May/95)
'
' Utilidad para reiniciar windows.
' Muestra tambi�n la memoria y recursos libres. ( 1/Sep/96)
'
' Este programa es de libre distribuci�n y
' puedes modificarlo, (para eso env�o los listados).
'
'----------------------------------------------------------
Option Explicit

Declare Function ExitWindows Lib "User" (ByVal ReStartCode As Long, ByVal DosReturnCode As Integer) As Integer
'Obtener la memoria y recursos libres           ( 1/Sep/96)
Declare Function GetFreeSpace Lib "Kernel" (ByVal wFlags As Integer) As Long
Declare Function GetFreeSystemResources Lib "User" (ByVal fuSysResource As Integer) As Integer
Const GFSR_SYSTEMRESOURCES = &H0


Sub Main()
#If Win32 Then
    MsgBox "Este programa s�lo funciona compilado con 16 bits.", vbInformation
#Else
    Dim Memoria&, m$

    Memoria& = GetFreeSpace(0)
    m$ = "Recursos libres: " & GetFreeSystemResources(GFSR_SYSTEMRESOURCES) & "%"
    m$ = m$ & " - Memoria libre: " & Format$(Memoria& \ 1024, "###,###,###") & " KB"

    If MsgBox(m$ & vbCrLf & vbCrLf & "�Quieres reiniciar Windows?", 4 + 16 + 256, "Reiniciar Windows") = 6 Then
        Memoria& = ExitWindows(66, 0)
    End If
    End
#End If
End Sub

---

Reinicia Windows (16 y 32 bits) (22/Mar/97)

Esta utilidad reiniciar� Windows. Sirve tanto para 16 como para 32 bits.

Nota:
En la p�gina del API tienes otros ejemplos, incluso para Windows NT/2000

Reiniciar Windows (listados para 16 y 32 bits)

Reiniciar Windows (2� parte) revisado para Windows NT
 

El listado:

Option Explicit
'--------------------------------------------------
' ReIniWin (Reiniciar Windows)          ( 8/Nov/95)
'
'(c) Guillermo Som
'--------------------------------------------------
#If Win32 Then
    'Para usar con ExitWindowsEx
    Public Const EWX_LOGOFF = 0     'Termina la sesi�n actual
    Public Declare Function ExitWindowsEx Lib "user32" (ByVal uFlags As Long, ByVal dwReserved As Long) As Long
    'ExitWindows termina la sesi�n actual e inicia una nueva
    '(es decir reiniciar windows)
    'Public Declare Function ExitWindows Lib "user32" (ByVal dwReserved As Long, ByVal uReturnCode As Long) As Long
#Else
    Public Declare Function ExitWindows Lib "user" (ByVal ReStartCode As Long, ByVal DosReturnCode As Integer) As Integer
#End If


Public Sub Main()
    Dim msg As String

    Beep
    #If Win32 Then
        msg = "Est�s ejecutando Windows en modo 32bits," & vbCrLf & "(seguramente Windows 95, conectado en red)," & vbCrLf & "y e"
    #Else
        msg = "E"
    #End If
    msg = msg & "ste programa reiniciar� Windows."
    If MsgBox(msg & vbCrLf & vbCrLf & "�Seguro que quieres reiniciar Windows?", 4 + 16 + 256, "� ATENCI�N !") = 6 Then
        'ReStart Windows
        #If Win32 Then
            If ExitWindowsEx(EWX_LOGOFF, 0&) Then
        #Else
            If ExitWindows(66, 0) Then
        #End If
            End If
    Else
        End
    End If
End Sub

---

Convertir N�meros en Letras (22/Mar/97)

Funci�n para convertir un n�mero en letra.
Por ejemplo: 125 ser�a "ciento veinticinco"

Listado y form de prueba. (gsnum2text.zip 2.98 KB)

Nota:
�chale un vistazo a la p�gina de la clase cNum2Text.

El listado:

'---------------------------------------------------------------------------
' gsNumero.BAS   M�dulo para procedimientos num�ricos            ( 1/Mar/91)
' Versi�n para Windows                                           (25/Oct/96)
'
' (c)Guillermo Som, 1991-97
'---------------------------------------------------------------------------
Option Explicit
Option Compare Text
Public Function Numero2Letra(ByVal strNum As String, Optional vLo) As String
    '----------------------------------------------------------
    ' Convierte el n�mero strNum en letras          (28/Feb/91)
    ' Versi�n para Windows                          (25/Oct/96)
    '----------------------------------------------------------
    Dim lngA As Long
    Dim Negativo As Boolean
    Dim L As Integer
    Dim Una As Boolean
    Dim Millon As Boolean
    Dim Millones As Boolean
    Dim vez As Integer
    Dim MaxVez As Integer
    Dim k As Integer
    Dim strQ As String
    Dim strB As String
    Dim strU As String
    Dim strD As String
    Dim strC As String
    Dim iA As Integer
    '
    Dim strN() As String
    Dim lo As Integer
    '
    'Si no se especifica el ancho...
    If IsMissing(vLo) Then
        lo = 255
    Else
        lo = vLo
    End If

    Dim unidad(0 To 9) As String
    Dim decena(0 To 9) As String
    Dim centena(0 To 9) As String
    Dim deci(0 To 9) As String
    Dim otros(0 To 15) As String
    'Asignar los valores
    unidad(1) = "Una"
    unidad(2) = "dos"
    unidad(3) = "tres"
    unidad(4) = "cuatro"
    unidad(5) = "cinco"
    unidad(6) = "seis"
    unidad(7) = "siete"
    unidad(8) = "ocho"
    unidad(9) = "nueve"
    '
    decena(1) = "diez"
    decena(2) = "veinte"
    decena(3) = "treinta"
    decena(4) = "cuarenta"
    decena(5) = "cincuenta"
    decena(6) = "sesenta"
    decena(7) = "setenta"
    decena(8) = "ochenta"
    decena(9) = "noventa"
    '
    centena(1) = "ciento"
    centena(2) = "doscientas"
    centena(3) = "trescientas"
    centena(4) = "cuatrocientas"
    centena(5) = "quinientas"
    centena(6) = "seiscientas"
    centena(7) = "setecientas"
    centena(8) = "ochocientas"
    centena(9) = "novecientas"
    '
    deci(1) = "dieci"
    deci(2) = "veinti"
    deci(3) = "treinta y "
    deci(4) = "cuarenta y "
    deci(5) = "cincuenta y "
    deci(6) = "sesenta y "
    deci(7) = "setenta y "
    deci(8) = "ochenta y "
    deci(9) = "noventa y "
    '
    otros(1) = "1"
    otros(2) = "2"
    otros(3) = "3"
    otros(4) = "4"
    otros(5) = "5"
    otros(6) = "6"
    otros(7) = "7"
    otros(8) = "8"
    otros(9) = "9"
    otros(10) = "10"
    otros(11) = "once"
    otros(12) = "doce"
    otros(13) = "trece"
    otros(14) = "catorce"
    otros(15) = "quince"
    '
    On Error GoTo 0

    lngA = Abs(Val(strNum))
    Negativo = (lngA <> Val(strNum))
    strNum = LTrim$(RTrim$(Str$(lngA)))
    L = Len(strNum)

    If lngA = 0 Then
        strNum = Left$("cero" & Space$(lo), lo)
        Exit Function
    End If
    '
    Una = True
    Millon = False
    Millones = False
    If L < 4 Then Una = False
    If lngA > 999999 Then Millon = True
    If lngA > 1999999 Then Millones = True
    strB = ""
    strQ = strNum
    vez = 0

    ReDim strN(1 To 4)
    strQ = Right$(String$(12, "0") & strNum, 12)
    For k = Len(strQ) To 1 Step -3
        vez = vez + 1
        strN(vez) = Mid$(strQ, k - 2, 3)
    Next
    MaxVez = 4
    For k = 4 To 1 Step -1
        If strN(k) = "000" Then
            MaxVez = MaxVez - 1
        Else
            Exit For
        End If
    Next
    For vez = 1 To MaxVez
        strU = "": strD = "": strC = ""
        strNum = strN(vez)
        L = Len(strNum)
        k = Val(Right$(strNum, 2))
        If Right$(strNum, 1) = "0" Then
            k = k \ 10
            strD = decena(k)
        ElseIf k > 10 And k < 16 Then
            k = Val(Mid$(strNum, L - 1, 2))
            strD = otros(k)
        Else
            strU = unidad(Val(Right$(strNum, 1)))
            If L - 1 > 0 Then
                k = Val(Mid$(strNum, L - 1, 1))
                strD = deci(k)
            End If
        End If
        If L - 2 > 0 Then
            k = Val(Mid$(strNum, L - 2, 1))
            strC = centena(k) & " "
        End If
        If strU = "uno" And Left$(strB, 4) = " mil" Then strU = ""
        strB = strC & strD & strU & " " & strB
        If (vez = 1 Or vez = 3) And strN(vez + 1) <> "000" Then strB = " mil " & strB
        If vez = 2 And Millon Then
            If Millones Then
                strB = " millones " & strB
            Else
                strB = "un mill�n " & strB
            End If
        End If
    Next
    strB = LTrim$(RTrim$(strB))
    If Right$(strB, 3) = "uno" Then strB = Left$(strB, Len(strB) - 1) & "a"
    Do                              'Quitar los espacios que haya por medio
        iA = InStr(strB, "  ")
        If iA = 0 Then Exit Do
        strB = Left$(strB, iA - 1) & Mid$(strB, iA + 1)
    Loop
    If Left$(strB, 6) = "una un" Then strB = Mid$(strB, 5)
    If Left$(strB, 7) = "una mil" Then strB = Mid$(strB, 5)
    If Right$(strB, 16) <> "millones mil una" Then
        iA = InStr(strB, "millones mil una")
        If iA Then strB = Left$(strB, iA + 8) & Mid$(strB, iA + 13)
    End If
    If Right$(strB, 6) = "ciento" Then strB = Left$(strB, Len(strB) - 2)
    If Negativo Then strB = "menos " & strB
    '
    strC = Space$(lo)
    LSet strC = strB
    Numero2Letra = strC
End Function

---

Aceptar archivos con Drag & Drop (23/Mar/97)

Ejemplo del uso de una clase para aceptar archivos "soltados" en un formulario.
Aceptar� tanto im�genes BMP, ICO y WMF, as� como archivos de texto. En caso que sea otro tipo de archivo, si se puede asignar (mostrar) en un textbox, se mostrar�, si no se producir� un error y el error ser� indicado en el label.

Esta clase est� sacada (sin autorizaci�n) del libro de Francisco Charte: Programaci�n Profesional con Visual Basic 4.0 de la editorial Anaya Multimedia.
Aunque me expongo a "cualquier cosa" y confiando en que al ser por el tema divulgativo no haya problemas.

Nota del 15/Dic/97:
Seg�n el autor, Fco. Charte, mientras haga referencia de d�nde est� sacada, la cosa va bien. Muchas gracias.

Creo que es un ejemplo interesante del modo de realizar esta funci�n que a m�s de uno, incluido yo, nos gustar�a implementar en sus programas.
Pues ah� queda eso y espero que "le saques provecho"

Baja los listados de la clase y el ejemplo (dragdrop.zip 4.55 KB)

Este es el listado de la clase DragDrop

'----------------------------------------------------------
'
'cDragDrop.Cls
'
' Esta clase facilitar� la creaci�n de aplicaciones
' que acepten archivos de arrastrar-y-soltar desde
' el Explorador
'
'Clase de ejemplo del Capitulo 8 del libro:
'Programaci�n Profesional con Visual Basic 4.0
'de Francisco Charte (Anaya Multimedia)
'
'Adaptada por Guillermo Som, 23/Mar/97
'----------------------------------------------------------
Option Explicit

    ' Referencia a la ventana oculta
Private MiVentana As frmOculto
    ' Referencia a la ventana que recibir� los archivos
Private VentanaDragDrop As Form
Private Termina As Boolean ' indicador interno


'Constantes para las funciones del API
'Const PM_NOREMOVE = &H0
Const PM_REMOVE = &H1
'Const PM_NOYIELD = &H2

Const WM_DROPFILES = &H233

'Declaraciones de las funciones del API
Private Declare Function DragQueryFile Lib "shell32.dll" Alias "DragQueryFileA" (ByVal hDrop As Long, ByVal UINT As Long, ByVal lpStr As String, ByVal ch As Long) As Long
'Private Declare Function DragQueryPoint Lib "shell32.dll" (ByVal hDrop As Long, lpPoint As POINTAPI) As Long
Private Declare Sub DragFinish Lib "shell32.dll" (ByVal hDrop As Long)
Private Declare Sub DragAcceptFiles Lib "shell32.dll" (ByVal hwnd As Long, ByVal fAccept As Long)
'
Private Declare Function PeekMessage Lib "user32" Alias "PeekMessageA" (lpMsg As Msg, ByVal hwnd As Long, ByVal wMsgFilterMin As Long, ByVal wMsgFilterMax As Long, ByVal wRemoveMsg As Long) As Long
Private Declare Function WaitMessage Lib "user32" () As Long

'Tipos de datos para las funciones del API
Private Type POINTAPI
    x As Long
    y As Long
End Type

Private Type Msg
    hwnd As Long
    message As Long
    wParam As Long
    lParam As Long
    time As Long
    pt As POINTAPI
End Type 'MSG


    ' Este m�todo activa la recepci�n de archivos
    ' en la ventana que se pasa como par�metro
Public Sub Activa(Ventana As Form)
        ' Guardamos la referencia a la ventana
    Set VentanaDragDrop = Ventana
        ' Activamos la recepci�n de archivos
    DragAcceptFiles VentanaDragDrop.hwnd, True
        ' Creamos una ventana oculta
    Set MiVentana = New frmOculto
        ' y la asociamos con nosotros mismos
    Set MiVentana.MiObjeto = Me
        ' activando el env�o de un mensaje en 500 milisegundos
    MiVentana.Timer.Enabled = True
        ' lo cual nos permite devolver el control
        ' al cliente que nos est� utilizando
    Termina = False
End Sub


    ' Esta funci�n ser� llamada desde el formulario
    ' oculto, y se estar� ejecutando mientras Termina
    ' no tome el valor True
Public Sub Proceso()
        ' Para leer mensajes de la cola
    Dim Mensaje As Msg, N As Integer ' contador
        ' Bytes y Cadena para leer nombres de archivo
    Dim Bytes As Integer, Cadena As String

        ' Mientras Termina no sea True
    Do While Not Termina
        WaitMessage ' esperamos a que llegue un mensaje
            ' Si ese mensaje es WM_DROPFILES
        If PeekMessage(Mensaje, VentanaDragDrop.hwnd, WM_DROPFILES, WM_DROPFILES, PM_REMOVE) Then ' lo leemos
            With Mensaje ' obtenemos el n�mero total de archivos
                For N = 0 To DragQueryFile(.wParam, -1, Cadena, 0) - 1
                        ' consultamos la longitud del nombre N
                    Bytes = DragQueryFile(.wParam, N, Cadena, 0)
                        ' asignamos el espacio necesario
                    Cadena = String(Bytes + 1, 0)
                        ' y obtenemos el nombre
                    DragQueryFile .wParam, N, Cadena, Bytes + 1
                        ' que pasamos al formulario cliente
                    VentanaDragDrop.Archivo Cadena
                Next
                DragFinish .wParam ' hemos terminado
            End With
        End If
        DoEvents ' permitimos el trabajo de otros procesos
    Loop ' y continuamos
End Sub


    ' Este m�todo ser� llamado para desactivar
    ' el funcionamiento del objeto
Public Sub Desactiva()
    Termina = True ' Provocamos el fin de la ejecuci�n de Proceso
        ' desactivamos la recepci�n de archivos
    DragAcceptFiles VentanaDragDrop.hwnd, False
    Unload MiVentana ' descargamos la ventana oculta
    Set VentanaDragDrop = Nothing ' y liberamos referencias
    Set MiVentana = Nothing
End Sub


    ' Al destruir el objeto
Private Sub Class_Terminate()
        ' si no ha sido previamente desactivado
    If Not Termina Then Desactiva ' lo desactivamos
End Sub

El listado del form oculto que usa la clase

    '
    ' frmOculto.frm
    '
    ' Este formulario oculto tiene como �nica finalidad
    ' enviar un mensaje al objeto asociado una vez
    ' ha trancurrido un periodo de 500 milisegundos.
    ' Esto permite que el objeto devuelva el control
    ' al formulario que ha llamado al m�todo Activa
    '
Option Explicit


    ' Referencia al objeto
Public MiObjeto As DragDrop


    ' Al descargar el formulario
Private Sub Form_Unload(Cancel As Integer)
    Set MiObjeto = Nothing ' eliminamos la refrencia
End Sub


    ' Cuando se produzca el evento
Private Sub Timer_Timer()
    Timer.Enabled = False ' desactivamos el timer
    MiObjeto.Proceso ' y llamamos a Proceso
End Sub

Por �ltimo el listado del form de prueba

'-------------------------------------------------------------
'Prueba de Drag & Drop aceptando archivos de texto (23/Mar/97)
'
'Proceso y clase basado en el ejemplo del libro:
'Programaci�n Profesional con Visual Basic 4.0
'de Francisco Charte (Anaya Multimedia)
'-------------------------------------------------------------
Option Explicit

' Referencia al objeto de arrastrar y soltar
Dim MiObjeto As DragDrop


' Este procedimiento p�blico ser� llamado
' por el objeto DragDrop cada vez que se
' reciba un archivo de arrastrar y soltar
Public Sub Archivo(Nombre As String)
    Dim nFic As Integer

    Desactivar

    On Local Error Resume Next

    'Si es un archivo gr�fico
    Picture1.Picture = LoadPicture(Nombre)
    If Err = 0 Then
        Picture1.Enabled = True
        Picture1.Visible = True
    Else
        Err = 0
        'Si no se asigna al text
        Text1.Enabled = True
        Text1.Visible = True

        nFic = FreeFile
        Open Nombre For Input As nFic
        Text1 = Input$(LOF(nFic), nFic)
        Close nFic
    End If

    AjustarTama�o

    Label1 = Nombre
    If Err Then
        Label1 = "ERROR: " & Error$
        Text1 = ""
        Err = 0
    End If
    On Local Error GoTo 0
End Sub


Private Sub cmdSalir_Click()
    Unload Me
    End
End Sub


Private Sub Form_Load()
    'Inicializar
    ' Creamos el objeto
    Set MiObjeto = New DragDrop
    MiObjeto.Activa Me ' lo activamos

    Desactivar
End Sub


Private Sub Form_Resize()
    'No ajustar las posiciones, si se minimiza el form
    If WindowState = vbMinimized Then Exit Sub
    AjustarTama�o
End Sub


Private Sub Form_Unload(Cancel As Integer)
    MiObjeto.Desactiva ' desactivamos el objeto
    Set MiObjeto = Nothing ' y lo liberamos
    'Liberar recursos
    Set Form1 = Nothing
End Sub


Private Sub AjustarTama�o()
    Dim alto As Integer

    cmdSalir.Top = ScaleHeight - 495
    cmdSalir.Left = ScaleWidth - 1380
    alto = cmdSalir.Top - (Label1.Top + Label1.Height) - 240
    If Text1.Enabled Then
        Text1.Move 90, 480, ScaleWidth - 180, alto
    End If
    If Picture1.Enabled Then
        Picture1.Move 90, 480, ScaleWidth - 180, alto
    End If
End Sub


Private Sub Desactivar()
    Picture1.Enabled = False
    Picture1.Visible = False
    Text1.Enabled = False
    Text1.Visible = False
End Sub

---

Una funci�n para saber si existe un archivo (24/Mar/97)

Esta es una funci�n que me ha enviado mi amigo Joe LeVasseur y es para saber si un archivo existe, aunque sea oculto o del sistema.

Option Explicit
' Ejemplo de probar si existe un archivo sin abrir


Private Sub Command1_Click()
    Dim ValDev As Boolean, UnArchivo As String
    UnArchivo = "c:\autoexec.bart"
    ValDev = ExisteArchivo(UnArchivo)
    MsgBox "ExisteArchivo=" & ValDev & vbCrLf & UnArchivo
End Sub


Private Sub Command2_Click()
    Dim ValDev As Boolean, UnArchivo As String
    UnArchivo = "c:\autoexec.bat"
    ValDev = ExisteArchivo(UnArchivo)
    MsgBox "ExisteArchivo=" & ValDev & vbCrLf & UnArchivo
End Sub


Private Function ExisteArchivo(sNombreArchivo As String) As Boolean
    Dim AttrDev%
    On Error Resume Next
    AttrDev = GetAttr(sNombreArchivo)
    If Err.Number Then
        Err.Clear
        ExisteArchivo = False
    Else
        ExisteArchivo = True
    End If
End Function

---

Hacer Scroll en un Picture y en varios controles (26/Mar/97)

Dos ejemplos para hacer Scroll. Uno es en un Picture con una imagen y el otro usando varios controles.
Espero que te sirva y lo puedas adaptar para tus necesidades.

En el ejemplo de varios controles tambi�n incluyo como restar horas y adapt�ndolo puedes usarlo para restar fechas.
En el ejemplo de la imagen, incluyo una funci�n para leer la l�nea de comandos y quitarle las comillas, si es que se incluyen junto con el nombre del programa.

Baja los ejemplos que est�n en este archivo comprimido: (t_scroll.zip 5.62 KB)

(13/May/97) Los archivos est�n "corregidos" para que no falle cuando la ventana se reduce "demasiado".
Gracias a "David Sans" [email protected] por la "aclaraci�n".

 

---

Ejecutar archivos con su programa asociado usando DDE (26/Mar/97)

En este ejemplo incluyo un m�dulo que hace tiempo vi por ah�, est� en alem�n, creo, pero como las instrucciones de VB son "internacionales", por llamarlas de alguna forma, pues es v�lido.
Para usarlo deber�s tener un control Text o Label para aceptar DDE, en el ejemplo siguiente es DDESystem

    'Ejecutar el archivo o el programa asociado
    If Exec(DDESystem, AddBSlash(File1.Path) & File1, False) = False Then
	'No est� asociado...
        'MsgBox "'" & File1 & "' konnte nicht ausgef�hrt werden."
        'Si no est� asociado, mostrar la informaci�n...
        MsgBox "'" & File1 & "' no est� asociado a ning�n programa."
    End If

Este es el listado completo del archivo: Starter.Bas que es el que tiene las rutinas para ejecutar los programas, as� como otras cosillas interesantes.

Baja los listados del ejemplo original, para VB3. (regdb.zip 9.25 KB)

 

Option Explicit

Global Const MB_RETRYCANCEL = 5
Global Const MB_ICONSTOP = 16
Global Const IDCANCEL = 2
Global Const IDRETRY = 4

'Declaraciones del API de Windows
#If Win32 Then
    Declare Function GetProfileString Lib "kernel32" Alias "GetProfileStringA" (ByVal lpAppName As String, ByVal lpKeyName As String, ByVal lpDefault As String, ByVal lpReturnedString As String, ByVal nSize As Long) As Long
    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 FindExecutable Lib "shell32.dll" Alias "FindExecutableA" (ByVal lpFile As String, ByVal lpDirectory As String, ByVal lpResult As String) As Long
    Declare Function GetModuleHandle Lib "kernel32" Alias "GetModuleHandleA" (ByVal lpModuleName As String) As Long
#Else
    Declare Function GetProfileString% Lib "Kernel" (ByVal lpAppName$, ByVal lpKeyName$, ByVal lpDefault$, ByVal lpReturnedString$, ByVal nSize%)
    Declare Function RegQueryValue& Lib "shell.dll" (ByVal hKey&, ByVal subkey$, ByVal buf$, buflen&)
    Declare Function FindExecutable% Lib "shell.dll" (ByVal file$, ByVal dr$, ByVal result$)
    Declare Function GetModuleHandle% Lib "Kernel" (ByVal lpModuleName$)
#End If


'A�ade barra de directorio si no la tiene
Function AddBSlash(ByVal t As String) As String
    If Len(t) Then
        If Right$(t, 1) <> "\" Then
            AddBSlash = t & "\"
        Else
            AddBSlash = t
        End If
    Else
        AddBSlash = ""
    End If
End Function


' Pr�ft, ob eine Anwendung f�r eine DDE-Kommunikation
' angemeldet wurde.
Function CanExtDDE(ByVal fext$, ByVal tp$) As Boolean
    Dim dde$, class$
    On Error Resume Next
    class = QueryRegBase("." & fext)
    If Len(class) Then
        dde = QueryRegBase(class & "\shell\" & tp & "\ddeexec")
        If Len(dde) Then
            CanExtDDE = True
        Else
            CanExtDDE = False
        End If
    Else
        CanExtDDE = False
    End If
End Function


Function CountChar%(ByVal t, ByVal z%)
    Dim g&, zeichen$, n&
    On Error Resume Next
    zeichen = Chr$(z)
    Do
        g = InStr(g + 1, t, zeichen)
        n = n + 1
    Loop While g
    CountChar = n - 1
End Function


' Ejecuta el programa o el erchivo con el programa
' asociado
Function Exec(c As Control, ByVal fullname$, ByVal t%) As Boolean
    Dim fpath$, FName$, fbody$, fext$, res%, para$, fn$, tp$
    On Error Resume Next

    If t = 0 Then tp = "open" Else tp = "print"

    fn = GetAvailPart(fullname, 32, 1)
    para = Right$(fullname, Len(fullname) - Len(fn) - 1)

    ' �bergabe in ihre Bestandteile zerlegen.

    SplitPathname fullname, fpath, FName
    SplitFilename FName, fbody, fext

    ' Ist die Datei eventuell ein ausf�hrbares Programm? Die entsprechenden
    ' Dateiendungen stehen in der WIN.INI.
    If IsFileOfType(fext, ReadWinIniString("windows", "programs", "")) Then
        Exec = ExecPrograms(fullname, para)
    Else
        ' Unterst�tzt die Anwendung, die zu fext geh�rt, DDE?
        If CanExtDDE(fext, tp) Then
            ' mit DDE Kontakt zur Anwendung aufnehmen
            Exec = ExecDocWithDDE(c, fullname, fpath, fext, tp)
        Else
            ' Dokument als Parameter �bergeben
            Exec = ExecDocWithProgram(fullname, fpath, fext, tp)
        End If
    End If
End Function


' Steuert den Kontakt mit einer Anwendung via DDE, um ein
' Dokument in diese Anwendung einzulesen.
Function ExecDocWithDDE(c As Control, ByVal fullname$, ByVal fpath$, ByVal fext$, ByVal tp$) As Boolean
    Dim topic$, application$, ddeexec$
    Dim ifexec$, cmd$, class$
    Dim fpath1$, FName$, fbody$, fext1$

    On Error Resume Next
    ' Die Klasse kann mit Hilfe der Dateierweitung gefunden werden.
    ' Sie wird f�r alle folgenden Aufrufe ben�tigt.
    class = QueryRegBase("." & fext)
    If Len(class) Then
        ' Lese n�tige Parameter aus der Registrationsdatenbank.
        cmd = QueryRegBase(class & "\shell\" & tp & "\command")
        ddeexec = QueryRegBase(class & "\shell\" & tp & "\ddeexec")
        ifexec = QueryRegBase(class & "\shell\" & tp & "\ddeexec\ifexec")
        If Len(ifexec) = 0 Then
            ' Die Angabe von ifexec ist optional. Wird Sie unterlassen, dann
            ' mu� ddeexec benutzt werden.
            ifexec = ddeexec
        End If
        topic = QueryRegBase(class & "\shell\" & tp & "\ddeexec\topic")
        If Len(topic) = 0 Then
            ' Wenn kein Topic angegeben wird, dann wird System als
            ' Topic vorausgesetzt.
            topic = "System"
        End If
        application = QueryRegBase(class & "\shell\" & tp & "\ddeexec\application")
        If Len(application) = 0 Then
            ' Auch der Name der Applikation mu� nicht in der
            ' Registrationsdatenbank stehen. Leider etwas mehr
            ' Arbeit f�r den Entwickler, da f�r application
            ' der Stammteil des Programmnamens benutzt wird.
            SplitPathname cmd, fpath1, FName
            SplitFilename FName, fbody, fext1
            application = fbody
        End If
        ' Ist das Programm vielleicht schon aktiv?
        If GetModuleHandle(cmd) = 0 Then
            ' Nein, dann starten
            If ExecPrograms(cmd, tp) = True Then
                ' in das ifexec-Kommando mu� nun noch der Dokumentname
                ' einkopiert werden. Die passende Stelle ist mit
                ' %1 gekennzeichnet. replacestringpart �bernimmt
                ' die Zeichenfriemelei.
                ' Zur Erinnerung: ifexec kann gleich ddeexec sein,
                ' wenn die Anwendung hier keinen Unterschied macht.
                ifexec = ReplaceStringPart(ifexec, "%1", fullname)
                ' Endlich: Das DDE-Kommando in loaddocwithdde wird
                ' aufgerufen.
                ExecDocWithDDE = LoadDocWithDDE(c, application, topic, ifexec)
            Else
                ExecDocWithDDE = False
            End If
        Else
            ' Das Programm ist aktiv und mu� nicht gestartet werden.
            ' Ansonsten der gleiche Ablauf wie zuvor, jedoch mit
            ' ddeexec.
            ddeexec = ReplaceStringPart(ddeexec, "%1", fullname)
            ExecDocWithDDE = LoadDocWithDDE(c, application, topic, ddeexec)
        End If
    Else
        ExecDocWithDDE = False
    End If
End Function


Function ExecDocWithProgram(ByVal fullname$, ByVal fpath$, ByVal fext$, ByVal tp$) As Boolean
    Dim res As Long
    Dim buffer$, class$
    On Error Resume Next
    buffer = Space$(144)
    class = QueryRegBase("." & fext)
    If Len(class) Then
        buffer = QueryRegBase(class & "\shell\" & tp & "\command")
        If Len(buffer) Then
            res = Shell(ReplaceStringPart(buffer, "%1", fullname), 1)
            If Err = 0 Then
                ExecDocWithProgram = True
            Else
                ExecDocWithProgram = False
            End If
            Exit Function
        End If
    End If
    ' Sucht das passende Programm zur Anwendung.
    res = FindExecutable(fullname, CurDir$, buffer)
    If (res >= 32) Or (res < 0) Then
        ' Laufwerk und Pfad als aktuell setzen.
        ChDrive fpath
        ChDir fpath
        Err = 0
        ' Programm mit commandline-Parameter starten.
        res = Shell(VBStr(buffer) & " " & fullname, 1)
        If Err = 0 Then
            ExecDocWithProgram = True
        Else
            ExecDocWithProgram = False
        End If
    Else
        ExecDocWithProgram = False
    End If
End Function


' Inicia un programa
Function ExecPrograms(ByVal fullname$, ByVal p$) As Boolean
    Dim res As Long

    On Error Resume Next
    Err = 0
    If Len(p) Then fullname = fullname & " " & p
    res = Shell(fullname, 1)
    If Err Then
        ExecPrograms = False
    Else
        ExecPrograms = True
    End If
End Function


Function GetAvailPart(t, ByVal z%, ByVal nr%)
    Dim Zaehler%
    On Error Resume Next
    Zaehler = CountChar(t, z) + 1
    If Zaehler >= nr Then GetAvailPart = GetStringPartX(t, Chr$(z), nr)
End Function


Function GetStringPartX(ByVal t, ByVal z$, ByVal nr%)
    Dim i&, p&
    On Error Resume Next
    If Len(t) Then
        t = t & z
        nr = nr - 1
        For i = 1 To nr
            p = InStr(p + 1, t, z)
        Next i
        GetStringPartX = Mid$(t, p + 1, InStr(p + 1, t, z) - p - 1)
    End If
End Function


' Pr�ft, ob eine Dateierweiterung in einer Auswahl von M�glichkeiten vorkommt.
' Die Erweiterungen in extensions m�ssen durch Leerzeichen voneinander
' getrennt sein. Beispiel: "exe com pif bat". Gro�-/Kleinschreibung wird
' ignoriert.
Function IsFileOfType(ByVal checkextension$, ByVal extensions$) As Boolean
    On Error Resume Next
    If Len(checkextension) Then
        If InStr(" " & UCase$(extensions) & " ", " " & UCase$(checkextension) & " ") Then
            IsFileOfType = True
        Else
            IsFileOfType = False
        End If
    Else
        IsFileOfType = False
    End If
End Function


' Schickt einen DDE-Befehl an eine Anwendung. Hier speziell zum Laden
' von Dokumenten.
Function LoadDocWithDDE(c As Control, ByVal application$, ByVal topic$, ByVal cmd$) As Boolean
    On Error Resume Next
    c.LinkMode = 0
    c.LinkTimeout = -1
    c.LinkTopic = application & "|" & topic
    c.LinkMode = 2
    c.LinkExecute cmd
    c.LinkMode = 0
    If Err = 0 Then
        LoadDocWithDDE = True
    Else
        LoadDocWithDDE = False
    End If
End Function


' Liest einen String aus der Registrationsdatenbank. Um die Verwaltung
' einfach zu halten, beginnt die Suche immer in der ROOT der
' Datenbank.
'
Function QueryRegBase(ByVal entry As String) As String
    Dim buf As String
    Dim buflen As Long

    On Error Resume Next
    buf = Space$(300)
    buflen = Len(buf)
    ' 1 = von ROOT aus lesen
    ' buflen wird von der Funktion ge�ndert, deshalb w�re
    ' RegQueryValue(1, entry, buf, len(buf)) falsch.
    'HKEY_CLASSES_ROOT
    If RegQueryValue(HKEY_CLASSES_ROOT, entry, buf, buflen) = 0 Then
        If buflen > 1 Then
            ' Die R�ckgabe in buflen z�hlt chr$(0) am Ende mit
            ' Also ein Zeichen abziehen, aber nat�rlich nur dann,
            ' wenn chr$(0) nicht das einzige Zeichen in der R�ckgabe ist.
            QueryRegBase = Left$(buf, buflen - 1)
        Else
            QueryRegBase = ""
        End If
    Else
        QueryRegBase = ""
    End If
End Function


' Liest einen String aus der WIN.INI
Function ReadWinIniString$(ByVal section$, ByVal entry$, ByVal default$)
    Dim buffer$, l As Long
    On Error Resume Next
    buffer = Space$(300)
    l = GetProfileString(section, entry, default, buffer, Len(buffer))
    ReadWinIniString = Left$(buffer, l)
End Function


' Einfache Suchen- und Ersetzenfunktion f�r Stringteile.
' Wenn src mehrfach gefunden wird, dann wird es auch mehrfach durch
' rpl ersetzt. Gro�-/Kleinschreibung wird ignoriert, so da�
' sich die Funktion speziell f�r Pfadoperationen und �hnliches anbietet.
Function ReplaceStringPart$(ByVal source$, ByVal src$, ByVal rpl$)
    Dim pos&
    On Error Resume Next
    src = UCase$(src)
    pos = InStr(UCase$(source), src)
    If src <> UCase$(rpl) Then
        Do While pos
            source = Left$(source, pos - 1) & rpl & Right$(source, Len(source) - pos - Len(src) + 1)
            pos = InStr(pos + Len(rpl), UCase$(source), src)
        Loop
    End If
    ReplaceStringPart = source
End Function


' Zerlegt einen Dateinamen ohne Pfad in den Stammteil des Namens
' und die Dateierweiterung.
' F�r kompletten Dateinamen ggf. zuerst splitpathname aufrufen
Sub SplitFilename(ByVal FName$, fbody$, fext$)
    Dim p As Integer

    On Error Resume Next
    p = InStr(FName, ".")
    If p Then
        fbody = Left$(FName, p - 1)
        fext = Mid$(FName, p + 1, Len(FName) - p)
    Else
        fbody = FName
        fext = ""
    End If
End Sub


' Zerlegt einen kompletten Dateiname in Pfad und Dateiname ohne Pfad
Sub SplitPathname(ByVal fullname$, fpath$, FName$)
    Dim i%, p%
    On Error Resume Next
    Do
        p = i
        i = InStr(i + 1, fullname, "\")
    Loop While i
    If p Then
        fpath = Left$(fullname, p)
    End If
    FName = Right$(fullname, Len(fullname) - p)
End Sub


' Funktion zum Wandeln von ASCIIZ-Strings in VB-Strings.
' Entfernt auch f�hrende und folgende Leerzeichen.
Function VBStr$(ByVal c$)
    Dim pos&
    pos = InStr(c, Chr$(0))
    Select Case pos
    Case Is > 1
        VBStr = Trim$(Left$(c, pos - 1))
    Case 1
        VBStr = ""
    Case 0
        VBStr = Trim$(c)
    End Select
End Function

---

Mis Utilidades, bueno no todas... s�lo algunas. (20/Abr)

Estas son algunas de las funciones o procedimientos que, m�s o menos, incluyo o utilizo en muchos de mis programas.
Las que pongo aqu�, son algunas que no est�n puestas ya, pero que en las consultas que hac�is, pues lo hab�is preguntado m�s de uno.
El archivo que las contiene est� en este link, lo he puesto aparte, para que este no sea demasiado largo...
Te indico con un t�tulo, y el link, para que te sea m�s f�cil localizarlas:

1. Quitar de una cadena los Caracteres indicados.
2. Rellenar una cadena con caracteres hasta completar una longitud dada
3. Formatear un n�mero a una longitud dada y cambiar los signos de puntuaci�n al indicado
4. C�lculo de la letra del NIF
5. Cambiar los caracteres extra�os por ? (para usar en las consultas a bases de datos con LIKE)