vba ado SQL（二）

Sub 原始()
 Set con = CreateObject("ADODB.Connection")
 Set Recordset = CreateObject("ADODB.Recordset")
 Set ws = ThisWorkbook.Worksheets("要查找结果")
 
 path = ThisWorkbook.FullName
 'path = "C:\Users\your\Documents\Database1.accdb;"
  With con
     .ConnectionString = "Provider=Microsoft.ACE.OLEDB.12.0;Extended Properties='Excel 12.0';Data Source=" & path
     .Open
	 End With
	 Dim SQL As String
  SQL = "SELECT * FROM [表1$] " '如想从第二行开始[表名$A2:Z65536]
   
   'con.Execute ("DELETE FROM [表1$] WHERE 序号 = ('aaa')")
   
   Recordset.Open SQL, con
   For i = 1 To Recordset.Fields.Count
       ws.Cells(1, i) = Recordset.Fields(i - 1).Name
   Next
   ws.Range("A2").CopyFromRecordset Recordset
   
   Recordset.Close
   con.Close
   Set Recordset = Nothing
   Set con = Nothing
   Set ws = Nothing
End Sub

改进版本

MySQL_Excel.cls

Public mySQLstr As String

Private connection_ As Driver
Private con As Object
Private cmd As Object
Private rs As Object
Private FileSys As Object
Private dict As Object
Private mysqle As String
Private SQL As String

Private string处理 As 字符处理


Public Enum Driver
mySQL = 1
wps = 2
excel2016 = 3
End Enum


'是低版本的excel、wps使用Excel_8
Const Excel_8 = "Extended Properties='Excel 8.0';"
Const Excel_12 = "Extended Properties='Excel 12.0';"

'是低版本的excel、wps使用Excel_12
Const ApplicationVersion_12 = "Provider=Microsoft.Jet.Oledb.4.0;Data source="
Const ApplicationVersion_16 = "Provider=Microsoft.ACE.OLEDB.12.0;Data Source="
Public Function mysql_ConnectionString(ByVal server As String, ByVal database As String, ByVal uid As String, ByVal pwd As String)
    mysqle = "Driver={MySQL ODBC 8.0 Unicode Driver}" _
                        & ";server = " & server _
                        & ";Port=3306" _
                        & ";DB=" & database _
                        & ";UID=" & uid _
                        & ";PWD=" & pwd _
                        '& ";OPTION=3;"
End Function

'
Public Property Let PenConnectionString(Optional ByVal Connection As Driver, ByVal path As String)
 Dim ExtensionName
    Select Case Connection
       Case mySQL
          con.ConnectionString = mysqle
       Case excel2016
          con.ConnectionString = ApplicationVersion_16 & path
       Case Else
         con.ConnectionString = ApplicationVersion_12 & path
    End Select
    '
    ExtensionName = string处理.GetFileExtensionSafe(path)
    
    If string处理.StringContainsAny(ExtensionName, "xls", "xlsx", "xlsb", "xlsm") Then
        Select Case Application.Version
            Case "16.0"
                con.ConnectionString = con.ConnectionString & ";" & Excel_12
            Case "12.0"
                con.ConnectionString = con.ConnectionString & ";" & Excel_8
        End Select
        connection_ = Connection
    End If
End Property



'根据连接con.ConnectionString是否是excel文件，使表名符合sql语句
'示例：[表$]
Private Function SQL_Table(ByVal YourTable As String)
    Select Case connection_
        Case wps, excel2016
            YourTable = "[" & YourTable & "$]"
    End Select
    SQL_Table = YourTable
End Function


Public Property Let SetSQL(ByVal strsql As String)
    SQL = strsql
End Property
Public Property Get GetSQL() As String
    GetSQL = SQL
End Property


Public Property Get SQL_Insert_增(ByVal YourTable As String, ByVal YourColumns As Variant, ByVal YourValues As Variant) As MySQL_Excel
    YourTable = SQL_Table(YourTable)
    coloumns = string处理.ColsVals(YourColumns)
    vals = string处理.ColsVals(YourValues, 是)
    SQL = "INSERT INTO " & YourTable & "(" & coloumns & ")" & " values " & "(" & vals & ")"
    Set SQL_Insert_增 = Me
End Property

Public Property Get SQL_Select_查(ByVal YourTable As String, Optional YourColumns As Variant) As MySQL_Excel
    YourTable = SQL_Table(YourTable)
    If VarType(YourColumns) = vbError Then
        YourColumns = "*" '判断YourColumns是否传参，如果没有，则赋值 "*"
    Else
        YourColumns = string处理.ColsVals(YourColumns)
    End If

    SQL = "SELECT " & YourColumns & " FROM " & YourTable
    Set SQL_Select_查 = Me
End Property


Public Property Get SQL_Update_改(ByVal YourTable As String, ByVal Columns_Or_Dict As Variant) As MySQL_Excel
    YourTable = SQL_Table(YourTable)
    Dim KeyValues
    If TypeName(Columns_Or_Dict) = "Dictionary" Then KeyValues = string处理.ColsVals(Columns_Or_Dict)
    SQL = "UPDATE " & YourTable & " SET " & KeyValues
    Set SQL_Update_改 = Me
End Property

Public Property Get SQL_Delete_删(ByVal YourTable As String) As MySQL_Excel
    YourTable = SQL_Table(YourTable)
    SQL = "DELETE FROM " & YourTable
    Set SQL_Delete_删 = Me
End Property

Public Property Get Where(ByVal Col As Variant, ByVal vals As Variant, Optional condition_ As 条件 = 条件.等于) As MySQL_Excel
Dim condition
    SQL = SQL & " WHERE " & string处理.SQL_condition(Col, vals, condition_)
    Set Where = Me
End Property

Public Property Get And_(ByVal Col As Variant, Optional ByVal vals As Variant, Optional condition_ As 条件 = 条件.等于) As MySQL_Excel
Dim condition
    SQL = SQL & " AND " & string处理.SQL_condition(Col, vals, condition_)
    Set And_ = Me
End Property


Public Sub SQL_Execute(Optional ByVal strsql As String)
    If strsql <> "" Then SQL = strsql
    If con.State = 0 Then con.Open
    With cmd
        .ActiveConnection = con
        .CommandText = SQL
        .Execute
    End With
End Sub

Public Function Recordset(sht) As Object '传入工作表名称，并将该工作表以Recordset结果集返回
    If con.State <> 0 Then con.Close
    If con.State = 0 Then con.Open
    rs.Open SQL, con
    Set Recordset = rs
End Function

Public Sub rs_sht(Optional sheet As Variant) '参数sheet是工作表的名称，如果没有就新建该工作表

Set rs = Recordset(sheet)

If Sheet_exists(sheet) = False Then Worksheets.Add().Name = sheet '判断是否存在名字"MySQL_Excel"的工作表存在,如果不存在就新建
Set ws = Worksheets(sheet)
    ws.Cells.ClearContents
Dim i As Integer
    For i = 1 To rs.Fields.Count
        ws.Cells(2, i) = rs.Fields(i - 1).Name
    Next
    ws.Range("A1").CopyFromRecordset rs
End Sub
'判断工作表是否存在,返回True或者False
Private Function Sheet_exists(Optional sheet As Variant) As Boolean
On Error Resume Next
    If sheet = "" Then sheet = "查询结果"
    Set ws = ActiveWorkbook.Sheets(sheet)
        If ws Is Nothing Then
            Sheet_exists = False '工作表不存在返回false
        Else
            Sheet_exists = True '存在返回true
        End If
Set ws = Nothing
End Function

'初始化加载
Private Sub Class_Initialize()
    Set string处理 = New 字符处理
    Set rs = CreateObject("adodb.recordset")
    Set con = CreateObject("ADODB.Connection")
    Set cmd = CreateObject("ADODB.Command")
    Set dict = CreateObject("Scripting.Dictionary")
End Sub
'程序结束时关闭
Private Sub Class_Terminate()
    On Error Resume Next
    con.Close: Set con = Nothing
    rs.Close: Set rs = Nothing
    Set cmd = Nothing
    Set dict = Nothing
    Err.Clear
End Sub

字符处理.cls

Public Enum 是否
否 = 1
是 = 2
End Enum

Public Enum 条件
等于 = 0
大于 = 1
小于 = 2
包含 = 3
不包含 = 4
包含字符 = 5
不包含字符 = 6
End Enum

Public Enum 字符匹配
左 = 1
中 = 2
右 = 3
End Enum
'参数：vals如果是
'【String：字符串】原样返回：( vals )
'StringsColsVals方法：      拼接返回：(str1,str2,str3……)
'DictionaryColsVals方法：   key1 = 'val1' ,key2 = 'val2' ……
Public Function ColsVals(ByVal Vals_or_kv As Variant, Optional 加引号 As 是否 = 否) As String
Dim str, val
    Select Case TypeName(Vals_or_kv)
        Case "String":
            If 加引号 = 是 Then
                str = "'" & Vals_or_kv & "'"
            Else
                str = Vals_or_kv
            End If
        Case "Dictionary":
            str = DictionaryColsVals(Vals_or_kv)
        Case Else:
            str = StringsColsVals(Vals_or_kv, 加引号)
    End Select
    ColsVals = str
End Function

'【String():字符数组】拼接返回：(str1,str2,str3……)
Private Function StringsColsVals(ByVal Vals_or_kv As Variant, Optional 加引号 As 是否 = 否) As String
Dim str, val
    For Each val In Vals_or_kv
        If 加引号 = 是 Then val = "'" & val & "'"
        If str <> "" Then
            str = str & "," & val
        Else
            str = val
        End If
    Next val
    StringsColsVals = str
End Function

'【Dictionary:字典】拼接返回： key1 = 'val1' ,key2 = 'val2' ……
Private Function DictionaryColsVals(ByVal Vals_or_kv As Variant) As String
Dim str
    For Each key In Vals_or_kv.Keys
        If str <> "" Then
            str = str & "," & key & "='" & Vals_or_kv(key) & "'"
        Else
            str = key & "='" & Vals_or_kv(key) & "'"
        End If
    Next key
    DictionaryColsVals = str
End Function



Public Function SQL_LikeValue(ByVal val As String, Optional ByVal like_ As 字符匹配 = 字符匹配.中) As String
    Select Case like_
        Case 字符匹配.左
            SQL_LikeValue = "'" & val & "%'"
        Case 字符匹配.中
            SQL_LikeValue = "'%" & val & "%'"
        Case 字符匹配.右
            SQL_LikeValue = "'%" & val & "'"
    End Select
End Function

'第一个Case条件：示例 传入【col,str,大于】                      返回：col > 'str'
'第二个Case条件：示例 传入【col,Array("str1","str2"),包含】     返回：col IN ('str1','str2')
'第三个Case条件：示例 传入【col,str,包含字符】                  返回：col like *str*
Public Function SQL_condition(ByVal Col As Variant, Optional ByVal vals As Variant, Optional condition_ As 条件 = 条件.等于) As String
Dim condition
    Select Case condition_
        Case 条件.大于, 条件.等于, 条件.小于:
            vals = ColsVals(vals, 是)
            If condition_ = 条件.大于 Then condition = " > "
            If condition_ = 条件.等于 Then condition = " = "
            If condition_ = 条件.小于 Then condition = " < "
            
        Case 条件.包含, 条件.不包含:
            vals = "(" & ColsVals(vals, 是) & ")"
            If condition_ = 条件.包含 Then condition = " IN "
            If condition_ = 条件.不包含 Then condition = " NOT IN "
            
        Case 条件.包含字符, 条件.不包含字符
            vals = SQL_LikeValue(vals)
            If condition_ = 条件.包含字符 Then condition = " LIKE "
            If condition_ = 条件.不包含字符 Then condition = " NOT LIKE "
    End Select
    SQL_condition = Col & condition & vals
End Function

'返回文件路径后缀名
Public Static Function GetFileExtensionSafe(ByVal filePath As String) As String
    If InStrRev(filePath, ".") > 0 Then
        GetFileExtensionSafe = Mid(filePath, InStrRev(filePath, ".") + 1)
    Else
        GetFileExtensionSafe = "" ' 如果没有扩展名，则返回空字符串
    End If
End Function

'字符串中包含数组中任意一个返回TRUE
Function StringContainsAny(ByVal str As String, ParamArray arr() As Variant) As Boolean
    Dim i As Long
    
    For i = LBound(arr) To UBound(arr)
        If InStr(1, str, arr(i), vbTextCompare) > 0 Then
            StringContainsAny = True
            Exit Function
        End If
    Next i
    StringContainsAny = False
End Function

测试模块

Sub 测试增加数据sql()

Dim ms As New MySQL_Excel
'path = "C:\Users\Your\Documents\Database1.accdb"
path = ThisWorkbook.FullName

ms.PenConnectionString(excel2016) = path
Dim str1, str2
    str1 = Split("序号,名称,规格,本月表1", ",")
    str2 = Split("111,bbbiii,123,1111", ",")
'    str1 = Array("序号", "名称")
'    str2 = Array("aaa", "bbb")

    strsql = ms.SQL_Insert_增("表1", str1, str2).GetSQL()

Debug.Print strsql
ms.SQL_Execute
End Sub

Sub 测试查询数据sql()
Dim ms As New MySQL_Excel

'path = "C:\Users\your\Documents\Database1.accdb"
path = ThisWorkbook.FullName
ms.PenConnectionString(excel2016) = path

Cols = Split("序号,规格", ",")
vals = Split("1212001,1212005", ",")

'strsql = ms.SQL_Select_查("表1").GetSQL()
'strsql = ms.SQL_Select_查("表1", vals).GetSQL()
strsql = ms.SQL_Select_查("表1").Where("序号", vals, 包含).GetSQL()
'strsql = ms.SQL_Select_查("表1").Where("序号", "1112017").And_("规格", "浅灰色", 条件.包含).GetSQL()
 
 Debug.Print strsql

 ms.rs_sht ("要查找结果")
    
End Sub


Sub 测试修改数据sql()
Dim ms As New MySQL_Excel
    
    ms.PenConnectionString(excel2016) = ThisWorkbook.FullName
    
    Set dict = CreateObject("Scripting.Dictionary")

    dict.Add "序号", 111
    dict.Add "规格", "bbb"
            
    strsql = ms.SQL_Update_改("表1", dict).Where("序号", "1112017").GetSQL()
    Debug.Print strsql
    ms.SQL_Execute strsql
End Sub


'不支持删除excel文件中的数据
Sub 测试删除数据sql()
Dim ms As New MySQL_Excel

path = "C:\Users\your\Documents\Database1.accdb"
ms.PenConnectionString(excel2016) = path
          
strsql = ms.SQL_Delete_删("表1").Where("序号", "aaa").GetSQL()

Debug.Print strsql
ms.SQL_Execute
End Sub

表

链接：[https://pan.baidu.com/s/1GMIpUJIJET8tfyR7Ve0dcw]
提取码：6666