[엑셀 VBA] 예약 DB - 7. MySQL 클래스와 사용법

Private strConn As String
Private conn As ADODB.Connection
 
Private ServerAddress As String
Private myDataBase As String
Private myUserName As String
Private myPassword As String
Private port As String
 
Private Sub Class_Initialize()
End Sub
 
Private Sub Class_Terminate()
    Call disconnect_mysql
End Sub
 
Private Function connecto_to_mysql() As Boolean
 
'    ServerAddress = "localhost"
'    myDataBase = "table1"
'    myUserName = "root"
'    myPassword = "0000"
'    port = "3306"
 
'    strConn = "Driver={MySQL ODBC 8.0 Unicode Driver};Server=" & ServerAddress & ";" & _
'              "Port= " & port & ";" & _
'              "Database=" & myDataBase & ";" & _
'              "Uid=" & myUserName & ";" & _
'              "Pwd=" & myPassword & ";" & _
'              "Connect Timeout=100;"
 
    mdGlobal.DBPath = ThisWorkbook.path & "\DB\tmp.accdb"
 
    If clsUtils Is Nothing Then Set clsUtils = New clsUtils
    If clsUtils.fileExists(DBPath) = False Then
        MsgBox "에러: 엑세스 파일을 찾을 수 없습니다.", vbCritical + vbOKOnly, "엑세스 파일"
    End If
 
    strConn = "Provider=Microsoft.ACE.OLEDB.12.0;Data Source=" & DBPath & ";Persist Security Info=False;"
 
    On Error GoTo Error_Section
 
        Set conn = New ADODB.Connection
        conn.Open strConn
 
    connecto_to_mysql = True
 
   Exit Function
 
Error_Section:
    mdMessage.err_MSG "clsMySQL: connecto_to_mysql", Err, False
    Call disconnect_mysql
    connecto_to_mysql = False
End Function
 
Public Function disconnect_mysql() As Boolean
    On Error GoTo Error_Section
        conn.Close
        Set conn = Nothing
        disconnect_mysql = True
 
    Exit Function
 
Error_Section:
    mdMessage.err_MSG "clsMySQL: disconnect_mysql", Err, False
    disconnect_mysql = False
End Function

mdGlobal.DBPath = ThisWorkbook.path & "\DB\tmp.accdb"

' SQL문으로 실행 : INSERT, UPDATE, DELETE
Public Function mysql_ExecSQL_strSQL(strSQL As String) As Boolean
    Dim aff As Long
 
    On Error GoTo Error_Section
        Call conn.Execute(strSQL, aff)
 
    mysql_ExecSQL_strSQL = IIf(aff > 0, True, False)
 
    Exit Function
 
Error_Section:
    mdMessage.err_MSG "clsMySQL: mysql_ExecSQL_strSQL", Err, False
    mysql_ExecSQL_strSQL = False
End Function

Public Sub err_MSG(funcName As String, Err As Variant, Optional message As String = "", Optional debugOnly As Boolean = True)
    Dim tmp As String
    tmp = "-------- " & funcName & " ----------" & vbNewLine
    tmp = tmp & Err.Number & ": " & Err.Description & vbNewLine
    tmp = tmp & "time: " & VBA.Now & vbNewLine
    tmp = tmp & "message: " & message & vbNewLine
    tmp = tmp & "---------------------- END ---------------------"
 
    Debug.Print tmp
 
    If debugOnly = False Then
        MsgBox tmp, vbCritical + vbOKOnly, "WARNING!!!!"
    End If
End Sub

' SQL문으로 실행 : SELECT 시 rs.recordcount=-1로 반환되는 단점이 있다. affectedRow 속성을 같이 반환한 방법을 생각해야 할 듯
Public Function mysql_ExecSQL_Recordset(ByVal strSQL As String) As Variant
    Dim aff As Long
    Dim rs As New ADODB.Recordset
 
    On Error GoTo Error_Section
        Set rs = conn.Execute(strSQL, aff)
 
    If rs Is Nothing Then
        Set mysql_ExecSQL_Recordset = Nothing
    Else
        Set mysql_ExecSQL_Recordset = rs
    End If
 
    Exit Function
 
Error_Section:
    mdMessage.err_MSG "clsMySQL: mysql_ExecSQL_Recordset", Err, False
    mysql_ExecSQL_Recordset = False
End Function니

Public MySQL As clsMySQL
 
Public Sub setMySQL(Optional opt As Boolean = True)
    If opt = True Then
        If MySQL Is Nothing Then Set MySQL = New clsMySQL
    Else
        If Not MySQL Is Nothing Then Set MySQL = Nothing
    End If
End Sub

Public Function refresh_table(tbName As String, Optional orderBy As Boolean = False) As Boolean
    Dim strSQL As String
    Dim dbTable As String
    dbTable = getDBTableName(tbName)
 
    If VBA.Len(dbTable) = 0 Then Exit Function
 
    If orderBy = False Then
        strSQL = "SELECT * FROM " & dbTable & ";"
    Else
        strSQL = "SELECT * FROM " & dbTable & " ORDER BY ODR;"
    End If
 
    Dim lobj As ListObject
    Set lobj = mdGlobal.getListObject("SCHEMA", tbName)
 
    refresh_table = mdDB.fetchData(lobj, strSQL)
End Function테

'데이터를 DB에서 가져와서 해당 시트의 테이블에 뿌리기
Public Function fetchData(lobj As ListObject, strSQL As String) As Boolean
 
    Call mdGlobal.setMySQL(True)
 
    Dim rs As ADODB.Recordset
 
    On Error GoTo Error_Section
 
        Set rs = MySQL.mysql_SELECT(strSQL)
        'Set rs = mySQL.mysql_ExecSQL_Recordset(strSQL)
 
        If Not rs Is Nothing Then
 
            Application.EnableEvents = False
            Application.ScreenUpdating = False
 
            If lobj.ListRows.Count > 0 Then lobj.DataBodyRange.delete
 
            lobj.ListRows.Add AlwaysInsert:=True
            lobj.DataBodyRange.Cells(1, 1).CopyFromRecordset rs
        End If
 
    Set lobj = Nothing
    rs.Close
    Set rs = Nothing
    Call mdGlobal.setMySQL(False)
 
 
    Application.EnableEvents = True
    Application.ScreenUpdating = True
 
    fetchData = True
 
    Exit Function
 
Error_Section:
    mdMessage.err_MSG "mdDB: fetchData", Err, False
 
    Set lobj = Nothing
    Set rs = Nothing
    Call mdGlobal.setMySQL(False)
    Application.EnableEvents = True
    Application.ScreenUpdating = True
 
    fetchData = False
End Function

Public Function mysql_SELECT(strSQL As String) As Variant
 
    Dim rs As New ADODB.Recordset
'   rs.CursorLocation = adUseClient
'   rs.ActiveConnection = Conn
'   rs.Source = strSQL
    rs.Open strSQL, conn, CursorTypeEnum.adOpenDynamic, LockTypeEnum.adLockOptimistic 'adOpenDynamic = 2, adLockOptimistic= 3
'    rs.Open strSQL, conn
 
'    Debug.Print rs.RecordCount
    On Error GoTo Error_Section
        If rs Is Nothing Then
            Set mysql_SELECT = Nothing
        Else
            Set mysql_SELECT = rs
        End If
    Exit Function
 
Error_Section:
    mdMessage.err_MSG "clsMySQL: mysql_SELECT", Err, False
    mysql_SELECT = False
End Function

Public Function mysql_INSERT_strSQL(strSQL As String) As Long
   Dim aff As Byte, SER As Long
   On Error GoTo Error_Section
      Call conn.Execute(strSQL, aff)
 
      If aff > 0 Then
        SER = conn.Execute("SELECT @@Identity")(0)
        mysql_INSERT_strSQL = SER
     Else
        mysql_INSERT_strSQL = -1
     End If
   Exit Function
 
Error_Section:
    mdMessage.err_MSG "clsMySQL: mysql_INSERT_strSQL", Err, False
    mysql_INSERT_strSQL = False
End Function

Public Function mysql_INSERT_Array(ByVal tbName As String, arrFields, arrValues) As Long
 
    On Error GoTo Error_Section
        'rs.Open tbName, Conn, adOpenDynamic, adLockOptimistic, adCmdTable
        Dim rs As New ADODB.Recordset
        rs.ActiveConnection = conn
        rs.CursorType = adOpenDynamic
        rs.LockType = adLockOptimistic
        rs.Open tbName, , , , adCmdTable
 
        rs.AddNew arrFields, arrValues
        rs.update
 
        Dim SER: SER = conn.Execute("SELECT @@Identity")(0)
        mysql_INSERT_Array = IIf(SER > 0, SER, 0)
 
    Exit Function
 
Error_Section:
    mdMessage.err_MSG "clsMySQL: mysql_INSERT_Array", Err, False
    mysql_INSERT_Array = 0
End Function

Public Function MySQL_INSERT_Range(tbName As String, ws As Worksheet, rowStart As Long, rowEnd As Long, colStart As Long, colEnd As Long) As Boolean
   Dim rs As ADODB.Recordset
   Set rs = New ADODB.Recordset
 
   On Error GoTo Error_MySQL_INSERT_Range
 
      Dim strSQL As String
      strSQL = "SELECT * FROM " & tbName & ";"
      rs.Open strSQL, strConn, CursorTypeEnum.adOpenDynamic, LockTypeEnum.adLockOptimistic 'adOpenDynamic = 2, adLockOptimistic= 3
 
      Dim row As Long, col As Long
      Dim fdName As String, val As Variant
 
      For row = rowStart To rowEnd
         rs.AddNew
         For col = colStart To colEnd
            fdName = Cells(1, col).Text
            val = Cells(row, col).value
 
            Debug.Print row & ":" & col & vbTab & fdName & ":" & val
            rs.Fields(fdName) = val
         Next col
         Debug.Print row
      Next row
      rs.update
 
   On Error GoTo 0
   rs.Close
   Set rs = Nothing
   MySQL_INSERT_Range = True
   Exit Function
 
Error_MySQL_INSERT_Range:
   MsgBox Err.Description, vbInformation
   Set rs = Nothing
   MySQL_INSERT_Range = False
End Function

Public Function mysql_UPDATE_Recordset(ByVal tbName As String, ByVal criterion As String, arrFields, arrValues) As Boolean
 
   On Error GoTo Error_Section
      Dim rs As New ADODB.Recordset
      rs.ActiveConnection = conn
      rs.CursorType = adOpenDynamic
      rs.LockType = adLockOptimistic            'adLockPessimistic :다른 사용자가 이 레코드를 변경, 수정하지 못하게 락을 거는
      rs.Open tbName, , , , adCmdTable
 
'     Dim criteria As String: criteria = "Ser = " & key
      Dim criteria As String: criteria = criterion
 
      'rs.MoveLast
      'rs.Find criteria, , adSearchBackward
      rs.Find criteria
      rs.update arrFields, arrValues
 
      rs.Close
      Set rs = Nothing
      mysql_UPDATE_Recordset = True
 
   Exit Function
 
Error_Section:
'    rs.Close
    Set rs = Nothing
    mdMessage.err_MSG "clsMySQL: mysql_UPDATE_Recordset", Err, False
 
    mysql_UPDATE_Recordset = False
End Function

Function IsDataExist(strSQL As String) As Boolean
    Dim aff As Long
 
    On Error GoTo Error_Section
        Call conn.Execute(strSQL, aff)
 
        IsDataExist = IIf(aff > 0, True, False)
    Exit Function
 
Error_Section:
    mdMessage.err_MSG "clsMySQL: IsDataExist", Err, False
    IsDataExist = False
End Function

Option Explicit
 
'//   mySQL Connector/ODBC Driver 설치                      //'
'//      https://dev.mysql.com/downloads/file/?id=506041    : ODBC
'//      https://dev.mysql.com/downloads/file/?id=506231    : ADO
'//   strPath : DB가 있는 엑셀 파일이음                     //'
'//   strSQL : SQL문                                        //'
'//   pasteRange : 검색한 레코드를 붙여 넣을 범위           //'
 
Private strConn As String
Private conn As ADODB.Connection
 
Private ServerAddress As String
Private myDataBase As String
Private myUserName As String
Private myPassword As String
Private port As String
 
 
Private Sub Class_Initialize()
    'If connecto_to_mysql = False Then Exit Sub
End Sub
 
Private Sub Class_Terminate()
    Call disconnect_mysql
End Sub
 
Private Function connecto_to_mysql() As Boolean
 
'    strConn = "Driver={MySQL ODBC 8.0 Unicode Driver};Server=" & ServerAddress & ";" & _
'              "Port= " & port & ";" & _
'              "Database=" & myDataBase & ";" & _
'              "Uid=" & myUserName & ";" & _
'              "Pwd=" & myPassword & ";" & _
'              "Connect Timeout=100;"
 
   mdGlobal.DBPath = ThisWorkbook.path & "\DB\tmp.accdb"
 
    If clsUtils Is Nothing Then Set clsUtils = New clsUtils
    If clsUtils.fileExists(DBPath) = False Then
        MsgBox "에러: 엑세스 파일을 찾을 수 없습니다.", vbCritical + vbOKOnly, "엑세스 파일"
    End If
 
    strConn = "Provider=Microsoft.ACE.OLEDB.12.0;Data Source=" & DBPath & ";Persist Security Info=False;"
 
    On Error GoTo Error_Section
        Set conn = New ADODB.Connection
        conn.Open strConn
 
    connecto_to_mysql = True
   Exit Function
 
Error_Section:
    mdMessage.err_MSG "clsMySQL: connecto_to_mysql", Err, False
    Call disconnect_mysql
    connecto_to_mysql = False
End Function
 
Public Function disconnect_mysql() As Boolean
    On Error GoTo Error_Section
        conn.Close
        Set conn = Nothing
        disconnect_mysql = True
 
    Exit Function
 
Error_Section:
    mdMessage.err_MSG "clsMySQL: disconnect_mysql", Err, False
    disconnect_mysql = False
End Function
 
Private Sub closeRcordset(rs As ADODB.Recordset)
    If Not rs Is Nothing Then
        rs.Close
        Set rs = Nothing
    End If
End Sub
 
' --------------------------------------------------------------------------------------
' Data Handling-------------------------------------------------------------------------
 
' SQL문으로 실행 : INSERT, UPDATE, DELETE
Public Function mysql_ExecSQL_strSQL(strSQL As String) As Boolean
    Dim aff As Long
 
    On Error GoTo Error_Section
        Call conn.Execute(strSQL, aff)
 
    mysql_ExecSQL_strSQL = IIf(aff > 0, True, False)
 
    Exit Function
 
Error_Section:
    mdMessage.err_MSG "clsMySQL: mysql_ExecSQL_strSQL", Err, False
    mysql_ExecSQL_strSQL = False
End Function
 
 
' SQL문으로 실행 : SELECT 시 rs.recordcount=-1로 반환되는 단점이 있다. affectedRow 속성을 같이 반환한 방법을 생각해야 할 듯
Public Function mysql_ExecSQL_Recordset(ByVal strSQL As String) As Variant
    Dim aff As Long
    Dim rs As New ADODB.Recordset
 
    On Error GoTo Error_Section
        Set rs = conn.Execute(strSQL, aff)
 
    If rs Is Nothing Then
        Set mysql_ExecSQL_Recordset = Nothing
    Else
        Set mysql_ExecSQL_Recordset = rs
    End If
 
    Exit Function
 
Error_Section:
    mdMessage.err_MSG "clsMySQL: mysql_ExecSQL_Recordset", Err, False
    mysql_ExecSQL_Recordset = False
End Function
 
 
' SELECT ----------------------------------------------------------------------
' SELECT ----------------------------------------------------------------------
 
Public Function mysql_SELECT(strSQL As String) As Variant
 
    Dim rs As New ADODB.Recordset
'   rs.CursorLocation = adUseClient
'   rs.ActiveConnection = Conn
'   rs.Source = strSQL
    rs.Open strSQL, conn, CursorTypeEnum.adOpenDynamic, LockTypeEnum.adLockOptimistic 'adOpenDynamic = 2, adLockOptimistic= 3
'    rs.Open strSQL, conn
 
'    Debug.Print rs.RecordCount
    On Error GoTo Error_Section
        If rs Is Nothing Then
            Set mysql_SELECT = Nothing
        Else
            Set mysql_SELECT = rs
        End If
    Exit Function
 
Error_Section:
    mdMessage.err_MSG "clsMySQL: mysql_SELECT", Err, False
    mysql_SELECT = False
End Function
 
Public Function mysql_INSERT_strSQL(strSQL As String) As Long
   Dim aff As Byte, SER As Long
   On Error GoTo Error_Section
      Call conn.Execute(strSQL, aff)
 
      If aff > 0 Then
        SER = conn.Execute("SELECT @@Identity")(0)
        mysql_INSERT_strSQL = SER
     Else
        mysql_INSERT_strSQL = -1
     End If
   Exit Function
 
Error_Section:
    mdMessage.err_MSG "clsMySQL: mysql_INSERT_strSQL", Err, False
    mysql_INSERT_strSQL = False
End Function
 
Public Function mysql_INSERT_Array(ByVal tbName As String, arrFields, arrValues) As Long
 
    On Error GoTo Error_Section
        'rs.Open tbName, Conn, adOpenDynamic, adLockOptimistic, adCmdTable
        Dim rs As New ADODB.Recordset
        rs.ActiveConnection = conn
        rs.CursorType = adOpenDynamic
        rs.LockType = adLockOptimistic
        rs.Open tbName, , , , adCmdTable
 
        rs.AddNew arrFields, arrValues
        rs.update
 
        Dim SER: SER = conn.Execute("SELECT @@Identity")(0)
        mysql_INSERT_Array = IIf(SER > 0, SER, 0)
 
    Exit Function
 
Error_Section:
    mdMessage.err_MSG "clsMySQL: mysql_INSERT_Array", Err, False
    mysql_INSERT_Array = 0
End Function
 
Public Function MySQL_INSERT_Range(tbName As String, ws As Worksheet, rowStart As Long, rowEnd As Long, colStart As Long, colEnd As Long) As Boolean
   Dim rs As ADODB.Recordset
   Set rs = New ADODB.Recordset
 
   On Error GoTo Error_MySQL_INSERT_Range
 
      Dim strSQL As String
      strSQL = "SELECT * FROM " & tbName & ";"
      rs.Open strSQL, strConn, CursorTypeEnum.adOpenDynamic, LockTypeEnum.adLockOptimistic 'adOpenDynamic = 2, adLockOptimistic= 3
 
      Dim row As Long, col As Long
      Dim fdName As String, val As Variant
 
      For row = rowStart To rowEnd
         rs.AddNew
         For col = colStart To colEnd
            fdName = Cells(1, col).Text
            val = Cells(row, col).value
 
            Debug.Print row & ":" & col & vbTab & fdName & ":" & val
            rs.Fields(fdName) = val
         Next col
         Debug.Print row
      Next row
      rs.update
 
   On Error GoTo 0
   rs.Close
   Set rs = Nothing
   MySQL_INSERT_Range = True
   Exit Function
 
Error_MySQL_INSERT_Range:
   MsgBox Err.Description, vbInformation
   Set rs = Nothing
   MySQL_INSERT_Range = False
End Function
 
 
' UPDATE ----------------------------------------------------------------------
' UPDATE ----------------------------------------------------------------------
 
Public Function mysql_UPDATE_Recordset(ByVal tbName As String, ByVal criterion As String, arrFields, arrValues) As Boolean
 
   On Error GoTo Error_Section
      Dim rs As New ADODB.Recordset
      rs.ActiveConnection = conn
      rs.CursorType = adOpenDynamic
      rs.LockType = adLockOptimistic            'adLockPessimistic :다른 사용자가 이 레코드를 변경, 수정하지 못하게 락을 거는
      rs.Open tbName, , , , adCmdTable
 
'     Dim criteria As String: criteria = "Ser = " & key
      Dim criteria As String: criteria = criterion
 
      'rs.MoveLast
      'rs.Find criteria, , adSearchBackward
      rs.Find criteria
      rs.update arrFields, arrValues
 
      rs.Close
      Set rs = Nothing
      mysql_UPDATE_Recordset = True
 
   Exit Function
 
Error_Section:
'    rs.Close
    Set rs = Nothing
    mdMessage.err_MSG "clsMySQL: mysql_UPDATE_Recordset", Err, False
 
    mysql_UPDATE_Recordset = False
End Function
 
 
' -----------------------------------------------------
' -----------------------------------------------------
Function IsDataExist(strSQL As String) As Boolean
    Dim aff As Long
 
    On Error GoTo Error_Section
        Call conn.Execute(strSQL, aff)
 
        IsDataExist = IIf(aff > 0, True, False)
    Exit Function
 
Error_Section:
    mdMessage.err_MSG "clsMySQL: IsDataExist", Err, False
    IsDataExist = False
End Function
 
' 표 없데이트 또는 삽입 -------------------------------
' -----------------------------------------------------
 
Public Function mysql_ListObject_Update(lobj As ListObject, tbName As String, criterion As String) As Boolean
 
    Dim criteria As String
 
'    Dim arrFields(): arrFields = Array("Ser", "GC", "NET_WE", "NET_WD", "MEM_WE", "MEM_WD", "VIP_WE", "VIP_WD", "OTH_WE", "OTH_WD", "NOTE", "DEADLINE", "LIST_ORDER")
    Dim arrFields()
    Dim arrValues()
    Dim cnt As Long: cnt = lobj.ListRows.Count
    Dim key As Variant
    Dim row As Long
    Dim newSerial As Long
 
    On Error GoTo Error_Section
 
        arrFields = RangeToArray(lobj.HeaderRowRange, True, False)
 
        Dim rs As New ADODB.Recordset
        rs.ActiveConnection = conn
        rs.CursorType = adOpenDynamic
        rs.LockType = adLockOptimistic
        rs.Open tbName, , , , adCmdTable
 
        For row = 1 To cnt
            key = VBA.Trim(lobj.ListRows(row).Range(, 1).value)
            arrValues = RangeToArray(lobj.ListRows(row).Range, True, False)
 
 
            If VBA.Len(key) > 0 Then
                'UPDATE
                criteria = criterion & key
                rs.MoveFirst
                rs.Find criteria
                rs.update arrFields, arrValues
                Debug.Print key & ": UPDATED"
                Debug.Print "-------------------------------------"
            Else
                'INSERT
                rs.AddNew arrFields, arrValues
                rs.update
                newSerial = conn.Execute("SELECT @@Identity")(0)
                Debug.Print newSerial & ": INSERTED"
                Debug.Print "-------------------------------------"
            End If
        Next row
 
    rs.Close
    Set rs = Nothing
    mysql_ListObject_Update = True
    Exit Function
 
Error_Section:
    Set rs = Nothing
    mdMessage.err_MSG "clsMySQL: mysql_ListObject_Update", Err, False
 
    mysql_ListObject_Update = False
End Function
 
 
 
 
Public Function RangeToArray(rng As Range, Optional tpose As Boolean = True, Optional includeIndex = False)
   Dim arr()
   Dim arrResult()
   Dim i As Long, index As Long, endIndex As Long
   arr = IIf(tpose, Application.Transpose(rng.value), rng.value)
 
'   Debug.Print "rng LBound Value Columns: " & LBound(rng.Value, 1) : 헤더 포함 행의 개수
'   Debug.Print "rng UBound Value Columns: " & UBound(rng.Value, 2) : 칼럼의 개수
 
   If includeIndex = False Then
      ReDim arrResult(1 To UBound(arr, 1) - 1)
      index = 2
      endIndex = UBound(arr, 1) - 1
   Else
      ReDim arrResult(1 To UBound(arr, 1))
     index = 1
      endIndex = UBound(arr, 1)
   End If
 
   Dim tmp
   For i = 1 To endIndex
      tmp = VBA.Trim(arr(index, 1))
      If tmp = "" Then tmp = Null
      arrResult(i) = tmp
continue:
      index = index + 1
   Next i
   RangeToArray = arrResult
End Function