VBA Mysql 类

Option Explicit

'==================================== 声明属性 =================================
Private Con As ADODB.Connection

' ====================================声明事件===================================

'==================================== 初始化 类 ===================================
Private Sub Class_Initialize()
　　Set Con = New ADODB.Connection
　　Con.CursorLocation = adUseClient '设置此项才可获取 recordset.RecordCount
　　Con.ConnectionString = "Driver={MySQL ODBC 5.2 ANSI Driver};" + _
　　　　"Server=sc;" + _
　　　　"DB=oa;" + _
　　　　"UID=UID;" + _
　　　　"PWD=PWD;" + _
　　　　"OPTION=3;" + _
　　　　"Stmt=Set Names 'UTF-8';"

End Sub

'=================================== 以“属性”的形式对 私有变量 读取、赋值 ====================================

'=================================== 公有方法 ====================================
'关闭连接
Public Sub closeConnection()
　　Con.Close
　　Set Con = Nothing
End Sub

'检测是否连接成功
Public Sub checkConnection()
　　Con.Open
　　If Con.State = adStateOpen Then
　　　　MsgBox "链接状态：" & Con.State & vbCrLf & "ADO版本：" & Con.Version, vbInformation, ""
　　End If

　　closeConnection '关闭连接
End Sub

'将查询得到的记录显示到指定 单元格
Public Sub recordToCell(sqlStr As String, wBook, wSheet, firstCell As String)
　　Dim thisRec As ADODB.Recordset

　　'查询记录
　　Set thisRec = selectRecord(sqlStr)

　　'写入到指定 单元格
　　Workbooks(wBook).Sheets(wSheet).Range(firstCell).CopyFromRecordset thisRec

　　closeConnection '关闭连接
End Sub

'============= 数据库 “插、查、改、删” ==============
'“删除”用“更改”[标记删除]实现）

'①“插入”一条记录（返回值：1成功，-1已有相同值，0失败）
'db 数据库名
'fieldArray 字段名 数组
'valueArray 字段值 数组
'checkField 用于检查是否已有相同记录的 字段名（field1,field2,……）
Public Function inertRecord(db As String, fieldArray, valueArray, checkField As String) As Integer
　　'检查是否已有相应记录
　　Dim insertRow As Integer
　　Dim rec As ADODB.Recordset
　　Dim checkFV, fieldValue, insertSql As String

　　' MsgBox TypeName(fieldArray)

　　checkFV = Join(fieldAndValue(fieldArray, valueArray, checkField), " AND ")
　　fieldValue = Join(fieldAndValue(fieldArray, valueArray), ",")

　　Set rec = selectRecord(db, "id", checkFV)
　　If rec.RecordCount < 1 Then
　　　　insertSql = "INSERT INTO `" & db & "` SET " & fieldValue
　　　　Con.Execute insertSql, insertRow, adCmdText

　　　　inertRecord = IIf(insertRow = 1, 1, 0)
　　Else
　　　　inertRecord = -1
　　End If

　　Set rec = Nothing
End Function

'②按条件“查询”记录（返回值：ADODB.Recordset对象）
'db 数据库名
'fields 要查询的字段名（field1,field2,……）
'where 查询条件（`field1`='value1' AND|OR `field2`='value2' AND|OR ……）
'sortFields 排序工序（field1,field2[DESC],……）
'limit 要查询的记录数（100 或 20,100）
Public Function selectRecord(db As String, Optional fields = "*", _
　　Optional where = "", Optional sortFields = "", Optional limit = "") As ADODB.Recordset

　　Dim sqlStr As String

　　sqlStr = "SELECT " & fields & " FROM `" & db & "`"
　　If where <> "" Then sqlStr = sqlStr & " WHERE " & where
　　If sortFields <> "" Then sqlStr = sqlStr & " ORDER BY '" & sortFields & "'"
　　If limit <> "" Then sqlStr = sqlStr & " LIMIT " & limit

　　' MsgBox sqlStr
　　Set selectRecord = allSql(sqlStr) '总查询 (执行sql语句方法)
End Function

'③“更改”符合指定条件的记录的指定字段（返回受影响的行数）
'db 数据库名
'fieldArray 字段名 数组
'valueArray 字段值 数组
'where 条件（`field1`='value1' AND|OR `field2`='value2' AND|OR ……）
Public Function updateRecord(db As String, fieldArray, valueArray, where As String) As Integer
　　Dim updateRows As Integer
　　Dim updateSql, fieldValue As String

　　fieldValue = Join(fieldAndValue(fieldArray, valueArray), ",")

　　If fieldValue <> "" Then
　　　　updateSql = "UPDATE `" & db & "` SET " & fieldValue & " WHERE " & where
　　　　Con.Open
　　　　Con.Execute updateSql, updateRows, adCmdText

　　　　updateRecord = IIf(updateRows <> 0, updateRows, 0)
　　End If
End Function

'总查询 (执行sql语句方法)
Public Function allSql(sqlStr) As ADODB.Recordset
　　Dim iRowscount As Long

　　Con.Open
　　Set allSql = Con.Execute(sqlStr, iRowscount, adCmdText)
End Function

'=================================== 私有方法 ====================================
'将 fieldArray、valueArray 连接成 `field`='value'（Array）并返回 “数组”
'（若 onlyField 不为空，则只连接包含其内元素的 field）
Private Function fieldAndValue(fieldArray, valueArray, Optional onlyField = "")
　　Dim i, s As Integer
　　Dim fj_onlyField(), fvArray()

　　' MsgBox fieldArray(0)
　　For i = 0 To UBound(fieldArray)
　　　　If fieldArray(i) <> "" Then
　　　　　　If onlyField = "" Then
　　　　　　　　ReDim Preserve fvArray(i)
　　　　　　　　fvArray(i) = "`" & fieldArray(i) & "`='" & valueArray(i) & "'"
　　　　　　Else
　　　　　　　　If InStr(onlyField, ",") > 0 Then
　　　　　　　　　　fj_onlyField = Split(onlyField, ",")
　　　　　　　　　　If checkArrayValue(fj_onlyField, fieldArray(i)) = True Then
　　　　　　　　　　　　ReDim Preserve fvArray(s)
　　　　　　　　　　　　fvArray(s) = "`" & fieldArray(i) & "`='" & valueArray(i) & "'"
　　　　　　　　　　　　s = s + 1
　　　　　　　　　　End If
　　　　　　　　Else
　　　　　　　　　　If onlyField = fieldArray(i) Then
　　　　　　　　　　　　ReDim Preserve fvArray(0)
　　　　　　　　　　　　fvArray(0) = "`" & fieldArray(i) & "`='" & valueArray(i) & "'"
　　　　　　　　　　　　Exit For
　　　　　　　　　　End If
　　　　　　　　End If
　　　　　　End If
　　　　End If
　　Next i
　　fieldAndValue = fvArray
　End Function

'检测数组中是否包含有＝指定值的元素
Private Function checkArrayValue(arr, theValue) As Boolean
　　Dim i As Integer

　　checkArrayValue = False
　　For i = 0 To UBound(arr)
　　　　If arr(i) = theValue Then
　　　　　　checkArrayValue = True
　　　　　　Exit For
　　　　End If
　　Next i
End Function

'将 html实体 转换成正常字符(可用)
Private Function htmlDecodes(str As String) As String
　　If str = "" Then
　　　　htmlDecodes = ""
　　Else
　　　　str = Replace(str, "&lt;", "<")
　　　　str = Replace(str, "&gt;", ">")
　　　　str = Replace(str, "&amp;", "&")
　　　　str = Replace(str, "&quot;", Chr(34))
　　　　str = Replace(str, "&gt;", Chr(39))

　　　　htmlDecodes = str
　　End If
End Function