Mis funciones en VBA Access

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