Trucos y ejemplos de VBA para Microsoft Access
18119
page-template-default,page,page-id-18119,ajax_fade,page_not_loaded,,vertical_menu_enabled,side_area_uncovered_from_content,qode-theme-ver-11.0,qode-theme-bridge,wpb-js-composer js-comp-ver-5.0.1,vc_responsive

Trucos y ejemplos de VBA para Microsoft Access

En esta página encontrarán algunos ejemplo de trucos de VBA (Visual Basic for Applications) que puedes utilizar en aplicaciones desarrolladas con la base de datos Microsoft Access.

Contenidos de Microsoft Access VBA


Cómo obtener el nombre del ordenador o PC - Documentar elementos de Microsoft Access - DoEvents en bucles - Eliminar caracteres especiales de una cadena - Extensión de un archivo - Extraer el dominio de una URL - Extraer emails de un texto - Filtro y orden de registros de un formulario - ID de un nuevo registro - Ir al final de un campo - Leer el contenido de una URL con Visual Basic - Len: Contar caracteres en una cadena - Listar los campos de una tabla - Quitar el último carácter de una cadena - Rellenar un campo Hyperlink -

Cómo obtener el nombre del ordenador o PC

Cómo obtener el nombre del ordenador o PC. Permite saber el nombre del PC donde está funcionando la base de datos Access...
Public Function GetComputerName() As String
   Dim sResult As String * 255
   GetComputerNameA sResult, 255
   GetComputerName = Left$(sResult, InStr(sResult, Chr$(0)) - 1)
End Function


Documentar elementos de Microsoft Access

Documentar elementos de Microsoft Access. Los elementos de una base de datos Tablas, Formularios, etc. se denominan Documents y se agrupa en Containers. Si te interesa tener en una tabla a todos ellos para hacer tus propios menús, búsquedas o utilidades esta función te lo hace....
Buscar y documentar todos los elementos de Access
Sub ElementosMDBBuscar()
    Dim cnt As DAO.Container
    Dim doc As DAO.Document
    For Each cnt In CurrentDb.Containers
        For Each doc In cnt.Documents
            ElementosMDBDocumentar cnt, doc
        Next
    Next
    MsgBox "Documentación completada"
End Sub
Sub ElementosMDBDocumentar(cnt As DAO.Container, doc As DAO.Document)
    Dim strSQL As String
    Dim rstElementos As DAO.Recordset
    strSQL = "SELECT * FROM ElementosMDB WHERE Container='" & cnt.Name & "' AND Document='" & doc.Name & "'"
    Set rstElementos = CurrentDb.OpenRecordset(strSQL)
    If rstElementos.EOF Then
        rstElementos.AddNew
            rstElementos!Container = cnt.Name
            rstElementos!Document = doc.Name
        rstElementos.Update
    End If
    rstElementos.Close
End Sub


DoEvents en bucles

DoEvents en bucles. Mantener el control de un bucle con DoEvents...
En algunas ocasiones en un bucle Do While o For Next largo queremos hacer un display de algún campo para poder seguir la evolución del mismo sin embargo vemos como al poco rato la visualización se detiene y no responde hasta el final, con lo cual da la sensación de que el proceso se ha quedado colgado. Para solucionarlo y mantener la visualización de control en el bucle basta con añadir dentro del mismo la instrucción DoEvents.
 
Do While 
   ... 
   ... 
   DoEvents
Loop


Eliminar caracteres especiales de una cadena

Eliminar caracteres especiales de una cadena. Función que elimina todos los caracteres especiales de una cadena....
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


Extensión de un archivo

Extensión de un archivo. Como saber la extensión de un archivo....
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


Extraer el dominio de una URL

Extraer el dominio de una URL. ...
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://www.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.

Extraer emails de un texto

Extraer emails de un texto. Con esta función puedes extraer cuentas de correo electrónico de un texto o campo tipo string....
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


Filtro y orden de registros de un formulario

Filtro y orden de registros de un formulario. Cómo hacer un filtro por un campo y ordenar los registros del formulario...
Form_frmPersonasTareasLista.Filter = "[codigo estado]='PDTE'"
Form_frmPersonasTareasLista.FilterOn = True
Form_frmPersonasTareasLista.OrderBy = "FechaAlta DESC"
Form_frmPersonasTareasLista.OrderByOn = True


ID de un nuevo registro

ID de un nuevo registro. Cómo saber el ID de un autonumérico recién creado en una tabla...
Si creamos un nuevo registro en una tabla cuyo índice es un campo autonumérico es posible que necesitemos saber la ID del registro recién creado. Para ello podemos utilizar las siguientes instrucciones:
' Como obtener el último valor autonumérico de una clave
rst.Move 0, rst.LastModified
lngID = rst!ID


Ir al final de un campo

Ir al final de un campo. Como entrar en un TextBox de Access y que se ponga al final del campo sin seleccionar todo el texto....
Private Sub Observaciones_Click()
    Observaciones.SelLength = 0
    Observaciones.SelStart = Len(Observaciones)
End Sub


Leer el contenido de una URL con Visual Basic

Leer el contenido de una URL con Visual Basic. Podemos acceder al contenido de una dirección URL usando el objeto Document....
Podemos acceder al contenido de una dirección URL con las siguientes instrucciones. Pongo dos ejemplos, uno donde se obtiene el título de la página con una propiedad directa del objeto y otra donde se captura el contenido HTML completo del cuerpo de la URL usando el objeto Document.
Dim objIE As Object
Set objIE = CreateObject("InternetExplorer.Application")
With objIE
    .Visible = False
    .Navigate URLtxt
    Do While .ReadyState <> 4: DoEvents: Loop
    Debug.Print = .LocationName ' Título de la página
    Debug.Print = .Document.Body.InnerHtml ' Contenido HTML de la página
    .Quit
End With
Set objIE = Nothing


Len: Contar caracteres en una cadena

Len: Contar caracteres en una cadena. La función Len que permite contar las apariciones de una cadena dentro de otra....
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


Listar los campos de una tabla

Listar los campos de una tabla. Un bucle For Each para listar los campos de una tabla de Access...
Modo resumido
Sub CamposDeTabla()
    Dim dbs As DAO.Database
    Dim tdf As DAO.TableDef
    Dim fld As DAO.Field
    Set dbs = OpenDatabase("i:intex winbol2000E999car.mdb")
    Set tdf = dbs.TableDefs("CART0001")
    For Each fld In tdf.Fields
        Debug.Print fld.Name
    Next
    Set fld = Nothing
    Set tdf = Nothing
    dbs.Close
End Sub


Quitar el último carácter de una cadena

Quitar el último carácter de una cadena. Cómo eliminar el último carácter de una cadena. ...
dim Texto as string
Texto = "Hola1";
Texto = Left(Texto, Len(Texto) - 1)
La variable Texto valdrá "Hola"

Rellenar un campo Hyperlink

Rellenar un campo Hyperlink. Para rellenar un campo del tipo Hyperlink cuando hacemos un add o edit de un resitro se hace de la siguiente forma: rst!CampoHyperlink = "Texto#URL#"
1 Star2 Stars3 Stars4 Stars5 Stars (No Ratings Yet)
Cargando…

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

ACEPTAR
Aviso de cookies
A %d blogueros les gusta esto: