Инструменты разработчика Access. Библиотека программ, надстроек и справочного материала

Public Const name_db As String = "bd.db"
Public name_shema As String
Public Const Server_name As String = "192.168.1.xxx"
Public Const Server_port As String = "3306"
Public Const User_ID As String = "xxxx"
Public Const Password As String = "xxxx"
Public Const pass_db As String = "xxxx"
 
Function IMPORTO()
    Dim aConn As Object, db As Object, td As TableDef
    Dim path_db As String, tables_skip As String
    Dim countrowsinserted As Long
    ' *************************** БД (в текущей папке) для экспорта на сервер
    path_db = CurrentProject.Path & "" & name_db: If Dir(path_db) <> name_db Then Exit Function
    ' *************************** Подключение к БД для экспорта на сервер
    Set db = getConnDAO(path_db, pass_db)
    ' *************************** Подключение к серверу
    name_shema = Split(name_db, ".")(0)
    Set aConn = Connection(True): If aConn.state = 0 Then Exit Function
    ' *************************** Создание схемы на сервере
    aConn.Execute "DROP DATABASE IF EXISTS " & name_shema
    aConn.Execute "CREATE SCHEMA " & name_shema
    ' *************************** Подключение к серверу
    Set aConn = Connection(): If aConn.state = 0 Then Exit Function
    ' *************************** Импорт таблиц и данных из текущей БД на сервер
    Debug.Print Now
    For Each td In db.TableDefs
        If td.Attributes = 0 And InStr(1, tables_skip, td.Name) = 0 Then
            Call DELTABLE(aConn, td) ' удаление таблицы с сервера (необязательно, если ранее используется DROP DATABASE)
            Call CREATETABLE(aConn, td) ' создание таблицы на сервере
            ' при необходимости - предварительно удалить некорректные символы из указанной таблицы
            countrowsinserted = GenDataInsertStatements(aConn, db, td) ' запись данных в таблицу на сервер
        End If
    Next
    ' ***************************
    Set aConn = Nothing: Set db = Nothing
End Function
 
' ***************************************** Удаление таблицы
Function DELTABLE(ByRef conn, ByRef td)
    Dim result As String
    result = "DROP TABLE IF EXISTS `" & td.Name & "`;"
    conn.Execute result
End Function
 
' ***************************************** Создание таблицы
Function CREATETABLE(ByRef aConn, ByRef td As TableDef)
    Dim result As String
    result = CreateTableStatement(td)
    aConn.Execute result
End Function

' ***************************************** Соединение с БД (DAO)
Function getConnDAO(path_db As String, PWD As String) As Object
    Set getConnDAO = CreateObject("DAO.DBEngine.120").OpenDatabase(path_db, False, False, "MS Access;PWD=" & PWD)
End Function
 
' ***************************************** Соединение с сервером
Function Connection(Optional noshema As Boolean) As Object
    On Error GoTo er_
    Set Connection = CreateObject("ADODB.Connection")
    Connection.Open getStrConnect(noshema)
    Exit Function
er_:
    MsgBox "AttachDSNLessTable encountered an unexpected error: " & vbCrLf & Err.Number & " - " & Err.Description
End Function
 
' *****************************************
Function getStrConnect(noshema As Boolean) As String
    getStrConnect = "DRIVER={MySQL ODBC 9.0 Unicode Driver}" _
        & ";Connect Timeout=10" _
        & ";SERVER=" & Server_name _
        & ";PORT=" & Server_port _
        & IIf(noshema, "", ";DATABASE=" & name_shema) _
        & ";UID=" & User_ID _
        & ";PWD=" & Password _
        & ";OPTION=16427"
End Function

' ***************************************** Свойства поля
Function getProperties(ByRef fld As field2, propname As String) As String
    On Error Resume Next
    getProperties = fld.Properties(propname)
    If Err.Number <> 0 Then
        Debug.Print fld.Name; " "; Err.Description
    End If
End Function
 
' ***************************************** SQL создания полей
Function CreateFieldStatement(ByRef td As TableDef, ByRef fld As field2) As String
    result = "  `" & fld.Name & "`"
    Select Case fld.Type
        Case dbDate
            prop = getProperties(fld, "format")
            Select Case prop
                Case "general date"
                    result = result & " DATETIME(0)"
                Case "short date"
                    result = result & " DATE"
                Case "short time"
                    result = result & " TIME"
                Case Else
                    result = result & " DATETIME(0)"
            End Select
        Case dbTime
            Stop
        Case dbTimeStamp
            Stop
        Case dbMemo ' Memo/Long Text, Hyperlinks
            result = result & " LONGTEXT"
        Case dbByte
            result = result & " TINYINT(3) UNSIGNED"
        Case dbInteger
            result = result & " INTEGER"
        Case dbLong
            result = result & " INTEGER"
        Case dbNumeric, dbDecimal
            result = result & " DECIMAL(" & ADOXCol.Precision & ", " & ADOXCol.NumericScale & ")"
        Case dbSingle, dbFloat
            result = result & " FLOAT"
        Case dbDouble
            result = result & " DOUBLE"
        Case dbGUID
            result = result & " GUID"
        Case dbBoolean
            result = result & " TINYINT"
        Case dbCurrency
            result = result & " DECIMAL(19,4)"
        Case dbText
            result = result & " VARCHAR(" & fld.Size & ")"
        Case Else
            result = result & " ????"
            Stop
    End Select
 
    If fld.DefaultValue <> "" Then
        If fld.Type = dbBoolean Then
            result = result & " DEFAULT " & IIf(fld.DefaultValue = "NO", 0, 1)
        Else
            result = result & " DEFAULT " & fld.DefaultValue
        End If
    End If
    If (fld.Attributes And dbAutoIncrField) Then result = result & " AUTO_INCREMENT"
    If fld.Required Then result = result & " NOT NULL"
    CreateFieldStatement = result & "," & vbCrLf
End Function
 
' ***************************************** SQL создания таблицы
Function CreateTableStatement(ByRef td As TableDef)
    Dim fld As field2
    result = result & "CREATE TABLE `" & td.Name & "`(" & vbCrLf
    For Each fld In td.Fields
        result = result & CreateFieldStatement(td, fld)
        DoEvents: Debug.Print td.Name & " " & fld.Name
    Next fld
    result = result & GenPKStatement(td) ' GET PK Field to define the INDEX
    Do While Right(result, 1) = Chr(10) Or Right(result, 1) = Chr(13) Or Right(result, 1) = ","
        result = Mid(result, 1, Len(result) - 1)
    Loop
    CreateTableStatement = result & ")" & ";"
End Function
 
' *****************************************
Function GenPKStatement(tdf) As String
    Dim sPkFlds               As String
    Dim aPkFlds()             As String
    If tdf.Indexes.Count > 0 Then
        sPkFlds = Replace(tdf.Indexes("PrimaryKey").Fields, "+", "")
        aPkFlds = Split(sPkFlds, ";")
        If UBound(aPkFlds) = 0 Then
            GenPKStatement = "  PRIMARY KEY (`" & sPkFlds & "`)" & vbCrLf
        End If
    End If
End Function

Public Function GenDataInsertStatements(ByRef conn, ByRef db, ByRef tbl) As Long
    Dim sSQLFields As String, dStr As String, i As Long
    Dim rs As Recordset2
    Set rs = db.OpenRecordset(tbl.Name, dbOpenSnapshot)
 
    For i = 0 To rs.Fields.Count - 1  '
        If i > 0 Then sSQLFields = sSQLFields & ", "
        Select Case rs.Fields(i).Type
            Case dbDate
                Select Case getProperties(rs.Fields(i), "format")
                    Case "general date"
                        strFormat = "yyyy-mm-dd" & IIf(Len(Nz(rs.Fields(i))) > 10, " hh:mm:ss", "")
                    Case "short date"
                        strFormat = "yyyy-mm-dd"
                    Case "short time"
                        strFormat = "hh:mm:ss"
                    Case Else
                        strFormat = "yyyy-mm-dd"
                End Select
                sSQLFields = sSQLFields & "'"" & IIF(ISNULL([" & rs.Fields(i).Name & "]), NULL, FORMAT([" & rs.Fields(i).Name & "], '" & strFormat & "')) & ""'"
            Case dbTime
                Stop
            Case dbTimeStamp
                Stop
            Case dbGUID, dbMemo, dbText
                If (rs.Fields(i).Attributes And dbHyperlinkField) = dbHyperlinkField Then
                    sSQLFields = sSQLFields & "'"" & HyperlinkPart(Nz([" & rs.Fields(i).Name & "]), 5) & ""'"
                Else
                    sSQLFields = sSQLFields & "'"" & NZ([" & rs.Fields(i).Name & "],'NULL') & ""'"
                End If
            Case dbByte, dbInteger, dbLong, dbNumeric, dbDecimal, dbSingle, dbFloat, dbDouble
                If rs.Fields(i).Type = dbSingle Then
                    sSQLFields = sSQLFields & "'"" & STR([" & rs.Fields(i).Name & "]) & ""'"
                Else
                    sSQLFields = sSQLFields & "'"" & NZ([" & rs.Fields(i).Name & "],'NULL') & ""'"
                End If
            Case dbCurrency
                sSQLFields = sSQLFields & "'"" & STR([" & rs.Fields(i).Name & "]) & ""'"
            Case dbBoolean
                sSQLFields = sSQLFields & """ & Replace([" & rs.Fields(i).Name & "], -1, 1) & """
            Case Else
                Stop
        End Select
    Next
    
    rs.Close
    Set rs = Nothing
    
    Set rsExport = db.OpenRecordset("SELECT ""INSERT INTO `" & tbl.Name & "` VALUES(" & sSQLFields & ")"" AS InsertCmd FROM [" & tbl.Name & "]", dbOpenSnapshot)
    With rsExport
        If .RecordCount > 0 Then
            Do While Not .EOF
                dStr = rsExport![InsertCmd]
                dStr = Replace(dStr, "'NULL'", "NULL")
                dStr = Replace(dStr, ", '')", ", NULL)")
                dStr = Replace(dStr, "('',", "(NULL,")
                Do While InStr(1, dStr, ", '',") > 0
                    dStr = Replace(dStr, ", '',", ", NULL,")
                Loop
                conn.Execute dStr
                .MoveNext
            Loop
            GenDataInsertStatements = .RecordCount
        End If
    End With
 
    rsExport.Close
    Set rsExport = Nothing
End Function