测试文件
链接: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