Question

arcgis直接用vba连接数据库输出excel，报错

Private Sub UIButtonControl1_Click()
Dim pDocument As IDocument
Dim pVBProject As VBProject
Dim strPath As String
Set pDocument = ThisDocument
Set pVBProject = pDocument.VBProject
strPath = pVBProject.FileName
strPath = Mid(strPath, 1, InStrRev(strPath, "\"))
Call ExporToExcel(strPath & "\..\..\..\data")

End Sub

Public Function ExporToExcel(ByVal strPath As String) As Boolean
Dim adoConn As New ADODB.Connection
Dim Rs_Data1 As New ADODB.Recordset
Dim xlApp As New Excel.Application
Dim xlBook As New Excel.Workbook
Dim xlSheet1 As New Excel.Worksheet
Dim strSQL As String
Dim lngRow As Long
Dim lngCol As Long
Dim lngTag As Long
On Error GoTo ErrorHandler
'打开一个数据库连接
adoConn.Open "[PROVIDER=MSDASQL.1];DRIVER=Microsoft Visual FoxPro

strSQL = "SELECT * FROM spcs27;"
'打开一个记录集
Rs_Data1.Open strSQL, adoConn, adOpenStatic, adLockReadOnly
xlApp.Visible = False
'新建一个Excel 对像
Set xlApp = CreateObject("Excel.Application")
'设置Sheet 的个数
xlApp.SheetsInNewWorkbook = 1
Set xlBook = xlApp.Workbooks().Add
Set xlSheet1 = xlBook.Worksheets("sheet1")
'重命名Sheet1
xlSheet1.Name = "spcs27"
'Excel 不可见
xlApp.Visible = False
If Not IsNull(Rs_Data1) Then
lngTag = 1
lngRow = 2
While Not Rs_Data1.EOF
If lngTag = 1 Then
For lngCol = 0 To Rs_Data1.Fields.Count – 1
'将Recordset 的字段名称写入Sheet 的单元格中
xlSheet1.Cells(1, lngCol + 1) = Rs_Data1.Fields(lngCol).Name
Next lngCol
lngTag = lngTag + 1
End If
If lngTag > 1 Then
For lngCol = 0 To Rs_Data1.Fields.Count – 1
'将Recordset 的字段值写入Sheet 的单元格中
xlSheet1.Cells(lngRow, lngCol + 1) = Rs_Data1.Fields(lngCol).Value
Next lngCol
End If
Rs_Data1.MoveNext
lngRow = lngRow + 1

Wend
End If
'Excel 可见
xlApp.Visible = True
'清除对像变量
Set xlApp = Nothing
Set xlBook = Nothing
Set xlSheet1 = Nothing
Rs_Data1.Close
Set Rs_Data1 = Nothing
ExporToExcel = True
Exit Function
ErrorHandler:
'出错处理
ExporToExcel = False
MsgBox Err.Description
End Function

• 你的回答被采纳后将获得：
• 系统奖励15（财富值+成长值）+难题奖励30（财富值+成长值）

Answer 1

红色的地方弄到一行上