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" dsans@abaforum.es 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)