Código VBA para fusionar MS Access con MySQL

El código que viene a continuación puede servir de ejemplo para pasar datos de una base de datos MS Access a una MySQL utilizando el driver ODBC de MySQL. La idea seria crear una tercera BD Access con una tabla linkada a la BD Access original y otra tabla linkada con el servidor MySQL usando ODBC. Esto demuestra que es posible realizar una migración de MS Access a MySQL, la cual podria ir acompañada del fantástico front-end MySQL Control Center.

El código esta escrito en VBA y se debe ejecutar desde MS Access. Hay muchas zonas cortadas ya que son repetitivas, estan señaladas con “[…]”:

Option Compare Database
'Option Explicit

' ExecuteQuery: Realitza una modificació a la BD
' Provar amb:
'  ExecuteQuery "INSERT INTO CamaraEnvasadoPreenvasado VALUES ('test', 'borrar')"
Sub ExecuteQuery(strSQL As String)
   Dim cnn          As ADODB.Connection
   Dim lngAffected  As Long
   
   ' Open the connection.
   Set cnn = CurrentProject.Connection

   ' Execute the query.
   cnn.Execute CommandText:=strSQL, _
               RecordsAffected:=lngAffected, _
               Options:=adExecuteNoRecords

   'Debug.Print "Records Affected = " & lngAffected
   
   ' Close connection and destroy object variables.
   cnn.Close
   Set cnn = Nothing
End Sub

Sub Fusionar()
    Dim cnnDB As ADODB.Connection
    Dim recordSt As New ADODB.Recordset
    Dim recordSt2 As New ADODB.Recordset
    Dim strSQL As String
    Dim idSuscriptor As String
    Dim fecha1 As Date
    Dim fecha2 As Date
    Dim i As Integer
    Dim sql As String
    ' Campos
    Dim TipoRelacion As Variant
    Dim Sector1 As Variant
    Dim Sector2 As Variant
     [...]

    ' Connectar a la BD actual:
    Set cnnDB = CurrentProject.Connection

    ' Seleccionamos todas las empresas de la BD local (access)
    strSQL = "SELECT * FROM Empresa"
    With recordSt
        Set .ActiveConnection = cnnDB
        .CursorType = adOpenKeyset
        .CursorLocation = adUseClient
        .LockType = adLockOptimistic
        .Open strSQL
    End With
    
    i = 0
    If Not recordSt.EOF Then
        recordSt.MoveFirst
    End If
    ' Por cada empresa...
    Do While Not recordSt.EOF
        idSuscriptor = recordSt.Fields("Numero de subscriptor").Value
        fecha1 = recordSt.Fields("Fecha").Value
        
        ' Buscar el registro equivalente en la BD externa (MySQL)
        strSQL = "SELECT * FROM empresa1 WHERE NumSuscriptor = " & idSuscriptor
        With recordSt2
            Set .ActiveConnection = cnnDB
            .CursorType = adOpenKeyset
            .CursorLocation = adUseClient
            .LockType = adLockOptimistic
            .Open strSQL
        End With
        
        If Not recordSt2.EOF Then
        'If 1 = 0 Then
            recordSt2.MoveFirst
            ' El registro existe en ambas BD
            
            fecha2 = recordSt2.Fields("FechaActualizacion").Value
            'Debug.Print DateDiff("s", fecha1, fecha2)
            'Debug.Print DateDiff("s", fecha1, Date)
            'Debug.Print DateDiff("s", Date, fecha2)
            If (DateDiff("s", fecha1, fecha2) > 0) Then
            'If (1 = 1) Then
                ' El registro más actual se encuentra en la BD externa (MySQL)
                
                ' El tratamiento de los campos para actualizar la BD local es diferente
                ' ya que esta definida para que no soporte cadenas de longitud 0 como ''
                TipoRelacion = EscapeForAccess(recordSt2.Fields("TipoRelacion").Value)
                Sector1 = EscapeForAccess(recordSt2.Fields("Sector1").Value)
                Sector2 = EscapeForAccess(recordSt2.Fields("Sector2").Value)
                Sector3 = EscapeForAccess(recordSt2.Fields("Sector3").Value)
                [...]

                
                If (recordSt2.Fields("SuscriptorOnline").Value = 1) Then
                    SuscriptorOnline = "True"
                Else
                    SuscriptorOnline = "False"
                End If
                
                If (recordSt2.Fields("EColaboradora").Value = 1) Then
                    EColaboradora = "True"
                Else
                    EColaboradora = "False"
                End If
                
                'FechaActualizacion = Format(recordSt2.Fields("FechaActualizacion").Value, "yyyymmddhhnnss")
                FechaActualizacion = Format(recordSt2.Fields("FechaActualizacion").Value, "yyyy-mm-dd hh:nn:ss")
                FechaActualizacion = "'" & recordSt2.Fields("FechaActualizacion").Value & "'"
                
                MercadoDestino = EscapeForAccess(recordSt2.Fields("MercadoDestino").Value)
                
                If (recordSt2.Fields("Visible").Value = 1) Then
                    Visible = "True"
                Else
                    Visible = "False"
                End If
                
                'MaxProductes = recordSt2.Fields("MaxProductes").Value
                
                ' Actualizamos BD local (access)
                sql = "UPDATE Empresa SET Tipo_de_Relacion = " & TipoRelacion & ", Sector1 = " & Sector1 & ", Sector2 = " & Sector2 & ", Sector3 = " & Sector3 & [...] WHERE [Numero de Subscriptor] = " & idSuscriptor

                Debug.Print sql
                'MsgBox sql
                ExecuteQuery sql
            ElseIf (DateDiff("s", fecha1, fecha2) < 0) Then
            'ElseIf (1 = 1) Then
                ' El registro más actual se encuentra en la BD local (access)
                TipoRelacion = EscapeForMySQL(recordSt.Fields("Tipo_de_Relacion").Value)
                Sector1 = EscapeForMySQL(recordSt.Fields("Sector1").Value)
                Sector2 = EscapeForMySQL(recordSt.Fields("Sector2").Value)
                Sector3 = EscapeForMySQL(recordSt.Fields("Sector3").Value)
                [...]

                If (recordSt.Fields("Subscriptor_on_line").Value) Then
                    SuscriptorOnline = 1
                Else
                    SuscriptorOnline = 0
                End If
                If (recordSt.Fields("Empresa_colaborador").Value) Then
                    EColaboradora = 1
                Else
                    EColaboradora = 0
                End If
                FechaActualizacion = Format(recordSt.Fields("Fecha").Value, "yyyy-mm-dd hh:nn:ss")
                MercadoDestino = EscapeForMySQL(recordSt.Fields("Mercados_de_destino").Value)
                Visible = EscapeForMySQL(recordSt.Fields("Visible").Value)
                
                ' Actualizamos BD externa (MySQL)
                sql = "UPDATE empresa1 SET TipoRelacion = '" & TipoRelacion & "', Sector1 = '" & Sector1 & "', Sector2 = '" & Sector2 & "', Sector3 = '" & Sector3 & [...] "' WHERE NumSuscriptor = " & idSuscriptor
                Debug.Print sql
                'MsgBox sql
                ExecuteQuery sql
            Else
                Debug.Print "Sin cambios (NumSuscriptor " & idSuscriptor & ")"
            End If
        Else
            ' Si no existe el registro en la BD externa (MySQL), se trata
            ' de uno nuevo y por tanto se ha de realizar la insercción
            NumSuscriptor = EscapeForMySQL(recordSt.Fields("Numero de Subscriptor").Value)
            TipoRelacion = EscapeForMySQL(recordSt.Fields("Tipo_de_Relacion").Value)
            Sector1 = EscapeForMySQL(recordSt.Fields("Sector1").Value)
            Sector2 = EscapeForMySQL(recordSt.Fields("Sector2").Value)
            Sector3 = EscapeForMySQL(recordSt.Fields("Sector3").Value)
            [...]
            If (IsNull(Provincia) Or (Provincia = "")) Then
                Provincia = 0
            Else
                Provincia = recordSt.Fields("Provincia").Value
            End If
            [...]

            FechaActualizacion = Format(recordSt.Fields("Fecha").Value, "yyyy-mm-dd hh:nn:ss")
            MercadoDestino = EscapeForMySQL(recordSt.Fields("Mercados_de_destino").Value)
            'Visible = EscapeForMySQL(recordSt.Fields("Visible").Value)
            If (recordSt.Fields("Visible").Value = 1) Then
                Visible = 1
            Else
                Visible = 0
            End If
                        
            sql = "INSERT INTO empresa1 (NumSuscriptor, TipoRelacion, Sector1, Sector2, Sector3, [...]) "
            sql = sql & " VALUES ('" & NumSuscriptor & "', '" & TipoRelacion & "', '" & Sector1 & "', '" & Sector2 & "', '" & Sector3 & "', '" &[...]& "')"
            Debug.Print sql
            'MsgBox sql
            ExecuteQuery sql
            
            ' Para poder especificar el valor del timestamp debo hacerlo:
            ' (no puedo hacerlo en el insert, parece un bug de access o del ODBC 2.50)
            
            ' Esto no funciona:
            ' (un bug de access o del ODBC 2.50 ?)
            'sql = "UPDATE empresa1 SET FechaActualizacion = '" & FechaActualizacion & "' WHERE NumSuscriptor = " & NumSuscriptor
            'Debug.Print sql
            'ExecuteQuery sql
            
            ' Funciona:
            sql = "UPDATE empresa1 SET TipoRelacion = '" & TipoRelacion & "', Sector1 = '" & Sector1 & "', Sector2 = '" & Sector2 & "', Sector3 = '" & Sector3 & [...] & "' WHERE NumSuscriptor = " & idSuscriptor
            Debug.Print "Actualizar timestamp del ultimo insert:"
            Debug.Print sql
            'MsgBox sql
            ExecuteQuery sql
            
        End If
        
        recordSt2.Close
        recordSt.MoveNext
    Loop
    
   Debug.Print "End"
   
   ' Close Connection object and destroy object variable.
   cnnDB.Close
   Set cnnDB = Nothing
End Sub

Public Function Escape(ByVal strString As String) As String
' ************* Declare our Regex Array ****************
Dim FindTerm(1)
FindTerm(0) = "'"
'FindTerm(1) = """"

' *************************************************
For i = 0 To 0
    ' Purpose:      To replace all occurrences of one string in another
    Dim intPos As Integer, intLP As Integer, intLen As Integer, strTemp As String
    ' find each search string and replace with target
    intLen = Len(FindTerm(i))
    intPos = InStr(strString, FindTerm(i))
    While intPos <> 0
        strTemp = strTemp & left$(strString, intPos - 1)
        'strTemp = strTemp & "" & FindTerm(i)
        strTemp = strTemp & FindTerm(i) & FindTerm(i)
        strString = right$(strString, Len(strString) - intPos - intLen + 1)
        intPos = InStr(strString, FindTerm(i))
    Wend
    ' append remainder upon failure of last InStr search
Next
strTemp = strTemp & strString
Escape = strTemp
End Function

Public Function EscapeForAccess(strString) As Variant
    If IsNull(strString) Then
        EscapeForAccess = "null"
    Else
        EscapeForAccess = "'" & Escape(strString) & "'"
    End If
End Function

Public Function EscapeForMySQL(strString) As Variant
    If IsNull(strString) Then
        EscapeForMySQL = Null
    Else
        EscapeForMySQL = Escape(strString)
    End If
End Function

Leave a Reply

Your email address will not be published. Required fields are marked *