Mis funciones en VBA Access

Deja un comentario / Visual Basic / Por Alex Borrás / 10 marzo, 2021

Las funciones de VBA Access que uso de forma frecuente en mis aplicaciones Access las tengo en una base de datos externa. Lo único que se debe hacer es poner una referencia desde nuestro proyecto a esa base de datos y automáticamente tenemos todas las funciones disponibles en nuestro MDB o ACCB.

Esto permite reutilizar código, un tema fundamental para desarrollar programas con eficiencia. También tiene la ventaja de que cualquier nueva mejora que hagamos pasa a estar disponible para todos los proyectos. Puedes consultar más trucos de VBA en mi Diccionario.

Código VBA completo de la base de datos de funciones

Índice de contenidos

1 mdlFuncionesValidacion.bas
2 mdlFuncionesFSO.bas
3 clsAbsURL.cls
4 mdlFuncionesNet.bas
5 mdlVariables.bas

mdlFuncionesValidacion.bas


Option Compare Database
Option Explicit
' Valida una cadena eliminando algunos errores que se producen cuando es nula. Elimnina los espacios en blanco sobrantes.
Public Function ValidarString(ByVal Valor As Variant, Optional ValorDefecto As String = "") As String
    If IsNull(Valor) Then
        ValidarString = ValorDefecto
        Exit Function
    End If
    If Trim(Valor) = "" Then
        ValidarString = ValorDefecto
        Exit Function
    End If
    ValidarString = Trim(Valor)
End Function
' Valida y convierte un variable a formato numérico si es posible
Public Function ValidarNumero(Numero As Variant, Optional ValorPorDefecto As Variant = 0) As Variant
    On Error GoTo ErrorFunction
    If IsMissing(Numero) Then
        ValidarNumero = ValorPorDefecto
        Exit Function
    End If
    If IsNull(Numero) Then
        ValidarNumero = ValorPorDefecto
        Exit Function
    End If
    If VarType(Numero) = vbString Then
        If Trim(Numero) = "" Then
            ValidarNumero = ValorPorDefecto
          Else
            If InStr(1, Numero, ",") = 0 Then
                ValidarNumero = Val(Numero) ' Enteros
              Else
                ValidarNumero = CDbl(Numero)  ' Decimales
            End If
            If ValidarNumero = 0 Then
                ValidarNumero = ValorPorDefecto
            End If
        End If
        Exit Function
    End If
    ValidarNumero = Numero
    Exit Function
ErrorFunction:
    MsgBox "Error: " & Err.Number & Chr(13) & "Se pone valor a 0. Descripcion: " & Err.Description, vbCritical, "ValidarNumero"
    ValidarNumero = 0
    'Resume
End Function
' Valida que una fecha sea correcta
Function ValidarDate(Fecha As Variant) As Date
    On Error GoTo ErrorFunction
    If IsNull(Fecha) Then
        ValidarDate = 0
        Exit Function
    End If
    If IsMissing(Fecha) Then
        ValidarDate = 0
        Exit Function
    End If
    ValidarDate = Fecha
    Exit Function
ErrorFunction:
    MsgBox "Error: " & Err.Number & Chr(13) & "Descripcion: " & Err.Description, vbCritical, "ValidarDate"
End Function
' Determina la fecha de inicio de un mes en función de la fecha pasada
Public Function FechaInicioMes(Optional FechaReferencia As Variant) As Date
    'Dim clsFunciones As New FuncionesIOS
    Dim datFechaReferencia As Date
    If IsMissing(FechaReferencia) Then
        datFechaReferencia = Date
      Else
        datFechaReferencia = ValidarDate(FechaReferencia)
    End If
    FechaInicioMes = "01/" & Format(datFechaReferencia, "mm") & "/" & Format(datFechaReferencia, "yyyy")
End Function
' Determina la fecha de final de un mes en función de la fecha pasada
Public Function FechaFinalMes(Optional FechaReferencia As Variant) As Date
    'Dim clsFunciones As New FuncionesIOS
    Dim datFechaReferencia As Date
    Dim strDia As String
    If IsMissing(FechaReferencia) Then
        datFechaReferencia = Date
    End If
    datFechaReferencia = ValidarDate(FechaReferencia)
    Select Case Format(datFechaReferencia, "mm")
        Case "01"
            strDia = "31"
        Case "02"
            strDia = "28"
        Case "03"
            strDia = "31"
        Case "04"
            strDia = "30"
        Case "05"
            strDia = "31"
        Case "06"
            strDia = "30"
        Case "07"
            strDia = "31"
        Case "08"
            strDia = "31"
        Case "09"
            strDia = "30"
        Case "10"
            strDia = "31"
        Case "11"
            strDia = "30"
        Case "12"
            strDia = "31"
    End Select
    FechaFinalMes = ValidarDate(strDia & "/" & Format(datFechaReferencia, "mm") & "/" & Format(datFechaReferencia, "yyyy"))
End Function

mdlFuncionesFSO.bas


Option Compare Database
Option Explicit
'Función absPathDropbox
'Devuelve un string con la localización de la carpeta de dropbox
Public Function absPathDropbox() As String
    Dim DropboxHostFile As String
    Dim DropboxHostFileNumber As Long
    Dim Base64EncodedPath As String
    Dim TempXMLDocument As MSXML2.DOMDocument60
    Dim Base64XMLNode As MSXML2.IXMLDOMElement
    
    DropboxHostFile = Environ("LOCALAPPDATA") & "\Dropbox\host.db"
    DropboxHostFileNumber = FreeFile
    
    Open DropboxHostFile For Input As DropboxHostFileNumber
    Base64EncodedPath = Input$(LOF(DropboxHostFileNumber), DropboxHostFileNumber)
    Close DropboxHostFileNumber
    
    Set TempXMLDocument = New MSXML2.DOMDocument60
    Set Base64XMLNode = TempXMLDocument.createElement("b64")
    Base64XMLNode.DataType = "bin.base64"
    Base64XMLNode.Text = Split(Base64EncodedPath, vbLf)(1)
    
    absPathDropbox = StrConv(Base64XMLNode.nodeTypedValue, vbUnicode)
End Function

Sub Prueba()
    Debug.Print absPathDropbox
End Sub

clsAbsURL.cls


Option Compare Database
Option Explicit
' Variables públicas de la clase
Public URLID  As Long
Public URLtxt As String
Public Titulo As String
Public Description As String
Public FechaPublicacion As Date
Public Facebook As Boolean
Public FacebookDate As Date
Public Existe As Boolean
Public Contactos As Long
Public Visitas As Long
Public Property Get Dominio() As String
    Dominio = ExtraerDominio(URLtxt)
End Property
Public Property Get Documentada() As Boolean
    If ValidarString(Titulo) <> "" And ValidarDate(FechaPublicacion) > 0 And ValidarString(Description) <> "" Then Exit Function
End Property
Public Property Get URLhtml() As String
    URLhtml = "<a href='" & URLtxt & "'>" & Titulo & "</a>"
End Property
Public Property Get YouTubeHTML() As String
    Dim strYouTubeID() As String
    strYouTubeID = Split(URLtxt, "=")
    YouTubeHTML = "<iframe width='300' height='200' src='https://www.youtube.com/embed/" & strYouTubeID(1) & "' frameborder='0' allow='accelerometer; autoplay; encrypted-media; gyroscope; picture-in-picture' allowfullscreen></iframe>"
    Exit Property
End Property
Public Function Inicializar(DireccionURL As String) As Byte
    On Error GoTo ErrorSub
    URLtxt = ValidarString(DireccionURL)
    If URLtxt = "" Then
        Existe = False
        Exit Function
    End If
    If Right(URLtxt, 1) = "/" Then
        URLtxt = Left(URLtxt, Len(URLtxt) - 1)
    End If
    If Left(URLtxt, 1) = "#" Then
        URLtxt = Mid(URLtxt, 2)
    End If
InicializarFin:
    Exit Function
ErrorSub:
    MsgBox Err.Description, vbCritical, Application.Name
End Function
Public Function Scraping() As absURLDataType
    Dim objIE As Object
    Dim objmetaElements As Object
    Dim objMeta As Object
    Dim colMetas As Object
    Dim strContent() As String
    Dim blnReadySate4 As Boolean
    Dim blnNewIE As Boolean
    Dim intTime As Integer
    On Error GoTo ErrorSub
    blnNewIE = False
    blnReadySate4 = False
    Set objIE = CreateObject("InternetExplorer.Application")
    blnNewIE = True
    With objIE
        .Visible = False
        .Navigate URLtxt
        Do While .ReadyState < 3: DoEvents: Loop
'        intTime = 1
'        Do While .ReadyState < 3
'            Sleep 100
'            intTime = intTime + 1
'            DoEvents
'            If intTime > 10 Then ' 10 segundos máximo de carga
'                Exit Do
'            End If
'        Loop
        If blnReadySate4 = False Then
            If Titulo = "" Then
                If .LocationName <> .LocationURL Then
                    Titulo = .LocationName ' Título de la página
                End If
            End If
            If Right(URLtxt, 3) <> "pdf" Then
                Set colMetas = .Document.getElementsByTagName("meta")
                For Each objMeta In colMetas
                    'Debug.Print ValidarString(objMeta.Name, "NO NAME") & ":" & ":" & ValidarString(objMeta.content, "NO CONTENT") & objMeta.outerhtml
                    GoSub BuscarEnMetasFecha
                    GoSub BuscarEnMetasTitulo
                    GoSub BuscarEnMetasDescripcion
                Next
                ' Ampliar texto
                Description = Description & ". " & DescriptionInContent(objIE)
                Description = Replace(Description, "..", ".")
                Description = Description & "..."
                ' Description in Content
                If ValidarString(Description) = "" Then
                    Description = DescriptionInContent(objIE)
                End If
            End If
            ' Control de fecha por datepublished en Header
            If ValidarDate(FechaPublicacion) = 0 Then
                Set objMeta = .Document.getElementsByTagName("head").Item(0)
                FechaPublicacion = ValidarDate(objMeta.outerHtml)
            End If
            ' Control de fecha por datepublished en contenido
            If ValidarDate(FechaPublicacion) = 0 Then
                FechaPublicacion = ValidarDate(objIE.Document.body.innerHtml)
            End If
            If ValidarDate(FechaPublicacion) = 0 Then
                FechaPublicacion = ValidarDate(objIE.Document.body.outerHtml)
            End If
            blnReadySate4 = True
        End If
    End With
    If blnNewIE Then
        objIE.Quit
        Set objIE = Nothing
    End If
' Cerrar objetos
    Set objMeta = Nothing
    Set colMetas = Nothing
' Devolver datos
    absURLData.Titulo = Titulo
    absURLData.Description = Description
    absURLData.FechaPublicacion = FechaPublicacion
    Exit Function
BuscarEnMetasFecha:
    ' Busca la fecha en META
    If ValidarDate(FechaPublicacion) > 0 Then Return
    If ValidarString(objMeta.content) <> "" Then
        strContent = Split(objMeta.content, "T")
        If IsDate(strContent(0)) Then
            FechaPublicacion = strContent(0)
            Return
        End If
        If objMeta.Name = "DC.Date" Then
            FechaPublicacion = ValidarDate(objMeta.content)
            Return
        End If
    End If
    Return
BuscarEnMetasTitulo:
    If ValidarString(Titulo) <> "" Then Return
    If InStr(1, objMeta.outerHtml, "og:title") > 0 Then
        Titulo = objMeta.content
        Return
    End If
    If InStr(1, objMeta.outerHtml, "twitter:title") > 0 Then
        Titulo = objMeta.content
        Return
    End If
    Return
BuscarEnMetasDescripcion:
    If ValidarString(Description) <> "" Then Return
    If objMeta.Name = "Description" Or objMeta.Name = "twitter:description" Then
        Description = objMeta.content
        Return
    End If
    If InStr(1, objMeta.outerHtml, "twitter:description") > 0 Then
        Description = objMeta.content
        Return
    End If
    Return
ErrorSub:
    'MsgBox "Error en ready state: " & objIE.ReadyState & vbCrLf & Err.Description & vbCrLf & URLtxt
    gblAbsLog = "ERROR: " & Err.Number & "; " & Err.Description
    'Resume
    If blnNewIE Then
        objIE.Quit
        Set objIE = Nothing
    End If
End Function
Function DescriptionInContent(objIE As Object) As String
    Dim strTemp As String
    strTemp = DescriptionInContent2(objIE.Document.body.innerHtml)
    If ValidarString(strTemp) <> "" Then
        DescriptionInContent = strTemp
        Exit Function
    End If
    DescriptionInContent = DescriptionInContent2(objIE.Document.body.outerHtml)
End Function
Function DescriptionInContent2(DescriptionText As String) As String
    On Error GoTo ErrorSub
    Dim ind As Variant
    Dim indStr As Variant
    On Error GoTo ErrorSub
    Dim strText() As String
    Dim strFind As String
'<p class="selectionShareable">
    strFind = "<p class=""selectionShareable"">"
    strText = Split(DescriptionText, strFind)
    If UBound(strText) > 0 Then
        DescriptionInContent2 = Left(Trim(CleanString(strText(1))), 150)
        Exit Function
    End If
'<div class="body sociedad">
    strFind = "<div class=""body sociedad"">"
    strText = Split(DescriptionText, strFind)
    If UBound(strText) > 0 Then
        DescriptionInContent2 = Left(Trim(CleanString(strText(1))), 150)
        Exit Function
    End If
'<P class=entradilla>
    Debug.Print Len(DescriptionText)
    strFind = "<P class=entradilla>"
    strText = Split(DescriptionText, strFind)
    If UBound(strText) > 0 Then
        DescriptionInContent2 = Left(Trim(CleanString(strText(1))), 150)
        Exit Function
    End If
' Buscar primer párrafo con 150 letras
    strFind = "<p>"
    strText = Split(DescriptionText, strFind)
    For ind = 0 To UBound(strText)
        If Len(strText(ind)) > 150 And Left(strText(ind), 1) <> "<" Then
            DescriptionInContent2 = Left(Trim(CleanString(strText(ind))), 150)
            Exit Function
        End If
    Next
    MsgBox "No se ha podido establecer descripción, se abre formulario con el contenido para pasar a Notepad++ y verificar"
    'DoCmd.OpenForm "Formulario1"
    'Form_Formulario1.Texto1 = DescriptionText
    Exit Function
ErrorSub:
    Debug.Print Err.Description
End Function
Sub DocumentarMETAs(colMetas As Object)
    Dim objMeta As Object
    On Error GoTo ErrorSub
    For Each objMeta In colMetas
        If ValidarString(objMeta.content) <> "" Then
            ' Pendiente documentar
        End If
    Next
    Exit Sub
ErrorSub:
    Debug.Print Err.Description
End Sub
Function LinkURL(Optional Caracteres As Integer = 30) As String
    Dim strURL As String
    strURL = URLtxt
    strURL = Replace(strURL, "http://", "")
    strURL = Replace(strURL, "https://", "")
    strURL = Replace(strURL, "www.", "")
    If Len(strURL) > Caracteres Then strURL = Left(strURL, Caracteres) & "..."
    LinkURL = "<a href=""" & URLtxt & """>" & strURL & "</a>"
End Function

mdlFuncionesNet.bas


Option Compare Database
Option Explicit
Public Type absURLDataType
    Titulo As String
    Description As String
    FechaPublicacion As Date
End Type
Global absURLData As absURLDataType
Public Function absScraping(URLtxt As String)
    Dim objAbsURL As New clsAbsURL
    ' Inicializar valores
    absURLData.Titulo = ""
    absURLData.Description = ""
    absURLData.FechaPublicacion = 0
    ' Scrapear
    objAbsURL.Inicializar URLtxt
    objAbsURL.Scraping
    absURLData.Titulo = objAbsURL.Titulo
    absURLData.Description = objAbsURL.Description
    absURLData.FechaPublicacion = objAbsURL.FechaPublicacion
    Set objAbsURL = Nothing
End Function
' Extrae el dominio de la URL
' alexborras.com
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
Public Function ExtraerDominio(URL As String) As String
    On Error Resume Next
    ExtraerDominio = Replace(URL, "https://", "")
    ExtraerDominio = Replace(ExtraerDominio, "http://", "")
    ExtraerDominio = Replace(ExtraerDominio, "www.", "")
    Dim strDomain() As String
    strDomain = Split(ExtraerDominio, "/")
    ExtraerDominio = strDomain(0)
End Function
Public Function CleanString(ByVal Valor As Variant) As String
    If ValidarString(Valor) = "" Then Exit Function
    CleanString = ValidarString(Valor)
    CleanString = Replace(CleanString, Chr(10), "")
    CleanString = Replace(CleanString, Chr(13), "")
    CleanString = Replace(CleanString, Chr(9), "")
    CleanString = Replace(CleanString, "<b>", "")
    CleanString = Replace(CleanString, "</b>", "")
End Function

mdlVariables.bas


Option Compare Database
Option Explicit
' Variables globales
Global gblAbsLog As String

Sobre el autor

Alex Borrás

Informático, especializado en desarrollo Web con WordPress, Redes Sociales y posicionamiento en buscadores (SEO). Fan de la OOP y como afición jugador de Ajedrez. Geek por vocación & iphonero.

Deja un comentario

Uso de cookies

Este sitio web utiliza cookies para que usted tenga la mejor experiencia de usuario. Si continúa navegando está dando su consentimiento para la aceptación de las mencionadas cookies y la aceptación de nuestra política de cookies, pinche el enlace para mayor información.plugin cookies

Aviso de cookies

Salir de la versión móvil