excel用VBA连接数据库为啥我的程序错误呢？新手上路，求各位前辈指点！

Posted 2023-04-24

Sub 查询外购件() ' ' 查询外购件 Macro ' 宏由 DELL 录制，时间: 2013-1-16 ' ' 'Windows("PERSONAL.XLS").Visible = True 'UserForm1.Visible = True 'Application.Goto Reference:="查询外购件" 'Application.WindowState = xlMinimized 'Windows("HOUR2.xls").Activate 'ActiveWindow.Close Dim i%, strCn$, strSQL$, serIP$, uid$, pwd$, dbName$, mydate, sht As Worksheet 'i为整数变量。 Dim cn As Object '定义数据链接对象 ，保存连接数据库信息 Dim rs As Object '定义记录集对象，保存数据表 Dim stime As Date, etime As Date stime = Timer serIP = "192.168.1.239store" uid = "sa" pwd = "sasasasa" dbName = "PLM" Set cn = CreateObject("ADODB.Connection") '创建数据链接对象 Set rs = CreateObject("ADODB.RecordSet") '创建记录集对象 strCn = "Provider=sqloledb;Server=" & serIP & ";Database=" & dbName & ";Uid=" & uid & ";Pwd=" & pwd & "; " '数据库链接 mydate = Date '下面的语句将读取数据表数据，并将它保存到excel工作表中 '定义SQL查询命令字符串 strSQL = "select c_barcode,c_pluno,c_adno,c_gcode,c_provider,c_name,c_basic_unit,c_model,c_pt_cost,c_price,c_price_mem,c_price_disc,c_comment from tb_gds where (c_gcode > '1000000001' and c_gcode < '79999999999') ORDER BY c_barcode" cn.Open strCn '与数据库建立连接，如果成功，返回连接对象cn cn.CommandTimeout = 720 rs.Open strSQL, cn '执行strSQL所含的SQL命令，结果保存在rs记录集对象中 Set sht = ThisWorkbook.Sheets("商品资料") sht.[a2:i50000].ClearContents sht.[a2:i50000].NumberFormatLocal = "@" sht.[a2].CopyFromRecordset cn.Execute(strSQL) rs.Close '关闭记录集 cn.Close '关闭数据库链接,释放资源 Set rs = Nothing '清空对象 Set cn = Nothing '清空对象 etime = Timer MsgBox "费时" & Format(etime - stime, "0.00") & "秒,更新完毕！" End Sub

参考技术A 没有错误啊，是不是你的服务器名称serIP
弄错了？？只需要填写服务器的名字就可以了，不需要加上IP的，你可以去掉前面的IP再试试，如果还是不行，你就按F8进行单步调试，看一下在哪一步骤出错的，同时将错误信息发出来，我在帮你看看

从VBA Excel 2007打开与MySQL的连接

尝试使用ODBC连接Excel和MySQL时出现此错误

未找到DataSource名称且未指定默认驱动程序

这是我的VBA代码：

Sub test123()

  ' Connection variables
  Dim conn As New ADODB.Connection
  Dim server_name As String
  Dim database_name As String
  Dim user_id As String
  Dim password As String

  ' Table action variables
  Dim i As Long ' counter
  Dim sqlstr As String ' SQL to perform various actions
  Dim table1 As String, table2 As String
  Dim field1 As String, field2 As String
  Dim rs As ADODB.Recordset
  Dim vtype As Variant

  '----------------------------------------------------------------------
  ' Establish connection to the database
  server_name = "127.0.0.1" ' Enter your server name here - if running from a local       computer use 127.0.0.1
  database_name = "smss" ' Enter your database name here
  user_id = "root" ' enter your user ID here
  password = "" ' Enter your password here

  Set conn = New ADODB.Connection
  conn.Open "DRIVER={MySQL ODBC 5.2a Driver}" _
    & ";SERVER=" & server_name _
    & ";DATABASE=" & database_name _
    & ";UID=" & user_id _
    & ";PWD=" & password _

  ' Extract MySQL table data to first worksheet in the workbook
  GoTo skipextract
  Set rs = New ADODB.Recordset
  sqlstr = "SELECT * FROM inbox" ' extracts all data
  rs.Open sqlstr, conn, adOpenStatic
  With Sheet1(1).Cells ' Enter your sheet name and range here
    .ClearContents
    .CopyFromRecordset rs
  End With
  skipextract:

End Sub

我添加了参考文献（工具参考）

ODBC驱动程序也已安装。

究竟出了什么问题？谢谢。

答案

该网站上有很多文章描述了类似的问题。特别是，在this link中有几个指针是真的。

在上面的代码中，一行特别让我觉得麻烦：

Dim conn As New ADODB.Connection

随后降低了

Set conn = New ADODB.Connection

第二个覆盖了第一个，让我感到不舒服 - 虽然我不能告诉你到底出了什么问题，除了你正在创建两个新的连接......

试试 - 以及链接文章中推荐的其他修补程序。祝好运。

另一答案

也许这可以帮助你/其他人：

将此引用添加到您的项目：Microsoft ActiveX Data对象2（或您拥有的任何更高版本）

将此代码放入模块并保存：在此模块中编辑服务器详细信息。

'---------------------------------------------------------------------------------------
' Module     : Mod_Connection
' Author     : Krish km, xkrishx.wordpress.com
' Date       : 27/08/2014
' Purpose    : use this for build mysql connectin string.
' Declaration: © Krish KM, 2014.
'            : Free to modify and re-use as long as a clear credit is made about the orgin of the code and the link above
'            : This script is distributed in the hope that it will be useful,
'            : but WITHOUT ANY WARRANTY; without even the implied warranty of
'            : MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
'            : GNU General Public License for more details.
'---------------------------------------------------------------------------------------

Option Explicit
Public ConnectionString As String
Private Const HKEY_LOCAL_MACHINE = &H80000002


Public Function GET_CURRENT_DRIVER() As String
'---------------------------------------------------------------------------------------
' Procedure : GET_CURRENT_DRIVER
' Author    : Krish km
' Date      : 27/08/2014
' Purpose   : This function returns available mysql odbc drivers found in the registry. You could search by MySQL ODBC and get the first result
'           : but I prefer prioritize the drivers i would like to yield first
'---------------------------------------------------------------------------------------
'
    If FIND_ODBC_DRIVER(GET_ODBC_DRIVER_NAMES, "MySQL ODBC 5.2 Unicode Driver") <> "" Then
        GET_CURRENT_DRIVER = "MySQL ODBC 5.2 Unicode Driver"
    ElseIf FIND_ODBC_DRIVER(GET_ODBC_DRIVER_NAMES, "MySQL ODBC 5.2w Driver") <> "" Then
        GET_CURRENT_DRIVER = "MySQL ODBC 5.2w Driver"
    Else
        GET_CURRENT_DRIVER = FIND_ODBC_DRIVER(GET_ODBC_DRIVER_NAMES, "MySQL ODBC")
    End If

End Function

Public Function GET_CONNECTION_STRING() As String
'---------------------------------------------------------------------------------------
' Procedure : GET_CONNECTION_STRING
' Author    : Krish KM
' Date      : 27/08/2014
' Purpose   : Returns MySQL connection string
'---------------------------------------------------------------------------------------
'        
    If Not ConnectionString = vbNullString Then
        GET_CONNECTION_STRING = ConnectionString
    Else

        Dim Driver As String
        Dim mDatabase As String
        Dim mServer As String
        Dim mUser As String
        Dim mPassword As String
        Dim mPort As Integer

        mDatabase = ""          ' DB name
        mServer = ""            ' Server name
        mUser = ""              ' DB user name
        mPassword = ""          ' DB user password
        mPort = 3306            ' DB port

        Driver = GET_CURRENT_DRIVER
        If Driver = "" Then
            Err.Raise 1, Err.Source, "MYSQL ODBC drivers are missing"
            Exit Function
        End If
        ConnectionString = "DRIVER={" & Driver & "};PORT=" & mPort & ";DATABASE=" & mDatabase & ";SERVER={" & mServer & "};UID=" & mUser & ";PWD={" & mPassword & "};"
        GET_CONNECTION_STRING = ConnectionString
    End If
End Function

Public Function GET_ODBC_DRIVER_NAMES()
'---------------------------------------------------------------------------------------
' Procedure : GET_ODBC_DRIVER_NAMES
' Author    : Krish KM
' Date      : 27/08/2014
' Purpose   : Checks in the registry for any odbc driver signatures and returns the collection
'---------------------------------------------------------------------------------------
'
    Dim strComputer As String, strKeyPath As String
    Dim objRegistry As Object, arrValueNames, arrValueTypes
    strComputer = "."
    strKeyPath = "SOFTWAREODBCODBCINST.INIODBC Drivers"
    Set objRegistry = GetObject("winmgmts:\" & strComputer & "
ootdefault:StdRegProv")
    objRegistry.EnumValues HKEY_LOCAL_MACHINE, strKeyPath, arrValueNames, arrValueTypes
    GET_ODBC_DRIVER_NAMES = arrValueNames
End Function

Public Function FIND_ODBC_DRIVER(ByVal iArr, ByVal sValue) As String
'---------------------------------------------------------------------------------------
' Procedure : FIND_ODBC_DRIVER
' Author    : Krish KM
' Date      : 27/08/2014
' Purpose   : Simple array function to check if a specific value exists. if yes return the value if not return empty string
'---------------------------------------------------------------------------------------
'
    FIND_ODBC_DRIVER = ""
    Dim iValue As Variant
    For Each iValue In iArr
        If iValue = sValue Then
            FIND_ODBC_DRIVER = iValue
            Exit Function
        End If
    Next
End Function

在Excel工作表按钮/宏上复制/修改此功能：根据您的request / sql调用更新SQL_GET语句。

Sub Retrieve_EMP_Details()
'---------------------------------------------------------------------------------------
' Procedure : Retrieve_EMP_Details
' Author    : Krish KM
' Date      : 27/08/2014
' Purpose   : connects to the database and retrieves employee details.
'---------------------------------------------------------------------------------------
'

    'Connection variables
    Dim conn As New ADODB.Connection
    Dim cmd As New ADODB.Command
    Dim rs As ADODB.Recordset

    'Get connection string and connect to the server
    On Error GoTo ERR_CONNECTION:
    conn.ConnectionString = GET_CONNECTION_STRING ' trap additional error if you want
    conn.Open

    'Preparing SQL Execution
    Dim SQL_GET As String
    SQL_GET = "SELECT * FROM tbl_employee" ' extracts all data

    cmd.Name = "EMPSearch"
    cmd.ActiveConnection = conn
    cmd.CommandText = SQL_GET

    'Execute SQL
    Set rs = cmd.Execute

    On Error GoTo ERR_READ_SQL
    If Not rs.EOF Then
        With Sheets(1).Cells ' Enter your sheet name and range here
            .ClearContents
            .CopyFromRecordset rs
        End With
    Else
        Sheets(1).Range("A1").value = "No records found :("

    End If

EXIT_SUB:
    On Error Resume Next
    Set conn = Nothing
    Set cmd = Nothing
    Set rs = Nothing
    Exit Sub

ERR_CONNECTION:
    MsgBox "Sorry unable to connect to the server.." & vbNewLine & "Connection string: " & GET_CONNECTION_STRING & vbNewLine & "System Msg: " & Err.Description
    GoTo EXIT_SUB

ERR_READ_SQL:
    MsgBox "Sorry unable read/wite results on the sheet.." & vbNewLine & "System Msg: " & Err.Description
    GoTo EXIT_SUB
End Sub

如果安装了ODBC驱动程序，则提供所有服务器详细信息，调整SQL语句。只执行sub_routine {Retrieve_EMP_Details}，您应该能够在表单（1）中看到结果

希望这有助于并享受:)

农业低