martes, 30 de octubre de 2018

Módulo de Visual Basic .NET para leer, grabar, editar y eliminar contenido en un fichero xml. Ejemplo completo de gestión de un fichero xml.

Imports System.IO
Imports System.Xml

Module ModCadenasConexionesXml
    'Gestionar fichero xml que almacena en este caso cadenas de conexion
    'Leer, Grabar, Editar y Eliminar valores de cadenas de conexion
    '
    'Ejemplo fichero:
    '<?xml version="1.0" encoding="utf-8"?>
    '<CadenasConexiones>
    ' <CadenaConexion ID = "1" >
    '    <Valor>Server=.\SQLEXPRESS;Database=PRUEBAS;Trusted_Connection=True;</Valor>
    ' </CadenaConexion>
    ' <CadenaConexion ID = "2" >
    '    <Valor>Server=.\SQLEXPRESS;Database=PRUEBAS2;Trusted_Connection=True;</Valor>
    ' </CadenaConexion>
    '</CadenasConexiones>

    Const PATHFICHERO = ".\CadenasConexion.xml"
    Const NOMBRERAIZ = "CadenasConexiones"
    Const NOMBRENODO = "CadenaConexion"
    Const NOMBREATRIBUTONODO1 = "ID"
    Const NOMBREVALORNODO1 = "Valor"

    Public Class clsCadenaConexion
        Public _ID As String
        Public _Valor As String

        Public Sub New()
            Me._ID = ""
            Me._Valor = ""
        End Sub

        Public Sub New(DescConexion As String, CadConexion As String)
            Me._ID = DescConexion
            Me._Valor = CadConexion
        End Sub

        Public Function GrabarCadenaConexionXml() As Boolean
            Try
                If Not File.Exists(PATHFICHERO) Then
                    'Crear XmlWriterSttings.
                    Dim settings As XmlWriterSettings = New XmlWriterSettings()
                    settings.Indent = True

                    'Crear XmlWriter
                    Dim writer As XmlWriter
                    writer = XmlWriter.Create(PATHFICHERO, settings)

                    'Inicio escritura documento xml
                    writer.WriteStartDocument()
                    writer.WriteStartElement(NOMBRERAIZ) ' Raíz.

                    'Grabar nodo
                    writer.WriteStartElement(NOMBRENODO)
                    writer.WriteAttributeString(NOMBREATRIBUTONODO1, Me._ID)
                    writer.WriteElementString(NOMBREVALORNODO1, Me._Valor)
                    'Fin grabar nodo
                    writer.WriteEndElement()

                    'Fin escritura documento xml
                    writer.WriteEndElement()
                    writer.Close()
                Else
                    ActualizarGrabarNodo()
                End If

                Return True

            Catch ex As Exception
                Debug.Print(ex.Message)
                Return False
            End Try
        End Function

        Private Function ActualizarGrabarNodo() As Boolean
            Dim resb As Boolean = False

            Try
                'Cargar fichero xml
                Dim xd As New XmlDocument
                xd.Load(PATHFICHERO)

                'Buscar NODO por el atributo ID
                For Each e As XmlElement In xd.GetElementsByTagName(NOMBRENODO)
                    resb = (Me._ID = e.GetAttribute(NOMBREATRIBUTONODO1))
                    If resb Then
                        'ID encontrado. Actualizar valor
                        e.Item(NOMBREVALORNODO1).InnerText = Me._Valor
                        xd.Save(PATHFICHERO)
                        Exit For
                    End If
                Next e

                If Not resb Then
                    'ID no encontrado. Grabar nuevo valor

                    'Creamos nuevo nodo con sus atributos y elementos
                    Dim nCadCon As XmlElement = xd.CreateElement(NOMBRENODO)
                    nCadCon.SetAttribute(NOMBREATRIBUTONODO1, Me._ID)
                    Dim nValor As XmlElement = xd.CreateElement(NOMBREVALORNODO1)
                    nValor.InnerText = Me._Valor
                    nCadCon.AppendChild(nValor)

                    'Añadir nuevo nodo al xml y grabar los cambios al fichero
                    xd.DocumentElement.AppendChild(nCadCon)
                    xd.Save(PATHFICHERO)

                    resb = True
                End If

                Return resb
            Catch ex As Exception
                Debug.Print(ex.Message)
                Return False
            End Try

        End Function

        Public Function EliminarCadenaConexionXml() As Boolean
            Dim resb As Boolean = False

            Try
                'Cargar fichero xml
                Dim xd As New XmlDocument
                xd.Load(PATHFICHERO)

                'Buscar NODO por ID
                For Each e As XmlElement In xd.GetElementsByTagName(NOMBRENODO)
                    resb = (Me._ID = e.GetAttribute(NOMBREATRIBUTONODO1))
                    If resb Then
                        'ID encontrado. Eliminar NODO
                        'obtenemos el nodo del elemento
                        Dim xn As XmlNode = e
                        'obtenemos la raiz e indicamos borrar el nodo
                        xn.ParentNode.RemoveChild(xn)
                        'grabamos los cambios en el fichero xml
                        xd.Save(PATHFICHERO)

                        Exit For
                    End If
                Next e

                Return resb
            Catch ex As Exception
                Debug.Print(ex.Message)
                Return False
            End Try

        End Function

        Public Function LeerCadenasConexionesXml() As DataSet
            Try
                Dim ds As New DataSet
                ds.Tables().Add(NOMBRERAIZ)
                ds.Tables(NOMBRERAIZ).Columns.Add(NOMBREATRIBUTONODO1)
                ds.Tables(NOMBRERAIZ).Columns.Add(NOMBREVALORNODO1)

                Dim xd As New XmlDocument
                xd.Load(PATHFICHERO)

                For Each e As XmlElement In xd.GetElementsByTagName(NOMBRENODO)
                    Dim dr As DataRow
                    dr = ds.Tables(NOMBRERAIZ).Rows.Add
                    dr(NOMBREATRIBUTONODO1) = e.GetAttribute(NOMBREATRIBUTONODO1)
                    dr(NOMBREVALORNODO1) = e.Item(NOMBREVALORNODO1).InnerText
                    dr.AcceptChanges()
                Next e

                Return ds

            Catch ex As Exception
                Debug.Print(ex.Message)
                Return Nothing
            End Try
        End Function

    End Class

End Module

lunes, 3 de septiembre de 2018

VBA Access. Función para visualizar o imprimir informes que se encuentran en un archivo externo. Consigue evitar error si el informe ya está abierto.

#If Win64 = 1 Then
    Private Declare PtrSafe Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As LongPtr) 'For 64 Bit Systems
#Else
    Private Declare Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As Long) 'For 32 Bit Systems
#End If

Public Function ImprimirReport(ByVal sPathFileReports As String, ByVal Report As String, Optional ByVal OpenArgs As String = "", Optional VistaPrevia As Boolean = False) As Boolean
On Error GoTo Error:
    Dim bReintento As Boolean
    bReintento = False
       
    Dim objAccess As Access.Application
    Set objAccess = GetObject(sPathFileReports)
   
    If VistaPrevia Then
        objAccess.Visible = True
    Else
        objAccess.Visible = False
    End If
   
Retry:
    objAccess.DoCmd.Close acReport, Report
    objAccess.DoCmd.OpenReport Report, IIf(VistaPrevia, acViewPreview, acViewNormal), , , , OpenArgs
   
    If Not VistaPrevia Then
        Sleep 10
       
        objAccess.DoCmd.Close acReport, Report
        objAccess.Application.Quit
        Set objAccess = Nothing
    End If
   
    ImprimirReport = True
   
Exit Function
    Resume
Error:
    If Not bReintento And Err.Number = 2455 Then
        'Si el archivo de reports ya se encuentra abierto,
        'no es posible cambiar la propiedad Visible y lanza el error 2455
        'continuar desde etiqueta Retry.
        'USAMOS EL FLAG bReintento PARA REINTENTAR SOLO 1 VEZ.
        bReintento = True
        GoTo Retry
    End If

    If Not objAccess Is Nothing Then objAccess.Application.Quit
    Set objAccess = Nothing
    ImprimirReport = False
    MsgBox Err.Number & ": " & Err.Description
End Function

miércoles, 23 de mayo de 2018

VBA Access. Módulo para substituir SendKeys usando el API de Windows para evitar el conocido bug de SendKeys con el NumLock.

Option Compare Database
Option Explicit

'Ej tecla ESCAPE: EnviarTeclas VK_ESCAPE
'Ej tecla ESCAPE 2 veces: EnviarTeclas VK_ESCAPE , , 2
'Ej teclas CTRL+C: EnviarTeclas VK_CONTROL,vbKeyC
'Ej teclas ALT+SPACE: EnviarTeclas VK_MENU,VK_SPACE
'Ej teclas ALT+G: EnviarTeclas VK_MENU, vbKeyG
'Ej teclas SHIFT+DEL: EnviarTeclas VK_SHIFT, VK_DELETE

Const KEYEVENTF_KEYUP = &H2
Const KEYEVENTF_EXTENDEDKEY = &H1

'-----------------
'Virtual Key Codes
'-----------------

'VK_LBUTTON The left mouse button
'VK_RBUTTON The right mouse button
'VK_CANCEL The Cancel virtual key, used for control-break processing
'VK_MBUTTON The middle mouse button
'VK_BACK Backspace
'VK_TAB Tab
'VK_CLEAR 5 (keypad without Num Lock)
'VK_RETURN Enter
'VK_SHIFT Shift (either one)
'VK_CONTROL Ctrl (either one)
'VK_MENU Alt (either one)
'VK_PAUSE Pause
'VK_CAPITAL Caps Lock
'VK_ESCAPE Esc
'VK_SPACE Spacebar
'VK_PRIOR Page Up
'VK_NEXT Page Down
'VK_END End
'VK_HOME Home
'VK_LEFT Left Arrow
'VK_UP Up Arrow
'VK_RIGHT Right Arrow
'VK_DOWN Down Arrow
'VK_SELECT Select
'VK_PRINT Print (only used by Nokia keyboards)
'VK_EXECUTE Execute (Not used)
'VK_SNAPSHOT Print Screen
'VK_INSERT Insert
'VK_DELETE Delete
'VK_HELP Help

'Constant Definitions

Public Const VK_LBUTTON = &H1
Public Const VK_RBUTTON = &H2
Public Const VK_CANCEL = &H3
Public Const VK_MBUTTON = &H4
Public Const VK_BACK = &H8
Public Const VK_TAB = &H9
Public Const VK_CLEAR = &HC
Public Const VK_RETURN = &HD
Public Const VK_SHIFT = &H10
Public Const VK_CONTROL = &H11
Public Const VK_MENU = &H12
Public Const VK_PAUSE = &H13
Public Const VK_CAPITAL = &H14
Public Const VK_ESCAPE = &H1B
Public Const VK_SPACE = &H20
Public Const VK_PRIOR = &H21
Public Const VK_NEXT = &H22
Public Const VK_END = &H23
Public Const VK_HOME = &H24
Public Const VK_LEFT = &H25
Public Const VK_UP = &H26
Public Const VK_RIGHT = &H27
Public Const VK_DOWN = &H28
Public Const VK_SELECT = &H29
Public Const VK_PRINT = &H2A
Public Const VK_EXECUTE = &H2B
Public Const VK_SNAPSHOT = &H2C
Public Const VK_INSERT = &H2D
Public Const VK_DELETE = &H2E
Public Const VK_HELP = &H2F

#If Win64 = 1 Then
    Private Declare PtrSafe Sub keybd_event Lib "user32" (ByVal bVk As Byte, ByVal bScan As Byte, ByVal dwFlags As Long, ByVal dwExtraInfo As Long)
#Else
    Private Declare Sub keybd_event Lib "user32" (ByVal bVk As Byte, ByVal bScan As Byte, ByVal dwFlags As Long, ByVal dwExtraInfo As Long)
#End If

#If Win64 = 1 Then
    Private Declare PtrSafe Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As LongPtr) 'For 64 Bit Systems
#Else
    Private Declare Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As Long) 'For 32 Bit Systems
#End If

Public Function EnviarTeclas(Key1 As Long, Optional Key2 As Long = 0, Optional NumRepeticiones = 1) As Boolean
On Error GoTo error
    Dim i As Integer
 
    For i = 1 To NumRepeticiones
        Call keybd_event(Key1, 0, 0, 0)
        If Key2 <> 0 Then Call keybd_event(Key2, 0, 0, 0)
     
        Sleep 10
        DoEvents
     
        Call keybd_event(Key1, 0, KEYEVENTF_KEYUP, 0)
        If Key2 <> 0 Then Call keybd_event(Key2, 0, KEYEVENTF_KEYUP, 0)
     
        Sleep 10
        DoEvents
    Next i
 
    EnviarTeclas = True
 
Exit Function
error:
    Debug.Print Err.Number & ": " & Err.Description
    EnviarTeclas = False
End Function

martes, 10 de abril de 2018

VBA Access. Módulo para Leer valores de ficheros de configuración.

'Ejemplos der uso:
'Contenido FicheroTxt1:
'CLAVE1=VALOR1;CLAVE2=VALOR2
'ObtenerValorClave(ContenidoFicheroTxt,"CLAVE1","=",";") => VALOR1

'Contenido FicheroTxt2:
'CLAVE1=VALOR1
'CLAVE2=VALOR2
' ObtenerValorClave(ContenidoFicheroTxt,"CLAVE2","=",vbCrLf) => VALOR2

Public Function ObtenerValorClave(ByVal sValores As String, ByVal sClave As String, ByVal sCarIniClave, ByVal sCarFinClave) As String
On Error GoTo error
    Dim PosIni As Integer
    Dim PosFin As Integer
    Dim sValor As String

    PosIni = GetPosValue(UCase(sValores), UCase(sClave), sCarIniClave)
    PosFin = GetPosValue(UCase(sValores), UCase(sClave), sCarFinClave)
    sValor = GetValue(sValores, PosIni, PosFin)
    ObtenerValorClave = sValor

Exit Function
error:
    ObtenerValorClave = ""
    Debug.Print Err.Number & ": " & Err.Description
End Function

Private Function GetPosValue(ByVal sCadena As String, ByVal sClave As String, ByVal sCarFin) As Integer
On Error GoTo error
    GetPosValue = InStr(1, UCase(sCadena), sClave, vbTextCompare)
    GetPosValue = InStr(GetPosValue, UCase(sCadena), sCarFin, vbTextCompare)

Exit Function
error:
    GetPosValue = 0
End Function

Private Function GetValue(ByVal sCadena As String, ByVal PosIni As Integer, ByVal PosFin As Integer) As String
On Error GoTo error
    If PosFin = 0 And PosIni > 0 Then
        PosFin = Len(sCadena) - PosIni
        GetValue = Trim(Mid(sCadena, PosIni + 1, PosIni - PosFin - 1))
    ElseIf PosIni > 0 Then
        GetValue = Trim(Mid(sCadena, PosIni + 1, PosFin - PosIni - 1))
    Else
        GetValue = ""
    End If
Exit Function
error:
    GetValue = ""
    Debug.Print Err.Number & ": " & Err.Description
End Function

domingo, 25 de marzo de 2018

VBA Access. Obtener el número de posiciones decimales de un número.

Public Function NumeroDecimales(ByVal dNumber As Double) As Long
On Error GoTo error
    Dim Value As String
    Dim PosSymb As String
    Dim DecSymb As String
    Dim NumDecs As Long
   
    DecSymb = Mid(1 / 2, 2, 1)
   
    Value = CStr(dNumber)
    PosSymb = InStr(Value, DecSymb)
    If CLng(PosSymb) > 0 Then
        NumDecs = Len(Value) - CLng(PosSymb)
    Else
        NumDecs = 0
    End If
   
    NumeroDecimales = NumDecs
   
Exit Function
error:
    NumeroDecimales = 0
    MsgBox Err.number & ": " & Err.Description
End Function

miércoles, 7 de marzo de 2018

VBA Access. Posicionar cursor en un registro concreto de un formulario con datos DAO.Recordset

Private Sub GotoRecord(ByVal strCriteria As String)
'Ejemplo stCriteria: [PKey] = 'ABCD'
On Error GoTo error
    Dim rs As DAO.Recordset
    Set rs = Me.SubForm.Form.RecordsetClone
    rs.FindFirst strCriteria
    If rs.NoMatch Then
        'Ningún valor encontrado
    Else
        Me.Subform.Form.Bookmark = rs.Bookmark
    End If
    rs.Close
    Set rs = Nothing

Exit Sub
error:
    MsgBox Err.Description
End Sub

VBA Access. Posicionar cursor en un registro concreto de un formulario con datos ADODB.Recordset

Private Sub GotoRecord(ByVal strCriteria As String)
'Ejemplo stCriteria: [PKey] = 'ABCD'
On Error GoTo error
    Dim rs As ADODB.Recordset
    Set rs = Me.SubForm.Form.RecordsetClone
    rs.Filter = strCriteria
    If Not rs.EOF Then
        Me.SubForm.Form.Bookmark = rs.Bookmark
    End If
    rs.Close
    Set rs = Nothing

Exit Sub
error:
    MsgBox Err.Description
End Sub

martes, 27 de febrero de 2018

VBA Access. Función NullIf.

'En Access no existe tal función.
'Nos puede ser útil en ciertas ocasiones combinándola con la función Nz.
'Ejemplo de uso: Nz(Nullif(Valor,""),"prueba")

Public Function NullIf(value As Variant, NullValue As Variant) As Variant
    If value = NullValue Then
        NullIf = Null
    Else
        NullIf = value
    End If
End Function

VBA Access. Redondeo de números decimales con el método medio redondeo. Alternativa a la función Round (bankers round)

 Private Function Redondeo(ByVal Numero As Variant, ByVal Decimales As Integer) As Double     'Aplica método medio redondeo (half round ...