Algunos Trozos de Código Util

Existe una enorme cantidad de código útil o "snippets" de VB por la web, los siguientes son solo unos pocos ejemplos que he encontrado útiles en su momento, lamentablemente no tengo las referencias originales de donde los saqué, pero igual van los agradecimientos a sus creadores.

Esta sección estará en constante actualización, conviene revisarla frecuentemente

Trabajar con Archivos INI

Se crea un módulo funcini.bas con lo siguiente:

' DECLARACIONES API
Declare Function GetPrivateProfileString Lib "kernel32" Alias _
       "GetPrivateProfileStringA" (ByVal lpApplicationName _
        As String, ByVal lpKeyName As Any, ByVal lpDefault _
        As String, ByVal lpReturnedString As String, ByVal _
        nSize As Long, ByVal lpFileName As String) As Long
Declare Function WritePrivateProfileString Lib "kernel32" Alias _
        "WritePrivateProfileStringA" (ByVal lpApplicationName _
         As String, ByVal lpKeyName As Any, ByVal lpString As Any, _
         ByVal lpFileName As String) As Long

Public Function sGetINI(sINIFile As String, sSection As String, sKey _
          As String, sDefault As String) As String
          Dim sTemp As String * 256
          Dim nLength As Integer
           sTemp = Space$(256)
          nLength = GetPrivateProfileString(sSection, sKey, sDefault, sTemp, _
                255, sINIFile)
           sGetINI = Left$(sTemp, nLength)
End Function

Public Sub writeINI(sINIFile As String, sSection As String, sKey _
           As String, sValue As String)
           Dim n As Integer
           Dim sTemp As String
            sTemp = sValue
           'Reemplaza CR/LF por espacios
           For n = 1 To Len(sValue)
                  If Mid$(sValue, n, 1) = vbCr Or Mid$(sValue, n, 1) = vbLf _
                      Then Mid$(sValue, n) = " "
            Next n
            n = WritePrivateProfileString(sSection, sKey, sTemp, sINIFile)
End Sub

Con esto se pueden usar la función SgetINI y la subrutina writeINI, por ejemplo

Sub InitProgram()
      Dim sINIFile As String
      Dim sUserName As String
      Dim nCount As Integer
      Dim i As Integer
      'Almacena el path del archivo INI
      sINIFile = App.Path & "\MYAPP.INI"
      'Lee desde el archivo INI la seccion user name
      sUserName = sGetINI(sINIFile, "Settings", "UserName", "?")
      If sUserName = "?" Then
            'No hay nombre de usuario grabado, lo pregunta y lo graba
            sUserName = InputBox$("Nombre de Usuario")
            writeINI sINIFile, "Settings", "UserName", sUserName
      End If
      txtUserName = sUserName
      'Rellena la combolist del archivo INI y
      'seleciona el ultimo elemento escogido por el usuario
      nCount = CInt(sGetINI(sINIFile, "Regions", "Count", 0))
      For i = 1 To nCount
            cmbRegn.AddItem sGetINI(sINIFile, "Regions", "Region" & i, "?")
      Next i
      cmbRegn.Text = sGetINI(sINIFile, "Regiones", _
      "LastRegion", cmbRegn.List(0))
End Sub

Private Sub cmdRead_Click()
      cmbRegn.Clear
      InitProgram
End Sub

Private Sub cmdView_Click()
      Shell "notepad " & App.Path & "\MYAPP.INI", vbNormalFocus
End Sub

Private Sub cmdWrite_Click()
      writeINI App.Path & "\MYAPP.INI", "Settings", "UserName", CStr(txtUserName.Text)
      writeINI App.Path & "\MYAPP.INI", "Regions", "LastRegion", cmbRegn.Text
End Sub

Private Sub Form_Load()
      InitProgram
End Sub

Cómo dar formato para celdas numéricas en el control DBGRID

A las columnas numéricas de un dbgrid se les puede aplicar un formato de visualización de los números. Para establecer este formato a través de código debe utilizarse la propiedad NumberFormat, pero en base al formato americano. Por ejemplo, imaginemos que la tercera columna en un dbgrid es una columna numérica en la que aparecen cifras de ventas con valores decimales, y queremos visualizar el punto para las unidades de millar y dos decimales tras la coma. Tenderemos a escribir el siguiente código:

DBGrid1.Columns(2).NumberFormat = "#.###,##"

Pues bien, el resultado será que, una vez ejecutado este código, esa columna aparecerá en blanco. La razón es que esta propiedad debe utilizarse en base al formato americano, o dicho de otro modo, el punto decimal debe ser una coma (",") y la separación de decimales un punto ("."). De esta forma, si utilizamos el siguiente código:

DBGrid1.Columns(2).NumberFormat = "#,###.##"

el resultado sí será el correcto, y veremos los valores numéricos en dicha columna, y además con el formato deseado (por ejemplo, 10.235,27).

Programación del Clipboard

:
Copiar Texto
Clipboard.Clear ' Limpiamos el destino
Clipboard.SetText Text1.SelText ' Copiamos el texto seleccionado
Text1.SetFocus

Pegar Texto
Text1.SelText = Clipboard.GetText() ' Pega el texto contenido en el ClipBoard
Text1.SetFocus
Cortar Texto:

Clipboard.SetText Text1.SelText ' Copia el texto seleccionado
Text1.SelText = "" ' Elimina el texto seleccionado del Text1
Text1.SetFocus

O usar los procesos implicitos de Windows, estas líneas ahorran mucho código, pero puede tener un resultado no deseado.

SendKeys "^A" ' Seleccionar todo
SendKeys "^C" ' Copiar
SendKeys "^V" ' Pegar
SendKeys "^X" ' Cortar
SendKeys "^Z" ' Deshacer

Activar la Selección al Recibir el Foco

En el evento GotFocus del control debes poner:

Text1.SelStart = 0
Text1.SelLength = Len(Text1)

Conversión Números a Letras

Function NumerosALetras(Numero As Double) As String
    Dim letras As String
    Dim HuboCentavos As Boolean
    Dim Decimales As Double
    Decimales = Numero - Int(Numero)
    Numero = Int(Numero)
    Inicializar
    letras = ""
    Do
       '*---> Validación si se pasa de 100 millones
       If Numero >= 1000000000 Then
          letras = "Error en Conversión a Letras"
          Numero = 0
          Decimales = 0
       End If
       
       '*---> Centenas de Millón
       If (Numero < 1000000000) And (Numero >= 100000000) Then
          If (Int(Numero / 100000000) = 1)_
                  And ((Numero - (Int(Numero / 100000000) * 100000000)) < 1000000) Then
             letras = letras & "cien millones "
          Else
             letras = letras & Centenas(Int(Numero / 100000000))
             If (Int(Numero / 100000000) <> 1) And (Int(Numero / 100000000) <> 5)_
                        And (Int(Numero / 100000000) <> 7) And (Int(Numero / 100000000) <> 9) Then
                letras = letras & "cientos "
             Else
                letras = letras & " "
             End If
          End If
          Numero = Numero - (Int(Numero / 100000000) * 100000000)
       End If
       
       '*---> Decenas de Millón
       If (Numero < 100000000) And (Numero >= 10000000) Then
          If Int(Numero / 1000000) < 16 Then
             letras = letras & Decenas(Int(Numero / 1000000))
             letras = letras & " millones "
             Numero = Numero - (Int(Numero / 1000000) * 1000000)
          Else
             letras = letras & Decenas(Int(Numero / 10000000) * 10)
             Numero = Numero - (Int(Numero / 10000000) * 10000000)
             If Numero > 1000000 Then
                letras = letras & " y "
             End If
          End If
       End If
       
       '*---> Unidades de Millón
       If (Numero < 10000000) And (Numero >= 1000000) Then
          If Int(Numero / 1000000) = 1 Then
             letras = letras & " un millón "
          Else
             letras = letras & Unidades(Int(Numero / 1000000))
             letras = letras & " millones "
          End If
          Numero = Numero - (Int(Numero / 1000000) * 1000000)
       End If
       
       '*---> Centenas de Millar
       If (Numero < 1000000) And (Numero >= 100000) Then
          If (Int(Numero / 100000) = 1) And ((Numero - (Int(Numero / 100000) * 100000)) < 1000) Then
             letras = letras & "cien mil "
          Else
             letras = letras & Centenas(Int(Numero / 100000))
             If (Int(Numero / 100000) <> 1) And (Int(Numero / 100000) <> 5)_
                        And (Int(Numero / 100000) <> 7) And (Int(Numero / 100000) <> 9) Then
                letras = letras & "cientos "
             Else
                letras = letras & " "
             End If
          End If
          Numero = Numero - (Int(Numero / 100000) * 100000)
       End If
       
       '*---> Decenas de Millar
       If (Numero < 100000) And (Numero >= 10000) Then
          If Int(Numero / 1000) < 16 Then
             letras = letras & Decenas(Int(Numero / 1000))
             letras = letras & " mil "
             Numero = Numero - (Int(Numero / 1000) * 1000)
          Else
             letras = letras & Decenas(Int(Numero / 10000) * 10)
             Numero = Numero - (Int((Numero / 10000)) * 10000)
             If Numero > 1000 Then
                letras = letras & " y "
             Else
                letras = letras & " mil "
             End If
          End If
       End If
       
       '*---> Unidades de Millar
       If (Numero < 10000) And (Numero >= 1000) Then
          If Int(Numero / 1000) = 1 Then
             letras = letras & "un"
          Else
             letras = letras & Unidades(Int(Numero / 1000))
          End If
          letras = letras & " mil "
          Numero = Numero - (Int(Numero / 1000) * 1000)
       End If
       
       '*---> Centenas
       If (Numero < 1000) And (Numero > 99) Then
          If (Int(Numero / 100) = 1) And ((Numero - (Int(Numero / 100) * 100)) < 1) Then
             letras = letras & "cien "
          Else
             letras = letras & Centenas(Int(Numero / 100))
             If (Int(Numero / 100) <> 1) And (Int(Numero / 100) <> 5)_
                        And (Int(Numero / 100) <> 7) And (Int(Numero / 100) <> 9) Then
                letras = letras & "cientos "
             Else
                letras = letras & " "
             End If
          End If
          Numero = Numero - (Int(Numero / 100) * 100)
          
       End If
       
        '*---> Decenas
       If (Numero < 100) And (Numero > 9) Then
          If Numero < 16 Then
             letras = letras & Decenas(Int(Numero))
             Numero = Numero - Int(Numero)
          Else
             letras = letras & Decenas(Int((Numero / 10)) * 10)
             Numero = Numero - (Int((Numero / 10)) * 10)
             If Numero > 0.99 Then
                letras = letras & " y "
             End If
          End If
    End If
       
       '*---> Unidades
       If (Numero < 10) And (Numero > 0.99) Then
          letras = letras & Unidades(Int(Numero))
          Numero = Numero - Int(Numero)
       End If
    Loop Until (Numero = 0)
    
    '*---> Decimales
    If (Decimales > 0) Then
        letras = letras & " con "
        letras = letras & Format(Decimales * 100, "00") & "/100"
    Else
        If (letras <> "Error en Conversión a Letras") And (Len(Trim(letras)) > 0) Then
           letras = letras & " exactos"
        End If
    End If
    
    NumerosALetras = letras
End Function
Function Centenas(VCentena As Double) As String
    If VCentena = 1 Then
       Centenas = Numeros(100)
    Else
       If VCentena = 5 Then
          Centenas = Numeros(101)
          Else
             If VCentena = 7 Then
                Centenas = letras & Numeros(102)
             Else
                If VCentena = 9 Then
                   Centenas = letras & Numeros(103)
                Else
                   Centenas = Numeros(VCentena)
                End If
             End If
       End If
    End If
End Function
Function Unidades(VUnidad As Double) As String
   Unidades = Numeros(VUnidad)
End Function
Function Decenas(VDecena As Double) As String
   Decenas = Numeros(VDecena)
End Function
Sub Inicializar()
   Numeros(0) = "cero"
   Numeros(1) = "uno"
   Numeros(2) = "dos"
   Numeros(3) = "tres"
   Numeros(4) = "cuatro"
   Numeros(5) = "cinco"
   Numeros(6) = "seis"
   Numeros(7) = "siete"
   Numeros(8) = "ocho"
   Numeros(9) = "nueve"
   Numeros(10) = "diez"
   Numeros(11) = "once"
   Numeros(12) = "doce"
   Numeros(13) = "trece"
   Numeros(14) = "catorce"
   Numeros(15) = "quince"
   Numeros(20) = "veinte"
   Numeros(30) = "treinta"
   Numeros(40) = "cuarenta"
   Numeros(50) = "cincuenta"
   Numeros(60) = "sesenta"
   Numeros(70) = "setenta"
   Numeros(80) = "ochenta"
   Numeros(90) = "noventa"
   Numeros(100) = "ciento"
   Numeros(101) = "quinientos"
   Numeros(102) = "setecientos"
   Numeros(103) = "novecientos"
End Sub

Simular Máscara Entrada de Fechas

Este código lo uso para simular una mascara de entrada para fechas a medida que voy ingresando los numeros me agrega la barra (/) la propiedad MaxLength deberia ser = 10, se puede mejorar validando los datos para dias, meses y años.

Private Sub Text1_KeyPress(KeyAscii As Integer)
      If Len(Text1) = 2 Then
          Text1 = Text1 & "/"
          Text1.SelStart = Len(Text1)
      ElseIf Len(Text1) = 5 Then
          Text1 = Text1 & "/"
          Text1.SelStart = Len(Text1)
      End If
End Sub

Comprobar la Existencia de un Archivo

:

Esta funcion devuelve verdadero o falso segun exista o no el archivo buscado

Function ExisteArchivo(cArchivo As String) As Boolean
ExisteArchivo = IIf(Dir$(cArchivo) = "", False, True)
End Function

Envio de e-mail Desde VB

1.- Adjuntar al proyecto los controles MAPI (Proyecto/Componentes y señalar Microsoft MAPI controls)
2.- En tu formulario, coloca los controles MAPISession y MAPIMessages
3.- Para enviar el mail:

MAPISession1.UserName = "nombre del remitente"
MAPISession1.NewSession = True
MAPISession1.DownLoadMail = True ' o false si no deseas recibir
MAPISession1.SignOn
MAPIMessages1.SessionID = MAPISession1.SessionID

MAPIMessages1.MsgIndex = -1 ' nuevo mensaje
MAPIMessages1.RecipDisplayName = "nombre del destinatario"

MAPIMessages1.ResolveName ' esto comprueba que el destinatario exista en las direcciones
MAPIMessages1.MsgSubject = "texto del asunto"
MAPIMessages1.MsgNoteText = "texto del mensaje"

' si deseas anexar algun archivo al mail:
MAPIMessages1.AttachmentIndex = 0 ' numero del anexo, 0,1,2,3....
MAPIMessages1.AttachmentName = "nombre_del_archivo_a_anexar"
MAPIMessages1.AttachmentPathName = "path_completo_del archivo_a_enviar"
MAPIMessages1.AttachmentPosition = 0 ' numero del anexo, 0,1,2,3...
MAPIMessages1.AttachmentType = 0 ' archivo de datos
' (puedes anexar varios archivos, incrementando el numero 0,1,2,3....)
' Y por fin, enviarlo:
MAPIMessages1.Send

' Cuando ya no tengas que enviar ningun mail más:
MAPISession1.SignOff

IMPORTANTE: Tu programa de mail debe ser cliente MAPI predeterminado:
en Outlook Express: Herramientas,Opciones,General y marcar la opcion correspondiente.

Funciones Para Programar el MAPI

Los códigos siguientes muestran rutins para programar el MAPI de mode de enviar y recibir mensajes de correo electrónico automáticamente, comandados por programa. Tal como en el ejemplo anterior todas estas funciones necesitan tener instalados los MAPI controls en una form y tener funcionando algun cliente de correo MAPI predeterminado (como Outlook por ejemplo)

Private Sub Command1_Click()
      Dim RetVal As Boolean
      Dim i As Long
      ' In a real application we'd check the return values to ensure all was well
      ' Start a session
      RetVal = AlterMailSession(Me, StartSession)
      ' Send a message with multiple addresses and attachments
      RetVal = CreateMailMessage(Me, "Test Message 1", " " & Chr(13) & "Test Contents" &_             Chr(13) & "More stuff")
      RetVal = MailMessageTo(Me, "elliot spencer", Primary)
      RetVal = MailMessageTo(Me, "elliot spencer", CC)
      RetVal = MailMessageTo(Me, "elliot spencer", Primary)
      RetVal = MailMessageTo(Me, "elliot spencer", CC)
      RetVal = MailMessageTo(Me, "elliot spencer", BlindCC)
      RetVal = AddAttachment(Me, "pq.doc", "c:\pq.doc", DataFile)
      RetVal = AddAttachment(Me, "pq.doc", "c:\pq.doc", OLEStatic)
      RetVal = SendMailMessage(Me)
      ' Abort this message
      RetVal = CreateMailMessage(Me, "Test Message 2", "Test Contents" & Chr(13) & "More_             stuff")
      RetVal = MailMessageTo(Me, "elliot spencer", CC)
      RetVal = AbortMailMessage(Me)
      ' Save this message
      RetVal = CreateMailMessage(Me, "Test Message 3", "Test Contents" & Chr(13) & "More_             stuff")
      RetVal = MailMessageTo(Me, "elliot spencer", Primary)
      RetVal = SaveMailMessage(Me)
      ' Stop the current session
      RetVal = AlterMailSession(Me, StopSession)
End Sub

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

This code comes from part of my MAPIFunc module and mainly deals with sending rather than receiving email messages. The module was tested against Exchange on NT4 but should work on Win 95 - Outlook setups.

'
' Created by E.Spencer (elliot@spnc.demon.co.uk) - This code is public domain.
'
Private Declare Function RegOpenKey Lib "AdvAPI32.dll" Alias "RegOpenKeyA" (ByVal hKey_       As Long, _ByVal lpSubKey As String, phkResult As Long) As Long
Private Declare Function RegQueryValueEx Lib "AdvAPI32.dll" Alias "RegQueryValueExA"_       (ByVal hKey As Long, _
            ByVal lpValueName As String, ByVal lpReserved As Long, lpType As Long, ByVal_                   lpData As String, _
                        lpcbData As Long) As Long
Private Declare Function RegCloseKey Lib "AdvAPI32.dll" (ByVal hKey As Long) As Long
Private Const HKEY_CURRENT_USER = &H80000001
Public Enum SessMode
StartSession
StopSession
End Enum
Public Enum AddrType
Primary
CC
BlindCC
End Enum
Public Enum AttachType
DataFile
OLEEmbedded
OLEStatic
End Enum
Public SStatus, MStatus As String

' Call this function to start and stop MAPI sessions
' Example :- MyBool = AlterMailSession(Me, StartSession)
' MyBool = AlterMailSession(Me, StopSession)
' MyBool will be true if operation succeeded
' First parameter is reference to form that contains MAPI message / session controls
' Second parameter is the required session mode - stop or start.
Public Function AlterMailSession(ByRef FName As Form, Mode As SessMode) As Boolean
AlterMailSession = True
On Error GoTo SessError
If Mode = StartSession Then
' Get the default exchange profile name
FName.MAPISession1.UserName = ReadRegistry(HKEY_CURRENT_USER, _
"Software\Microsoft\Windows NT\CurrentVersion\Windows Messaging Subsystem\Profiles\", "DefaultProfile")
' If session is already open return immediately
If SStatus = "Open" Then Exit Function
' Set up profile - Default for exchange
FName.MAPISession1.UserName = "MS Exchange Settings"
FName.MAPISession1.SignOn ' Start mail session
FName.MAPIMessages1.SessionID = FName.MAPISession1.SessionID ' Allocate session ID to_ Mail holder
SStatus = "Open"
MStatus = "Ready"
ElseIf Mode = StopSession Then
' If session is already closed return immediately
If SStatus = "Closed" Then Exit Function
FName.MAPISession1.SignOff ' End mail session
FName.MAPIMessages1.SessionID = 0
SStatus = "Closed"
MStatus = "NotReady"
End If
Exit Function
SessError:
SStatus = "Closed"
MStatus = "NotReady"
AlterMailSession = False
End Function

' Call this function to start a new mail message
' Example :- MyBool = CreateMailMessage(Me, "Test Message", "Test Contents")
' MyBool will be true if operation succeeded
' First parameter is reference to form that contains MAPI message / session controls
' The second parameter is the message subject line.
' The third parameter is the message content text (embed Chr(13) for newlines)
Public Function
CreateMailMessage(ByRef FName As Form, Subject As String, Contents As String) As Boolean
CreateMailMessage = False
' If session is not open return immediately
If SStatus <> "Open" Then Exit Function
CreateMailMessage = True
On Error GoTo MessError
FName.MAPIMessages1.Compose ' Start new message composition
FName.MAPIMessages1.MsgSubject = Subject ' Insert message subject line
FName.MAPIMessages1.MsgNoteText = Contents & Chr(13) & " " ' Insert message text
MStatus = "Open"
Exit Function
MessError:
MStatus = "NotReady"
CreateMailMessage = False
End Function

' Call this function to abort a mail message
' Example :- MyBool = AbortMailMessage(Me)
' MyBool will be true if operation succeeded
' First parameter is reference to form that contains MAPI message / session controls
Public Function AbortMailMessage(ByRef FName As Form) As Boolean
AbortMailMessage = False
' If session is not open return immediately
If SStatus <> "Open" Then Exit Function
' If no current mail message then return immediately
If MStatus <> "Open" Then Exit Function
AbortMailMessage = True
On Error GoTo MessError
FName.MAPIMessages1.Delete (mapMessageDelete)
MStatus = "Ready"
Exit Function
MessError:
AbortMailMessage = False
End Function

' Call this function to send a complete mail message
' Example :- MyBool = SendMailMessage(Me)
' MyBool will be true if operation succeeded
' First parameter is reference to form that contains MAPI message / session controls
Public Function SendMailMessage(ByRef FName As Form) As Boolean
Dim Tries As Integer
SendMailMessage = False
' If session is not open return immediately
If SStatus <> "Open" Then Exit Function
' If no current mail message then return immediately
If MStatus <> "Open" Then Exit Function
SendMailMessage = True
On Error GoTo MessError
Retry:
FName.MAPIMessages1.Send
MStatus = "Ready"
Exit Function
MessError:
Tries = Tries + 1
If Tries < 10 Then GoTo Retry
SendMailMessage = False
End Function

' Call this function to save a complete mail message without sending it
' Example :- MyBool = SaveMailMessage(Me)
' MyBool will be true if operation succeeded
' First parameter is reference to form that contains MAPI message / session controls
Public Function SaveMailMessage(ByRef FName As Form) As Boolean
SaveMailMessage = False
' If session is not open return immediately
If SStatus <> "Open" Then Exit Function
' If no current mail message then return immediately
If MStatus <> "Open" Then Exit Function
SaveMailMessage = True
On Error GoTo MessError
FName.MAPIMessages1.Save
MStatus = "Ready"
Exit Function
MessError:
SaveMailMessage = False
End Function

' Call this function to address a mail message to a recipient
' Example :- MyBool = MailMessageTo(Me, "elliot spencer", Primary)
' MyBool will be true if operation succeeded. Supply display names from address book
' list - names will be resolved to addresses in the address book before being added to
' recipient list.
' First parameter is reference to form that contains MAPI message / session controls
' Second parameter is name of recipient (as displayed in address list)
' Third parameter is type of recipient
Public Function MailMessageTo(ByRef FName As Form, ToName As String, AddrMode As AddrType) As Boolean
MailMessageTo = False
' If session is not open return immediately
If SStatus <> "Open" Then Exit Function
' If no current mail message then return immediately
If MStatus <> "Open" Then Exit Function
MailMessageTo = True
On Error GoTo MessError
FName.MAPIMessages1.RecipIndex = FName.MAPIMessages1.RecipCount ' Update count of recipients
If AddrMode = Primary Then FName.MAPIMessages1.RecipType = 1 ' Set to primary recipient type
If AddrMode = CC Then FName.MAPIMessages1.RecipType = 2 ' Set to carbon copy type
If AddrMode = BlindCC Then FName.MAPIMessages1.RecipType = 3 ' Set to blind carbon copy type
FName.MAPIMessages1.RecipDisplayName = ToName ' Display name as provided
FName.MAPIMessages1.ResolveName ' Resolve display name to real address via address book
Exit Function
MessError:
MailMessageTo = False
End Function

' Call this function to address a mail message to a recipient
' Example :- MyBool = AddAttachment(Me, "Test File", "c:\test.txt", DataFile)
' MyBool will be true if operation succeeded.
' First parameter is reference to form that contains MAPI message / session controls
' Second parameter is name of recipient (as displayed in address list)
' Third parameter is type of recipient
Public Function AddAttachment(ByRef FName As Form, AName As String, APath As String, AttMode As AttachType) As Boolean
AddAttachment = False
' If session is not open return immediately
If SStatus <> "Open" Then Exit Function
' If no current mail message then return immediately
If MStatus <> "Open" Then Exit Function
AddAttachment = True
On Error GoTo MessError
FName.MAPIMessages1.AttachmentIndex = FName.MAPIMessages1.AttachmentCount ' Update count of attachments
If AttMode = DataFile Then FName.MAPIMessages1.AttachmentType = 0
If AttMode = OLEEmbedded Then FName.MAPIMessages1.AttachmentType = 1
If AttMode = OLEStatic Then FName.MAPIMessages1.AttachmentType = 2
FName.MAPIMessages1.AttachmentPosition = FName.MAPIMessages1.AttachmentIndex
FName.MAPIMessages1.AttachmentPathName = APath ' File or object path as provided
FName.MAPIMessages1.AttachmentName = AName ' File or object name as provided
Exit Function
MessError:
AddAttachment = False
End Function

' From my registry read module - just to get the default
' exchange user name (profile name)
'
Public Function ReadRegistry(ByVal Group As Long, ByVal Section As String, ByVal Key As String) As String
Dim lResult As Long, lKeyValue As Long, lDataTypeValue As Long, lValueLength As Long, sValue As String
On Error Resume Next
lResult = RegOpenKey(Group, Section, lKeyValue)
sValue = Space$(2048)
lValueLength = Len(sValue)
lResult = RegQueryValueEx(lKeyValue, Key, 0&, lDataTypeValue, sValue, lValueLength)
If (lResult = 0) And (Err.Number = 0) Then
sValue = Left$(sValue, lValueLength - 1)
Else
sValue = "Not Found"
End If
lResult = RegCloseKey(lKeyValue)
ReadRegistry = sValue
End Function

Convertir Texto a Mayúsculas o Minúsculas

El siguiente código usa funciones API para convertir automáticamente TODOS los ingresos de texto en una form a mayúsculas o minúsculas

' Las siguientes sentencias incluir en un Módulo (.BAS)

'Función API para definir los atributos de un TextBox para Edición
Declare Function SetWindowLong Lib "user32" Alias "SetWindowLongA" (ByVal hwnd As_ Long, ByVal nIndex As Long, ByVal dwNewLong As Long) As Long
'Función API para obtener los atributos de Edición de un TextBox
Declare Function GetWindowLong Lib "user32" Alias "GetWindowLongA" (ByVal hwnd As_ Long, ByVal nIndex As Long) As Long

'Constantes Necesarias para las funciones API
Public Const GWL_STYLE = (-16) 'Tipo de Ventana de Edición
Public Const ES_UPPERCASE = &H8& 'Attributo de Edición, todos los caracteres serán convertidos a mayúsculas
Public Const ES_LOWERCASE = &H10& 'Attributo de Edición, todos los caracteres serán convertidos a minúsculas

Luego en el evento Load() de una form se coloca:

Private Sub Form_Load()
      Dim estilo As Long
      'obtiene los atributos del Textbox
      estilo = GetWindowLong(txtnombre.hwnd, GWL_STYLE)
      estilo = estilo Or ES_UPPERCASE 'para convertir todo a mayúsculas
      'estilo = estilo Or ES_LOWERCASE 'para convertir todo a minúsculas
      'asigna los nuevos atributos al TextBox
      SetWindowLong txtnombre.hwnd, GWL_STYLE, estilo
End Sub

Rutinas Para Ordenar stings

Aquí están el Quick, Merge e Insert Sort, recomiendo el uso de Quicksort tal como dicen los comentarios, lo he probado en grandes arrays y anda muy bien

' MODULE: MStringSortRoutines
' FILENAME: C:\My Code\vb\Sorting\MStringSortRoutines.bas
' AUTHOR: Phil Fresle
' CREATED: 01-Dec-1999
' COPYRIGHT: Copyright 1999 Frez Systems Limited. All Rights Reserved.
'
' DESCRIPTION:
' Generic string sort routines, prefer to use the 'non-pure' Quick Sort unless
' you have a good reason to choose another routine. Here are the routines in
' order of efficiency.
'
' Quick Sort - Fast for large arrays - delegates to insert sort when called
' with a small array and to sort small chunks of the large array
' This 'non-pure' quick sort is therefore quicker by not
' recursing for small chunks where a simple brute-force iteration
' is quicker.
' Merge Sort - Fast for large arrays - larger memory footprint than QuickSort
' but will sort faster if the data is not completely random. Delegates
' to insert sort for small arrays.
' Insert Sort - Fast for small arrays (say less than 60 values)
' Selection Sort - Fast for small arrays (say less than 60 values)
'
' NOTE: Due to the recursive nature of Quick and Merge sort they are not very efficient
' for small arrays which is why the routines delegate to a more brute force insert
' sort for small arrays.
'
' This is 'free' software with the following restrictions:
'
' You may not redistribute this code as a 'sample' or 'demo'. However, you are free
' to use the source code in your own code, but you may not claim that you created
' the sample code. It is expressly forbidden to sell or profit from this source code
' other than by the knowledge gained or the enhanced value added by your own code.
'
' Use of this software is also done so at your own risk. The code is supplied as
' is without warranty or guarantee of any kind.
'
' Should you wish to commission some derivative work based on the add-in provided
' here, or any consultancy work, please do not hesitate to contact us.
'
' Web Site: http://www.frez.co.uk
' E-mail: sales@frez.co.uk
'
' MODIFICATION HISTORY:
' 1.0 01-Dec-1999
' Phil Fresle
' Initial Version
' 1.1 22-Mar-2000
' Phil Fresle
' Added Merge Sort
'*******************************************************************************
Option Explicit

'*******************************************************************************
' SelectionSortStrings (SUB)
'
' PARAMETERS:
' (In/Out) - ListArray() - String - Array to sort
' (In) - bAscending - Boolean - True to sort ascending, false descending
' (In) - bCaseSensitive - Boolean - True for a case sensitive sort, false
' for an insensitive one
'
' DESCRIPTION:
' Simple Selection Sort routine for strings, fast for small arrays (say less
' than 60 values).
'*******************************************************************************
Public Sub SelectionSortStrings(ListArray() As String, _
Optional ByVal bAscending As Boolean = True, _
Optional ByVal bCaseSensitive As Boolean = False)

Dim sSmallest As String
Dim lSmallest As Long
Dim lCount1 As Long
Dim lCount2 As Long
Dim lMin As Long
Dim lMax As Long
Dim lCompareType As Long
Dim lOrder As Long

lMin = LBound(ListArray)
lMax = UBound(ListArray)

If lMin = lMax Then
Exit Sub
End If

' Order Ascending or Descending?
lOrder = IIf(bAscending, -1, 1)

' Case sensitive search or not?
lCompareType = IIf(bCaseSensitive, vbBinaryCompare, vbTextCompare)

' Loop through array swapping the smallest\largest (determined by lOrder)
' item with the current item
For lCount1 = lMin To lMax - 1
sSmallest = ListArray(lCount1)
lSmallest = lCount1

' Find the smallest\largest item in the array
For lCount2 = lCount1 + 1 To lMax
If StrComp(ListArray(lCount2), sSmallest, lCompareType) = lOrder Then
sSmallest = ListArray(lCount2)
lSmallest = lCount2
End If
Next

' Just swap them, even if we are swapping it with itself,
' as it is generally quicker to do this than test first
' each time if we are already the smallest with a
' test like: If lSmallest <> lCount1 Then
ListArray(lSmallest) = ListArray(lCount1)
ListArray(lCount1) = sSmallest
Next
End Sub

'*******************************************************************************
' InsertSortStringsStart (SUB)
'
' PARAMETERS:
' (In/Out) - ListArray() - String - Array to sort
' (In) - bAscending - Boolean - True to sort ascending, false descending
' (In) - bCaseSensitive - Boolean - True for a case sensitive sort, false
' for an insensitive one
'
' DESCRIPTION:
' User friendly entry point for InsertSortStrings
'*******************************************************************************
Public Sub InsertSortStringsStart(ListArray() As String, _
Optional ByVal bAscending As Boolean = True, _
Optional ByVal bCaseSensitive As Boolean = False)

Dim lMin As Long
Dim lMax As Long
Dim lOrder As Long
Dim lCompareType As Long

lMin = LBound(ListArray)
lMax = UBound(ListArray)

If lMin = lMax Then
Exit Sub
End If

' Order Ascending or Descending?
lOrder = IIf(bAscending, 1, -1)

' Case sensitive search or not?
lCompareType = IIf(bCaseSensitive, vbBinaryCompare, vbTextCompare)

InsertSortStrings ListArray, lMin, lMax, lOrder, lCompareType
End Sub

'*******************************************************************************
' InsertSortStrings (SUB)
'
' PARAMETERS:
' (In/Out) - ListArray() - String - Array to sort
' (In) - lMin - Long - Start of sorting region within array
' (In) - lMax - Long - End of sorting region within array
' (In) - lOrder - Long - Ascending is -1, Descending is +1, used
' for comparison in StrComp
' (In) - lCompareType - Long - Either vbBinaryCompare or vbTextCompare,
' used in StrComp function
'
' DESCRIPTION:
' Simple Insert Sort routine for strings, fast for small arrays as there is no
' recursion (say less than 60 values)
'*******************************************************************************
Private Sub InsertSortStrings(ListArray() As String, _
ByVal lMin As Long, _
ByVal lMax As Long, _
ByVal lOrder As Long, _
ByVal lCompareType As Long)

Dim sValue As String
Dim lCount1 As Long
Dim lCount2 As Long

' Loop through array shifting elements down to their correct place
For lCount1 = lMin + 1 To lMax
sValue = ListArray(lCount1)

' Find the place to put it
For lCount2 = lCount1 - 1 To lMin Step -1
If StrComp(ListArray(lCount2), sValue, lCompareType) <> lOrder Then
Exit For
End If
ListArray(lCount2 + 1) = ListArray(lCount2)
Next lCount2

' Insert it
ListArray(lCount2 + 1) = sValue
Next
End Sub

'*******************************************************************************
' QuickSortStringsStart (SUB)
'
' PARAMETERS:
' (In/Out) - ListArray() - String - Array to sort
' (In) - bAscending - Boolean - True to sort ascending, false descending
' (In) - bCaseSensitive - Boolean - True for a case sensitive sort, false
' for an insensitive one
'
' DESCRIPTION:
' User friendly entry point for QuickSortStrings
'*******************************************************************************
Public Sub QuickSortStringsStart(ListArray() As String, _
Optional ByVal bAscending As Boolean = True, _
Optional ByVal bCaseSensitive As Boolean = False)

Dim lMin As Long
Dim lMax As Long
Dim lOrder As Long
Dim lCompareType As Long

lMin = LBound(ListArray)
lMax = UBound(ListArray)

If lMin = lMax Then
Exit Sub
End If

' Order Ascending or Descending?
lOrder = IIf(bAscending, 1, -1)

' Case sensitive search or not?
lCompareType = IIf(bCaseSensitive, vbBinaryCompare, vbTextCompare)

QuickSortStrings ListArray, lMin, lMax, lOrder, lCompareType
End Sub

'*******************************************************************************
' QuickSortStrings (SUB)
'
' PARAMETERS:
' (In/Out) - ListArray() - String - Array to sort
' (In) - lLowerPoint - Long - Start of sorting region within array
' (In) - lUpperPoint - Long - End of sorting region within array
' (In) - lOrder - Long - Ascending is -1, Descending is +1, used
' for comparison in StrComp
' (In) - lCompareType - Long - Either vbBinaryCompare or vbTextCompare,
' used in StrComp function
'
' DESCRIPTION:
' Quick for large arrays, delegates to Insert Sort for small arrays and when
' partition is small
'*******************************************************************************
Private Sub QuickSortStrings(ListArray() As String, _
ByVal lLowerPoint As Long, _
ByVal lUpperPoint As Long, _
ByVal lOrder As Long, _
ByVal lCompareType As Long)

Const DELEGATE_POINT As Long = 60

Dim lMidPoint As Long

' Delegate to an insert sort if it is a small array (this is what makes this
' routine so much quicker than a standard quick sort routine). The delegation
' point could be tuned if necessary.
If (lUpperPoint - lLowerPoint) <= DELEGATE_POINT Then
InsertSortStrings ListArray, lLowerPoint, lUpperPoint, lOrder, lCompareType
Exit Sub
End If

' Do the quick sort
Do While lLowerPoint < lUpperPoint
' Find a mid point (split the array into partitions)
lMidPoint = QuickSortStringsPartition(ListArray, lLowerPoint, lUpperPoint, lOrder, lCompareType)

' Recurively sort the smaller partition
If (lMidPoint - lLowerPoint) <= (lUpperPoint - lMidPoint) Then
QuickSortStrings ListArray, lLowerPoint, lMidPoint - 1, lOrder, lCompareType
lLowerPoint = lMidPoint + 1
Else
QuickSortStrings ListArray, lMidPoint + 1, lUpperPoint, lOrder, lCompareType
lUpperPoint = lMidPoint - 1
End If
Loop
End Sub

'*******************************************************************************
' QuickSortStringsPartition (FUNCTION)
'
' PARAMETERS:
' (In/Out) - ListArray() - String - Array to sort
' (In) - lLow - Long - Start of sorting region within array
' (In) - lHigh - Long - End of sorting region within array
' (In) - lOrder - Long - Ascending is -1, Descending is +1, used
' for comparison in StrComp
' (In) - lCompareType - Long - Either vbBinaryCompare or vbTextCompare,
' used in StrComp function
'
' RETURN VALUE:
' Long - New pivot point
'
' DESCRIPTION:
' Selects a pivot point and moves smaller entries to one side of it and larger
' entries to the other side of it. Returns the position of the pivot point
' when finished.
'*******************************************************************************
Private Function QuickSortStringsPartition(ListArray() As String, _
ByVal lLow As Long, _
ByVal lHigh As Long, _
ByVal lOrder As Long, _
ByVal lCompareType As Long) As Long

Dim lPivot As Long
Dim sPivot As String
Dim lLowCount As Long
Dim lHighCount As Long
Dim sTemp As String

' Select pivot point and exchange with first element
lPivot = lLow + (lHigh - lLow) \ 2
sPivot = ListArray(lPivot)
ListArray(lPivot) = ListArray(lLow)

lLowCount = lLow + 1
lHighCount = lHigh

' Continually loop moving entries smaller than pivot to one side and
' larger than pivot to other side
Do
Do While lLowCount < lHighCount
If StrComp(sPivot, ListArray(lLowCount), lCompareType) <> lOrder Then
Exit Do
Else
lLowCount = lLowCount + 1
End If
Loop

Do While lHighCount >= lLowCount
If StrComp(ListArray(lHighCount), sPivot, lCompareType) <> lOrder Then
Exit Do
Else
lHighCount = lHighCount - 1
End If
Loop

If lLowCount >= lHighCount Then
Exit Do
End If

' Swap the items
sTemp = ListArray(lLowCount)
ListArray(lLowCount) = ListArray(lHighCount)
ListArray(lHighCount) = sTemp

lHighCount = lHighCount - 1
lLowCount = lLowCount + 1
Loop

ListArray(lLow) = ListArray(lHighCount)
ListArray(lHighCount) = sPivot
QuickSortStringsPartition = lHighCount
End Function

'*******************************************************************************
' MergeSortStringsStart (SUB)
'
' PARAMETERS:
' (In/Out) - ListArray() - String - Array to sort
' (In) - bAscending - Boolean - True to sort ascending, false descending
' (In) - bCaseSensitive - Boolean - True for a case sensitive sort, false
' for an insensitive one
'
' DESCRIPTION:
' User friendly entry point for MergeSortStrings
'*******************************************************************************
Public Sub MergeSortStringsStart(ListArray() As String, _
Optional ByVal bAscending As Boolean = True, _
Optional ByVal bCaseSensitive As Boolean = False)

Dim lMin As Long
Dim lMax As Long
Dim lOrder As Long
Dim lCompareType As Long

Const DELEGATE_POINT As Long = 60

lMin = LBound(ListArray)
lMax = UBound(ListArray)

If lMin = lMax Then
Exit Sub
End If

' Order Ascending or Descending?
lOrder = IIf(bAscending, 1, -1)

' Case sensitive search or not?
lCompareType = IIf(bCaseSensitive, vbBinaryCompare, vbTextCompare)

' Delegate to insert sort for very small arrays for speed
If (lMax - lMin) > DELEGATE_POINT Then
MergeSortStrings ListArray, lMin, lMax, lOrder, lCompareType
Else
InsertSortStrings ListArray, lMin, lMax, lOrder, lCompareType
End If
End Sub

'*******************************************************************************
' MergeSortStrings (SUB)
'
' PARAMETERS:
' (In/Out) - ListArray() - String - Array to sort
' (In) - lLowerPoint - Long - Start of sorting region within array
' (In) - lUpperPoint - Long - End of sorting region within array
' (In) - lOrder - Long - Ascending is -1, Descending is +1, used
' for comparison in StrComp
' (In) - lCompareType - Long - Either vbBinaryCompare or vbTextCompare,
' used in StrComp function
'
' DESCRIPTION:
' Quick for large arrays
'*******************************************************************************
Private Sub MergeSortStrings(ListArray() As String, _
ByVal lLowerPoint As Long, _
ByVal lUpperPoint As Long, _
ByVal lOrder As Long, _
ByVal lCompareType As Long)

Dim lMidPoint As Long

If lUpperPoint > lLowerPoint Then
' Split the array up recursively and sort (divide and conquer)
lMidPoint = (lUpperPoint + lLowerPoint) \ 2
MergeSortStrings ListArray, lLowerPoint, lMidPoint, lOrder, lCompareType
MergeSortStrings ListArray, lMidPoint + 1, lUpperPoint, lOrder, lCompareType

' Merge to sort
MergeStrings ListArray, lLowerPoint, lMidPoint, lUpperPoint, lOrder, lCompareType
End If
End Sub

'*******************************************************************************
' MergeStrings (SUB)
'
' PARAMETERS:
' (In/Out) - ListArray() - String - Array to sort
' (In) - lLowerPoint - Long - Start of sorting region within array
' (In) - lMidPoint - Long - Mid point
' (In) - lUpperPoint - Long - End of sorting region within array
' (In) - lOrder - Long - Ascending is -1, Descending is +1, used
' for comparison in StrComp
' (In) - lCompareType - Long - Either vbBinaryCompare or vbTextCompare,
' used in StrComp function
'
' DESCRIPTION:
' Merge part of the MergeSort that merges the two sorted parts lLowerPoint to
' lMidPoint and lMidPoint+1 to lUpperPoint
'*******************************************************************************
Private Sub MergeStrings(ListArray() As String, _
ByVal lLowerPoint As Long, _
ByVal lMidPoint As Long, _
ByVal lUpperPoint As Long, _
ByVal lOrder As Long, _
ByVal lCompareType As Long)

Dim TempList() As String
Dim lcount As Long
Dim lBottomPointer As Long
Dim lTopPointer As Long
Dim lCurrentPointer As Long

' Prepare temporary array
ReDim TempArray(lLowerPoint To lUpperPoint)

' Make a temporary copy of the array
For lcount = lLowerPoint To lUpperPoint
TempArray(lcount) = ListArray(lcount)
Next

' Initialise pointers that will be used to move through array
lBottomPointer = lLowerPoint
lTopPointer = lMidPoint + 1
lCurrentPointer = lLowerPoint

' Loop until we have got to the end of one section
Do While (lBottomPointer <= lMidPoint And lTopPointer <= lUpperPoint)
If StrComp(TempArray(lBottomPointer), TempArray(lTopPointer), lCompareType) <> lOrder Then
ListArray(lCurrentPointer) = TempArray(lBottomPointer)
lBottomPointer = lBottomPointer + 1
Else
ListArray(lCurrentPointer) = TempArray(lTopPointer)
lTopPointer = lTopPointer + 1
End If
lCurrentPointer = lCurrentPointer + 1
Loop

' Copy the rest of the uncompleted section onto the end
Do While lBottomPointer <= lMidPoint
ListArray(lCurrentPointer) = TempArray(lBottomPointer)
lBottomPointer = lBottomPointer + 1
lCurrentPointer = lCurrentPointer + 1
Loop
Do While lTopPointer <= lUpperPoint
ListArray(lCurrentPointer) = TempArray(lTopPointer)
lTopPointer = lTopPointer + 1
lCurrentPointer = lCurrentPointer + 1
Loop
End Sub

Clase de Utilidades para ADO

VERSION 1.0 CLASS
BEGIN
MultiUse = -1 'True
Persistable = 0 'NotPersistable
DataBindingBehavior = 0 'vbNone
DataSourceBehavior = 0 'vbNone
MTSTransactionMode = 0 'NotAnMTSObject
END
Attribute VB_Name = "AdoUtils"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = True
Attribute VB_PredeclaredId = False
Attribute VB_Exposed = False
'INCLUDE A REFERENCE TO MICROSOFT ACTIVE DATA OBJECTS
'IN ORDER TO USE THIS CLASS
Option Explicit
Private m_sConnectionString As String
Private m_sLastError As String
Private m_bIsSQL As Boolean

Public Property Get ConnectionString() As String
ConnectionString = m_sConnectionString
End Property

Public Property Let ConnectionString(ByVal NewValue As String)
'for some of the functions in this class
'you will need to firsta
'set this property to a
'valid connection string

'or reset it when you need to change the connection
m_sConnectionString = NewValue
End Property

Public Property Get isSQL() As Boolean

isSQL = m_bIsSQL
End Property

Public Property Let isSQL(ByVal NewValue As Boolean)
'SET TO TRUE IF YOU ARE USING SQL SERVER
'DEFAULT IS ACCESS
m_bIsSQL = NewValue
End Property
Public Function Clone(ByVal objRecordset As ADODB.Recordset, Optional ByVal LockType As ADODB.LockTypeEnum = adLockBatchOptimistic) As ADODB.Recordset
'RETURNS A CLONE (COPY OF AN EXISTING RECORDSET)

Dim objNewRS As ADODB.Recordset
Dim objField As Object
Dim lngCnt As Long
On Error GoTo LocalError

Set objNewRS = New ADODB.Recordset
objNewRS.CursorLocation = adUseClient
objNewRS.LockType = LockType

For Each objField In objRecordset.Fields
objNewRS.Fields.Append objField.Name, objField.Type, objField.DefinedSize, objField.Attributes
Next objField

If Not objRecordset.RecordCount = 0 Then
Set objNewRS.ActiveConnection = objRecordset.ActiveConnection
objNewRS.Open

objRecordset.MoveFirst
While Not objRecordset.EOF
objNewRS.AddNew
For lngCnt = 0 To objRecordset.Fields.Count - 1
objNewRS.Fields(lngCnt).Value = objRecordset.Fields(lngCnt).Value
Next lngCnt
objRecordset.MoveNext
Wend
objNewRS.MoveFirst
End If

Set Clone = objNewRS
Exit Function
LocalError:
m_sLastError = Err.Number & " - " & Err.Description
If objNewRS.State = adStateOpen Then
objNewRS.Close
End If
Set objNewRS = Nothing
End Function

Function Datashape(ByVal tblParent As String, _
ByVal tblChild As String, _
ByVal fldParent As String, _
ByVal fldChild As String, _
Optional ordParent As String = "", _
Optional ordChild As String = "", _
Optional WhereParent As String = "", _
Optional WhereChild As String = "", _
Optional ParentFields As String = "*", _
Optional ChildFields As String = "*", _
Optional MaxRecords As Long = 0) As ADODB.Recordset
'=========================================================
'This function will return a DisConnected SHAPEd RecordSet
'Assumptions:
'
'tblParent = Valid Table in the Database - String \ Parent Table
'tblChild = Valid Table in the Database - String / Child Table
'
'fldParent = Valid Field in Parent Table - String \ relate this field
'fldChild = Valid Field in Child Table - String / ..to this field
'
'ordParent = Valid Field in Parent Table - String \ ordering
'ordChild = Valid Field in Child Table - String /
'
'WhereParent = Valid SQL Where Clause - Variant (Optional)
'WhereChild = Valid SQL Where Clause - Variant (Optional)
'
'ParentFields = Specific Fields to return - String (pipe delimitered)
'ChildFields = Specific Fields to return - String (pipe delimitered)
'MaxRecords = Specify Maximum Child Records - Long (0 = ALL)

'NOTE: You may have to change connection string: Normal Connection Strings
'Begin with "Provider=". For the MsDataShape Provider, the connection string
'begins with "Data Provider = "

'EXAMPLE: THIS RETURNS A HYPOTHETICAL RECORDSET OF CUSTOMERS,
'WHERE ONE OF THE MEMBERS IS A HYPOTHETICAL CHILD RECORDSET
'OF THE CUSTOMERS' ORDERS

'Dim sShapeConnectionString As String
'Dim oCustRs As ADODB.Recordset
'Dim oOrderRs As ADODB.Recordset
'Dim oADO As New AdoUtils
'Dim sSQL As String

'sShapeConnectionString = "Data Provider=Microsoft.Jet.OLEDB.4.0;Data Source=C:\MyBusiness.mdb"
'sSQL = "SELECT * FROM CUSTOMERS"
'With oTest
' .ConnectionString = sShapeConnectionString
' Set oCustRs = .Datashape("Customers", "Orders", "ID", "CustomerID")
' Set oOrderRs = ors.Fields(ors.Fields.Count - 1).Value
'End With

'=========================================================
On Error GoTo ErrHandler

Dim cn As ADODB.Connection
Dim rs As ADODB.Recordset
Dim lSQL As String
Dim pSQL As String
Dim cSQL As String
Dim pWhere As String
Dim cWhere As String
Dim pOrder As String
Dim cOrder As String

'Define the SQL Statement
lSQL = ""
ParentFields = Replace(ParentFields, "|", ", ")
ChildFields = Replace(ChildFields, "|", ", ")
pWhere = WhereParent
cWhere = WhereChild
pOrder = ordParent
cOrder = ordChild

If WhereParent <> "" Then WhereParent = " WHERE " & WhereParent
If WhereChild <> "" Then WhereChild = " WHERE " & WhereChild
If pOrder <> "" Then pOrder = " ORDER By " & pOrder
If cOrder <> "" Then cOrder = " ORDER By " & cOrder
'Define Parent SQL Statement
pSQL = ""
If MaxRecords > 0 Then
If isSQL Then
pSQL = pSQL & "{SET ROWCOUNT " & MaxRecords & " SELECT [@PARENTFIELDS]"
Else
pSQL = pSQL & "{SELECT TOP " & MaxRecords & " [@PARENTFIELDS]"
End If
Else
pSQL = pSQL & "{SELECT " & "[@PARENTFIELDS]"
End If
pSQL = pSQL & " FROM [@PARENT]"
pSQL = pSQL & " [@WHEREPARENT]"
pSQL = pSQL & " [@ORDPARENT]} "
'Substitute for actual values
pSQL = Replace(pSQL, "[@PARENTFIELDS]", ParentFields)
pSQL = Replace(pSQL, "[@PARENT]", tblParent)
pSQL = Replace(pSQL, "[@WHEREPARENT]", pWhere)
pSQL = Replace(pSQL, "[@ORDPARENT]", pOrder)
pSQL = Trim(pSQL)
'Define Child SQL Statement
cSQL = ""
cSQL = cSQL & "{SELECT " & "[@CHILDFIELDS]"
cSQL = cSQL & " FROM [@CHILD]"
cSQL = cSQL & " [@WHERECHILD]"
cSQL = cSQL & " [@ORDCHILD]} "
'Substitute for actual values
cSQL = Replace(cSQL, "[@CHILDFIELDS]", ChildFields)
cSQL = Replace(cSQL, "[@CHILD]", tblChild)
cSQL = Replace(cSQL, "[@WHERECHILD]", cWhere)
cSQL = Replace(cSQL, "[@ORDCHILD]", cOrder)
cSQL = Trim(cSQL)

'Define Parent Properties
lSQL = "SHAPE " & pSQL & vbCrLf
'Define Child Properties
lSQL = lSQL & "APPEND (" & cSQL & " RELATE " & fldParent & " TO " & fldChild & ") AS ChildItems"

'Get the data
Set cn = New ADODB.Connection
With cn
.ConnectionString = ConnectionString
.CursorLocation = adUseServer
.Provider = "MSDataShape"
.Open
End With

Set rs = New ADODB.Recordset
With rs
.CursorType = adOpenForwardOnly
.LockType = adLockReadOnly
.Source = lSQL
.ActiveConnection = cn
.Open
End With
Set rs.ActiveConnection = Nothing
cn.Close
Set cn = Nothing
Set Datashape = rs
Set rs = Nothing
Exit Function
ErrHandler:
If Not cn Is Nothing Then

If cn.State = adStateOpen Then cn.Close
Set cn = Nothing
End If
m_sLastError = Err.Number & " - " & Err.Description

End Function

Public Function EmptyRS(ByVal adoRS As ADODB.Recordset) As Boolean
'Checks for an EMPTY RecordSet
On Error GoTo ErrHandler
EmptyRS = True
If Not adoRS Is Nothing Then
EmptyRS = ((adoRS.BOF = True) And (adoRS.EOF = True))
End If
Exit Function
ErrHandler:
m_sLastError = Err.Number & " - " & Err.Description
EmptyRS = True
End Function

Public Function Execute(SQL As String) As Boolean
'TO DIRECTLY EXECUTE AN INSERT, UPDATE, OR DELETE
'SQL STATMENT. SET THE CONNECTION STRING PROPERTY
'TO A VALID CONNECTION STRING FIRST

On Error GoTo LocalError
Dim cn As New ADODB.Connection
With cn
.ConnectionString = ConnectionString
.CursorLocation = adUseServer
.Open
.BeginTrans
.Execute SQL
.CommitTrans
.Close
End With
Set cn = Nothing
Execute = True
Exit Function
LocalError:
m_sLastError = Err.Number & " - " & Err.Description
If cn.State = adStateOpen Then
cn.RollbackTrans
cn.Close
End If
Set cn = Nothing
Execute = False
End Function

Public Function GetRS(SQL As String) As ADODB.Recordset
'SET THE CONNECTION STRING PROPERTY TO A VALID CONNECTION STRING
'PASS AN SQL STATEMENT TO THIS FUNCTION
'THE RETURN VALUE WILL BE AN ADODB RECORDSET

Dim rs As New ADODB.Recordset
On Error GoTo LocalError
With rs
.ActiveConnection = ConnectionString
.CursorLocation = adUseClient
.LockType = adLockOptimistic
.CursorType = adOpenKeyset
.Source = SQL
.Open
Set .ActiveConnection = Nothing
End With
Set GetRS = rs
Set rs = Nothing
Exit Function
LocalError:
m_sLastError = Err.Number & " - " & Err.Description
Set rs = Nothing
End Function

Public Function GetCount(TableName As String, Optional WhereClause As String = "") As Long

'RETURNS COUNT OF RECORDS WITHIN A TABLE, WITH OPTIONAL WHERE CLAUSE

On Error GoTo LocalError
Dim rs As New ADODB.Recordset
Dim SQL As String
GetCount = 0
If WhereClause <> "" Then
SQL = "Select COUNT (*) FROM " & TableName & " WHERE " & WhereClause
Else
SQL = "Select COUNT (*) FROM " & TableName
End If
With rs
.ActiveConnection = ConnectionString
.CursorLocation = adUseClient
.LockType = adLockReadOnly
.CursorType = adOpenKeyset
.Source = SQL
.Open
Set .ActiveConnection = Nothing
End With
GetCount = rs.Fields(0).Value
Set rs = Nothing
Exit Function
LocalError:
m_sLastError = Err.Number & " - " & Err.Description
If rs.State = adStateOpen Then
rs.Close
End If
Set rs = Nothing
GetCount = -1
End Function

Public Function PutRS(rs As ADODB.Recordset) As Boolean
'USE THIS TO UPDATE A RECORDSET IN BATCH (TRANSACTIONAL) MODE
'IF CHANGES TO THE RECORDSET'S WERE MADE PRIOR TO THIS CALL
'THIS FUNCTION WILL COMMIT THEM TO THE UNDERYLING DATABASE

On Error GoTo LocalError
PutRS = False
If EmptyRS(rs) Then
Exit Function
ElseIf rs.LockType = adLockReadOnly Then
Exit Function
Else
Dim cn As New ADODB.Connection
With cn
.ConnectionString = ConnectionString
.CursorLocation = adUseServer
.Open
.BeginTrans
End With
With rs
.ActiveConnection = cn
.UpdateBatch
cn.CommitTrans
Set .ActiveConnection = Nothing
End With
cn.Close
Set cn = Nothing
End If
PutRS = True
Exit Function
LocalError:
m_sLastError = Err.Number & " - " & Err.Description
If cn.State = adStateOpen Then
cn.RollbackTrans
cn.Close
End If
Set cn = Nothing
PutRS = False
End Function

Public Function sqlBoolean(TrueFalse As Boolean) As Integer
'CONVERTS BIT RETURN VALUE FROM SQL SERVER

'This is because SQL True = 1
'VB True = -1
sqlBoolean = TrueFalse
If isSQL Then
If TrueFalse = True Then sqlBoolean = TrueFalse * TrueFalse
End If
End Function

Public Function sqlDate(ByVal vDate As Variant) As String

'THIS FUNCTION TAKES VALUES THAT ARE POSSIBLE
'DATES AND FORMATS THEM PROPERFOR INSERTION INTO
'DATABASE COLUMNS DEFINED AS DATES

On Error GoTo LocalError
'Remove all invalid characters
vDate = Trim(CStr(vDate))
vDate = Replace(vDate, "#", "")
vDate = Replace(vDate, "'", "")
vDate = Replace(vDate, Chr(34), "")
'--------------------------------------
'Convert the Date to a Double Precision
' for international compatability
'--------------------------------------
sqlDate = ""
'First see in what format the data came
' Validate parameter
If Not IsDate(vDate) Or IsNull(vDate) Then
'Maybe it is a number
If IsNumeric(vDate) Then
vDate = CDate(vDate)
End If
If Not IsDate(vDate) Then
'Still not a date
Exit Function
End If
End If
If isSQL Then
'Format is MM/DD/??YY
sqlDate = Format(vDate, "mm\/dd\/yyyy")
sqlDate = "'" & sqlDate & "'"
Else
'Format by Regional Settings
sqlDate = FormatDateTime(vDate, vbShortDate)
sqlDate = "#" & sqlDate & "#"
End If
Exit Function
LocalError:
m_sLastError = Err.Number & " - " & Err.Description
sqlDate = ""
End Function

Public Function sqlDateTime(ByVal vDate As Variant) As String

'THIS FUNCTION TAKES VALUES THAT ARE POSSIBLE
'DATES AND FORMATS THEM PROPERFOR INSERTION INTO
'DATABASE COLUMNS DEFINED AS DATE/TIMES

On Error GoTo LocalError
'Remove all invalid characters
vDate = Trim(CStr(vDate))
vDate = Replace(vDate, "#", "")
vDate = Replace(vDate, "'", "")
vDate = Replace(vDate, Chr(34), "")
'--------------------------------------
'Convert the Date to a Double Precision
' for international compatability
'--------------------------------------
sqlDateTime = ""
'First see in what format the data came
' Validate parameter
If Not IsDate(vDate) Or IsNull(vDate) Then
'Maybe it is a number
If IsNumeric(vDate) Then
vDate = CDate(vDate)
End If
If Not IsDate(vDate) Then
'Still not a date
Exit Function
End If
End If
If isSQL Then
'Format is MM/DD/??YY HH:MM:SS
sqlDateTime = Format(vDate, "mm\/dd\/yyyy hh\:mm\:ss")
sqlDateTime = "'" & sqlDateTime & "'"
Else
'Format by Regional Settings
sqlDateTime = FormatDateTime(vDate, vbShortDate) & " " & Format(vDate, "hh\:mm\:ss")
sqlDateTime = "#" & sqlDateTime & "#"
End If
Exit Function
LocalError:
m_sLastError = Err.Number & " - " & Err.Description
sqlDateTime = ""
End Function

Public Function sqlTime(ByVal vDate As Variant) As String
'THIS FUNCTION TAKES VALUES THAT ARE POSSIBLE
'DATES AND FORMATS THEM PROPERFOR INSERTION INTO
'DATABASE COLUMNS DEFINED AS TIME ONLY

On Error GoTo LocalError
'Remove all invalid characters
vDate = Trim(CStr(vDate))
vDate = Replace(vDate, "#", "")
vDate = Replace(vDate, "'", "")
vDate = Replace(vDate, Chr(34), "")
'--------------------------------------
'Convert the Date to a Double Precision
' for international compatability
'--------------------------------------
sqlTime = ""
'First see in what format the data came
' Validate parameter
If Not IsDate(vDate) Or IsNull(vDate) Then
'Maybe it is a number
If IsNumeric(vDate) Then
vDate = CDate(vDate)
End If
If Not IsDate(vDate) Then
'Still not a date
Exit Function
End If
End If
If isSQL Then
'Format is MM/DD/??YY HH:MM:SS
sqlTime = FormatDateTime(vDate, vbLongTime)
sqlTime = "'" & sqlTime & "'"
Else
'Format by Regional Settings
sqlTime = FormatDateTime(vDate, vbLongTime)
sqlTime = "#" & sqlTime & "#"
End If
Exit Function
LocalError:
m_sLastError = Err.Number & " - " & Err.Description
sqlTime = ""
End Function

Public Function sqlEncode(sqlValue) As String

'IF A STRING VALUE IN AN SQL STATMENT HAS A ' CHARACTER,
'USE THIS FUNCTION SO THE STRING CAN BE USED IN THE STATEMENT
sqlEncode = Replace(sqlValue, "'", "''")
End Function

Public Property Get LastError() As String
'IF AN ERROR OCCURS IN CALLING ONE OF THE FUNCTIONS IN THIS CLASS
'READ THIS PROPERTY TO SEE WHAT THE ERROR WAS

LastError = m_sLastError
m_sLastError = ""
End Property

Public Function ExecuteID(SQL As String) As Long
'PURPOSE: RETURN VALUE OF IDENTITY COLUMN
'OF A NEWLY INSERTED RECORD

'SQL is a valid Insert statement.
'ConnetionString properyt has been set to a valid Connection String
'Tested on SQL7 as well as ACCESS 2000 using Jet4

On Error GoTo LocalError
Dim cn As New ADODB.Connection
Dim rs As New ADODB.Recordset
Dim AutoID As Long

With rs

'Prepare the RecordSet
.CursorLocation = adUseServer
.CursorType = adOpenForwardOnly
.LockType = adLockReadOnly
.Source = "SELECT @@IDENTITY"
End With

With cn
.ConnectionString = ConnectionString
.CursorLocation = adUseServer
.Open
.BeginTrans
.Execute SQL, , adCmdText + adExecuteNoRecords

With rs

.ActiveConnection = cn
.Open , , , , adCmdText
AutoID = rs(0).Value
.Close
End With
.CommitTrans
.Close
End With
Set rs = Nothing
Set cn = Nothing
'If we get here ALL was Okay
ExecuteID = AutoID
Exit Function

LocalError:
m_sLastError = Err.Number & " - " & Err.Description

ExecuteID = 0

End Function