Trucos y ejemplos de VBA para Microsoft Access

Función para contar caracteres en una cadena

Function absCharCount(Text As String, Char As String) As Long
    Dim lngCount As Long
    Dim strVar() As String
    strVar = Split(Text, Char)
    absCharCount = UBound(strVar)
End Function

Cómo se puede ver es fácilmente ampliable.

Public Function EliminarCaracteresEspeciales(Texto As String) As String
    Texto = Replace(Texto, "ñ", "N")
    Texto = Replace(Texto, "ñ", "ny")
    Texto = Replace(Texto, "Ñ", "NY")
    Texto = Replace(Texto, "á", "a")
    Texto = Replace(Texto, "é", "e;")
    Texto = Replace(Texto, "í", "i")
    Texto = Replace(Texto, "ó", "o")
    Texto = Replace(Texto, "ú", "u")
    Texto = Replace(Texto, "à", "a")
    Texto = Replace(Texto, "è", "e;")
    Texto = Replace(Texto, "ì", "i")
    Texto = Replace(Texto, "ò", "o")
    Texto = Replace(Texto, "ù", "u")
    Texto = Replace(Texto, "Á", "A")
    Texto = Replace(Texto, "É", "E;")
    Texto = Replace(Texto, "Í", "I")
    Texto = Replace(Texto, "Ó", "O")
    Texto = Replace(Texto, "Ú", "U")
' Dieresis ä
    Texto = Replace(Texto, "ä", "a")
    Texto = Replace(Texto, "ë", "e;")
    Texto = Replace(Texto, "ï", "i")
    Texto = Replace(Texto, "ö", "o")
    Texto = Replace(Texto, "ü", "u")
    Texto = Replace(Texto, "Ä", "A")
    Texto = Replace(Texto, "Ë", "E;")
    Texto = Replace(Texto, "Ï", "I")
    Texto = Replace(Texto, "Ö", "O")
    Texto = Replace(Texto, "Ü", "U")
' Otros
    Texto = Replace(Texto, "&", "And")
    Texto = Replace(Texto, "ã", "a")
    Texto = Replace(Texto, "ç", "c")
    Texto = Replace(Texto, "Ç", "c")
    Texto = Replace(Texto, "´", " ")
    Texto = Replace(Texto, "’", " ")
    Texto = Replace(Texto, "'", " ")
    Texto = Replace(Texto, "ª", " ")
    Texto = Replace(Texto, "º", " ")
    Texto = Replace(Texto, """", " ")
    EliminarCaracteresEspeciales = Texto
End Function

Esta instrucción tiene en cuenta que en el nombre del archivo pueda haber mas de un punto y que la extensión pueda ser un numero variable de caracteres. Se facilita en formato de Function pero puede ser convertida a una sola instrucción

Function ExtensionArchivo(Archivo As String, Optional Caracter As String = ".") As String
    On Error Resume Next
    ExtensionArchivo = Right(Archivo, Len(Archivo) - InStrRev(Archivo, Caracter))
End Function

Public Function ExtraerURL(URL As String) As String
    'quita la última barra
    If Right(URL, 1) = "/" Then
        ExtraerURL = Mid(URL, 1, Len(URL) - 1)
      Else
        ExtraerURL = URL
    End If
    ExtraerURL = Replace(ExtraerURL, "https://", "")
    ExtraerURL = Replace(ExtraerURL, "http://", "")
End Function

Un ejemplo de uso sería

debug.print ExtraerURL("https://alexborras.com/")[/vb]

Devuelve el valor www.alexborras.com Jugando con las sustituciones también podríamos eliminar las primeras www si queremos solo el dominio raíz.

Esta es una función que suelo utilizar para extraer emails de texto. Es la versión simplificada para encontrar un solo email ya que con una modificación en el Gosub puede capturar un número indeterminado de emails y almacenarlos en una colección de objetos. La función también sirve de ejemplo para la utilización de varias sentencias de manejo de strings en Visual Basic: Instr, Len, Mid y Asc

Public Function CapturarEmailTexto(Texto) As String
    Dim indPos As Long
    Dim indDesde As Long
    Dim indHasta As Long
    Dim strEmail As String
    Dim strInt   As String
    On Error GoTo ErrorSub
    CapturarEmailTexto = ""
    strEmail = ""
    If InStr(1, Texto, "@") = 0 Then Exit Function
    For indPos = 1 To Len(Texto)
        If Mid(Texto, indPos, 1) = "@" Then
            GoSub Captura
            Exit For
        End If
    Next
    CapturarEmailTexto = strEmail
    Exit Function
Captura:
    indDesde = 0
    indHasta = 0
' Buscar Inicio de Email
    For indDesde = indPos - 1 To 0 Step -1
        If indDesde = 0 Then Exit For
        strInt = Mid(Texto, indDesde, 1)
        If strInt = " " Then Exit For
        If strInt = ":" Then Exit For
        If strInt = "(" Then Exit For
        If strInt = ")" Then Exit For
        If strInt = "[" Then Exit For
        If strInt = "]" Then Exit For
        If strInt = "<" Then Exit For If strInt = ">" Then Exit For
        If strInt = """" Then Exit For
        If strInt = "'" Then Exit For
        If Asc(strInt) = 13 Then Exit For ' Control de Return
        If Asc(strInt) = 10 Then Exit For ' Control de Return
    Next
' Buscar Final de Email
    For indHasta = indPos + 1 To Len(Texto)
        strInt = Mid(Texto, indHasta, 1)
        If strInt = " " Then Exit For
        If strInt = ":" Then Exit For
        If strInt = "(" Then Exit For
        If strInt = ")" Then Exit For
        If strInt = "[" Then Exit For
        If strInt = "]" Then Exit For
        If strInt = "<" Then Exit For If strInt = ">" Then Exit For
        If strInt = """" Then Exit For
        If strInt = "'" Then Exit For
        If Asc(strInt) = 13 Then Exit For ' Control de Return
        If Asc(strInt) = 10 Then Exit For ' Control de Return
    Next
' Determinar Mail
    strEmail = Mid(Texto, indDesde + 1, indHasta - indDesde - 1)
' Eliminar Caracteres Finales incorrectos
    If Right(strEmail, 1) = "." Then strEmail = Mid(strEmail, 1, Len(strEmail) - 1)
    If Right(strEmail, 1) = "," Then strEmail = Mid(strEmail, 1, Len(strEmail) - 1)
    Return
ErrorSub:
    MsgBox Err.Number & ": " & Err.Description
End Function

Esta es una función manual que puede permitir manipular los caracteres de la cadena

Public Function CuentaPalabras(Texto As String, Palabra As String) As Long
    Dim wptr As Long
    Dim count As Long
    wptr = InStr(Texto, Palabra)
    Do Until wptr = 0
        count = count + 1
        wptr = InStr(wptr + 1, Texto, Palabra)
    Loop
    CuentaPalabras = count
End Function

dim Texto as string
Texto = "Hola1";
Texto = Left(Texto, Len(Texto) - 1)

La variable Texto valdrá "Hola"

Ejemplo de la función Split:

Dim matStrings() As String
txtstrings = "Uno,Dos,Tres"
matStrings = Split(txtStrings, ",")

Obtenemos una matriz de Strings con cada uno de los elementos: matstrings(1) = "Uno" matstrings(2) = "Dos" matstrings(3) = "Tres"

Función para obtener una Subcadena por delimitadores

Function absSubStringDelimiter(Text As String, Char1 As String, Char2 As String) As String
    Dim pos1 As Integer
    Dim pos2 As Integer
    pos1 = InStr(1, Text, Char1)
    pos2 = InStr(1, Text, Char2)
    If pos1 > 0 And pos2 > 0 Then
        If pos2 > pos1 Then
            absSubStringDelimiter = Trim(Mid(Text, pos1 + 1, (pos2 - pos1 - 1)))
        End If
    End If
End Function