vba ado SQL（一）

后续打算写个拼接sql语句的类

这是最原始的

sub test()
 Set con = CreateObject("ADODB.Connection")
 Set Recordset = CreateObject("ADODB.Recordset")
 Set ws= ThisWorkbook.Worksheets("要查找结果")
 
 'path =ThisWorkbook.Path & "\xxx.accdb" ’或者xxx.xls 等等
 path=ThisWorkbook.FullName
   With con
      .ConnectionString = "provider=Microsoft.ACE.OLEDB.12.0;extended properties='excel 8.0;';data source=" & path
      .Open 
   End With
   Dim sql As String
   sql = "select * from [表名$]" '如想从第二行开始[表名$A2:Z65536]

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 这个名字自定义

把下面代码粘贴进去

Public con
Public rs
Dim FileSys
Public dic
Public SQL As String
Public mysqle
Const ex2007 = "Provider=Microsoft.Jet.Oledb.4.0;Extended Properties=excel 8.0;Data source="
Const ex2010 = "provider=Microsoft.ACE.OLEDB.12.0;extended properties='excel 8.0;';data source="

Public Enum Driver
mysql = 1
excel2007 = 2
excel2010 = 3
End Enum

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(ByVal Connection As Driver, ByVal path As String)
   Select Case Connection
      Case mysql
         con.ConnectionString = mysqle
      Case excel2007
         con.ConnectionString = ex2007 & path
      Case excel2010
         con.ConnectionString = ex2010 & path
         
   End Select
End Property

Sub insert()
    '执行数据库增加
    If con.State <> 0 Then con.Close
    If con.State = 0 Then con.Open
    con.Execute (SQL)
End Sub


Public Function Recordset(sht) '传入工作表名称，并将该工作表以Recordset结果集返回

If Me.Sheet_exists(sht) = False Then
    MsgBox "工作表不存在"
    Exit Function
End If
    
If con.State = 0 Then con.Open
    rs.Open Me.SQL, con

    Set Recordset = rs

End Function

Public Sub rs_sht(Optional sheet As Variant) '参数sheet是工作表的名称，如果没有就新建该工作表
'连接mysql并把内容复制到excel文档
'On Error Resume Next
If con.State <> 0 Then con.Close

If con.State = 0 Then con.Open
    rs.Open Me.SQL, con
If Me.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("A3").CopyFromRecordset rs
    
    rs.Close
    con.Close
End Sub
Function Sheet_exists(Optional sheet As Variant) As Boolean
'判断工作表是否存在,返回True或者False
On Error Resume Next
    If sheet = "" Then sheet = "MySQL_EXCEL"
    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

'这个函数是读取工作簿目录下的 \ADODB.Connection里的内容，如果有需要可以自行研究，我是打算做配置文件用
Function text_ConnectionString(Optional path)
    If TypeName(path) = "Error" Then
        spath = ThisWorkbook.path & "\ADODB.Connection"
    Else
        spath = path
    End If
    
    If FileSys.FileExists(spath) = False Then '判断文件是否存在
        Set f = FileSys.OpenTextFile(spath, 8, True)
        Shell ("notepad " & spath)
    End If
    
    Open spath For Input As #1
    ConnectionString = ""
        Do Until EOF(1)
            Line Input #1, Data
            ConnectionString = ConnectionString & Data
            Debug.Print ConnectionString
        Loop
    Close #1
text_ConnectionString = ConnectionString
End Function

Public Sub Class_Initialize()
'初始化加载
    Set rs = CreateObject("adodb.recordset")
    Set con = CreateObject("ADODB.Connection")
    Set FileSys = CreateObject("Scripting.FileSystemObject")

End Sub
Public Sub Class_Terminate()
'程序结束时关闭
    On Error Resume Next
    con.Close: Set con = Nothing
    rs.Close: Set rs = Nothing
    Set FileSys = Nothing
    Err.Clear
End Sub

在模块中测试

Sub test()

 Dim ex As New mysql_excel
 strPath = ThisWorkbook.FullName

 ex.PenConnectionString(excel2010) = strPath

ex.SQL = "select * from [表名$]"
ex.rs_sht ("查询结果")
End Sub

刚开始如果遇到这个错误

下载这个数据源工具，一般excel 都是自带