vba ado SQL(三）

测试文件
链接：https://pan.baidu.com/s/1otoMr1pmCzD_cKPR0xkOow?pwd=6666
提取码：6666
–来自百度网盘超级会员V1的分享

解决了：表中是换行符，而你添加列名没有换行的问题

下面是代码

模块1

Sub 添加数据sql()
Dim ms As New MySQL_Excel, tg As New Target_handle

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

'----------------------测试1----------------------------
    insertColumns = Split("序号,品名,规格,包装,原有库存,入库,出库,现有库存", ",")
    insertValues = Split("4,牛奶,1瓶,框,22,10,5,80", ",")
'----------------------测试1----------------------------

'----------------------测试2----------------------------
'    insertColumns = Split("序号,品名,规格,包装,原有库存,出库,现有库存", ",")
'    insertValues = Split("4,牛奶,1瓶,框,22,5,80", ",")
'    tg.RedimArrIndex(insertColumns) = "入库"
'    tg.RedimArrIndex(insertValues) = 12
'----------------------测试2----------------------------


'----------------------测试3----------------------------
'    insertColumns = Split("品名,规格,包装,原有库存,出库,现有库存", ",")
'    insertValues = Split("牛奶,1瓶,框,22,5,80", ",")
'----------------------测试3----------------------------

    With ms
        '.日期 = 是 '使用这个是添加日期,是当前日期，要保证表里有 日期 这个字段
        '.autoIncrement = "序号" '如果要使用这个属性就使用 测试3 ，作用是这列数据自增
        '--------------上面两个属性要使用，必须保证在 .Table = 表  之前
        .Table = "库存表" '向哪张表添加数据，记得换其他表，字段列名要对应的上
        .Insert_(insertColumns) = insertValues '就是上面数组，前面的是列，后面的是值，数组长度是一样的

Debug.Print .getSql '打印sql语句
        
        .Execute
    End With


End Sub
Sub 测试查询数据sql()
Dim ms As New MySQL_Excel, cols, strSQL

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

cols = "品名,规格,包装"
With ms
    .Table = "库存表"
    .Select_ = "" '也可以设置查询你需要的列，等于上面的cols，就查询出来那三列的值
    
    '.Where_(品名, "鸡") = 包含字符 '品名包含字符 "鸡" 的 数据都查询出来
End With

    'ms.SetSQL = "SELECT * FROM [库存表] where 序号 = (SELECT MAX(序号) FROM [Sheet1$A3:H29])"
    Debug.Print ms.getSql
 
 'Set rs = ms.Recordset()

 ms.rs_sht ("要查找结果")
    
End Sub
Sub 测试修改数据sql()
Dim ms As New MySQL_Excel, cols, strSQL

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

updColumns = Split("品名,规格,包装,现有库存", ",")
updValues = Split("鸡胸,4支,盒子,80", ",")
With ms
    .Table = "库存表"
    .Update_(updColumns) = updValues
    .Where_("序号", 1) = 等于 '把 序号 = 1 的这些数据，修改成上面数组里的数据
End With
    
 Debug.Print ms.getSql
 '根据列名逐个赋值
ms.Execute
    

MySQL_Excel.cls

Public mySQLstr As String

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

Public 日期 As 是否
Public autoIncrement As String
Private selfIncreaseIndex

Private Table_
Private Table_Columns
Private Table_Values
Public 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


Public Property Let SetSQL(ByVal strSQL As String)
    SQL = strSQL
End Property
Public Function getSql() As String
    getSql = SQL
End Function


'根据连接con.ConnectionString是否是excel文件，使表名符合sql语句
'示例：[表$]
'
Public Property Let Table(ByVal YourTable As String)
    Select Case connection_
        Case wps, excel2016
            YourTable = IIf(InStr(1, YourTable, "$") > 0, YourTable, YourTable & "$")
            YourTable = IIf(InStr(1, YourTable, "[") > 0, YourTable, "[" & YourTable)
            YourTable = IIf(InStr(1, YourTable, "]") > 0, YourTable, YourTable & "]")
    End Select
    Table_ = YourTable
    Dim rs, cols(), strSQL
    strSQL = "select * from " & Table_
    If autoIncrement = "" Then
        strSQL = strSQL & " where 1=0"
    Else
        strSQL = strSQL & " where " & autoIncrement & " = (SELECT MAX(" & autoIncrement & ") FROM " & Table_ & ")"
    End If
    Set rs = Recordset(strSQL)
    
    ReDim cols(0 To rs.Fields.Count)
     For i = 0 To rs.Fields.Count - 1
        If autoIncrement <> rs.Fields(i).Name Then cols(i) = rs.Fields(i).Name
     Next
     Table_Columns = cols
     If autoIncrement <> "" Then selfIncreaseIndex = rs.Fields(autoIncrement)
End Property

Public Property Let Insert_(ByVal YourColumns As Variant, ByVal YourValues As Variant)
    YourColumns = mapUnderscoreToCamelCase(YourColumns, Table_Columns)
    Dim cols, vals
    If autoIncrement <> "" Then '这个值是设置自增列,如果有值就在这些数据中添加一个自增列的数据
        tg.RedimArrIndex(YourColumns) = autoIncrement
        tg.RedimArrIndex(YourValues) = selfIncreaseIndex + 1
    End If
    If 日期 = 是 Then
        tg.RedimArrIndex(YourColumns) = "日期"
        tg.RedimArrIndex(YourValues) = VBA.Format(Now(), "yyyy-mm-dd")
    End If
    
    cols = string处理.ColsVals(YourColumns)
    vals = string处理.ColsVals(YourValues, 是)
    SQL = "INSERT INTO " & Table_ & "(" & cols & ")" & " values " & "(" & vals & ")"
End Property
'判断YourColumns是否传参，如果没有，则"*"
Public Property Let Select_(ByVal YourColumns As Variant)
    
    If VarType(YourColumns) = vbError Or IsEmpty(YourColumns) Or YourColumns = "" Or YourColumns = "*" Then YourColumns = "*"
    
    If TypeName(YourColumns) = "String" And InStr(1, YourColumns, ",") > 0 Then YourColumns = Split(YourColumns, ",")
    
    If TypeName(YourColumns) = "String()" Then
        YourColumns = mapUnderscoreToCamelCase(YourColumns, Table_Columns)
        YourColumns = string处理.ColsVals(YourColumns)
    End If
    
    SQL = "SELECT " & YourColumns & " FROM " & Table_
End Property

Public Property Let Update_(ByVal cols, ByVal vals)
    Dim KeyValues
    cols = mapUnderscoreToCamelCase(cols, Table_Columns)
    For i = 0 To UBound(cols)
        dict.Add cols(i), vals(i)
    Next
    KeyValues = string处理.ColsVals(dict)
    SQL = "UPDATE " & Table_ & " SET " & KeyValues
End Property

Public Sub Delete()
    SQL = "DELETE FROM " & Table_
End Sub

Public Property Let Where_(ByVal col As Variant, ByVal vals As Variant, condition_ As 条件)
Dim condition
    SQL = SQL & " WHERE " & string处理.SQL_condition(col, vals, condition_)
End Property

Public Property Let And_(ByVal col As Variant, Optional ByVal vals As Variant, condition_ As 条件)
Dim condition
    SQL = SQL & " AND " & string处理.SQL_condition(col, vals, condition_)
End Property


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

'执行SQL，并返回Recordset结果集
Public Function Recordset(Optional ByVal strSQL As String)
    If con.State <> 0 Then con.Close
    If con.State = 0 Then con.Open
    If strSQL = "" Then strSQL = SQL

    rs.Open strSQL, con
    Set Recordset = rs
End Function

Public Sub rs_sht(Optional sheet As Variant) '参数sheet是工作表的名称，如果没有就新建该工作表
    On Error Resume Next
    Set rs = Recordset()
    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(1, i) = rs.Fields(i - 1).Name
    Next
    ws.Range("A2").CopyFromRecordset rs
End Sub
Private Function Sheet_exists(Optional sheet As Variant) As Boolean
'判断工作表是否存在,返回True或者False
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

'判断字符串中是否有 "_", 去除之后判断是否相等,如果是则替换成带"_"的值
Function mapUnderscoreToCamelCase(ByRef colArray, ByVal colRecordset As Variant)
Dim i%
    For i = 0 To UBound(colArray)
        For Each colrs In colRecordset
            If colArray(i) = Replace(colrs, "_", "", , , vbTextCompare) Then colArray(i) = colrs
        Next
    Next
    mapUnderscoreToCamelCase = colArray
End Function

Private Sub Class_Initialize()
'初始化加载
    Set string处理 = New 字符处理
    Set tg = New Target_handle
    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

Target_handle.cls

Private rowsNumber As Integer
Private kv_string

'获取单元格宽度，多个单元格
Function GetMultipleColumnsWidth(rng As Range)
 Dim colsWidth
    For Each col In rng.columns
        If colsWidth = "" Then
            colsWidth = col.ColumnWidth
        Else
            colsWidth = colsWidth & ";" & col.ColumnWidth
        End If
    Next col
    GetMultipleColumnsWidth = colsWidth
End Function
'根据target ，获取target这行数据，cols列名限定获取，返回一个数组下标0
Public Function targetChange(ByVal cols As Variant, ByVal Target As Range) As Variant
Dim cv, str

    On Error Resume Next
    Let i = 0
    ReDim cv(UBound(cols))
    For Each str In cols
        cv(i) = targetRow_findstrColumn(Target, str)
        i = i + 1
    Next
    targetChange = cv
End Function

'传入target,str  根据target.row和列名str 获取值
Function targetRow_findstrColumn(ByVal Target As Range, ByVal str As String) As String
   targetRow_findstrColumn = Cells(Target.Row, getColRow(Target, str).Column).Value
End Function

'传入target所在表查找 exName 所在单元格，并返回该单元格
Function getColRow(ByVal tar As Range, ByVal exName As String) As Range
    Set getColRow = Sheets(tar.Parent.Name).Cells.Find(What:=exName, LookAt:=xlWhole)
End Function

'扩充数组index+1，并赋值给这个index+1
Public Property Let RedimArrIndex(ByRef arr As Variant, ByVal MaxIndexValue As String)
    ReDim Preserve arr(0 To UBound(arr) + 1)
    arr(UBound(arr)) = MaxIndexValue
End Property

'arr作为条件，筛选arg1=arr
Public Property Let FilterRedimArray(ByRef arg1, ByRef arg2, ByVal arr)
    Dim i As Long, j As Long
    ReDim arr1(0 To UBound(arr)), arr2(0 To UBound(arr))
    For i = 0 To UBound(arr)
        For j = 0 To UBound(arg1)
            If arr(i) = arg1(j) Then
                arr1(i) = arg1(j)
                arr2(i) = arg2(j)
            End If
        Next j
    Next i
    ReDim arg1(0 To UBound(arr)), arg2(0 To UBound(arr))
    arg1 = arr1
    arg2 = arr2

End Property

字符处理.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":
            str = IIf(加引号 = 是, "'" & Vals_or_kv & "'", str = Vals_or_kv)
        Case "Integer":
            str = Vals_or_kv
        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 String
Dim str, str2
    For Each Key In Vals_or_kv.Keys
        If TypeName(Vals_or_kv(Key)) = "Integer" Or TypeName(Vals_or_kv(Key)) = "Double" Then
            str2 = Vals_or_kv(Key)
        Else
            str2 = "'" & Vals_or_kv(Key) & "'"
        End If
        If str <> "" Then
            str = str & "," & Key & "=" & str2
        Else
            str = Key & "=" & str2
        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 = VBA.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