VB导出EXECL提示无效的过程调用或参数
Public Function SJDC(RSrecord As ADODB.Recordset)On Error GoTo Err1
Dim Rs_Data As New ADODB.Recordset
'Dim conn As ADODB.Connection
Dim Irowcount As Integer
Dim Icolcount As Integer
'Dim xlApp As New Excel.Application
' Dim xlBook As Excel.Workbook
' Dim xlSheet As Excel.Worksheet
' Dim xlQuery As Excel.QueryTable
Dim xlApp As Object
Dim xlBook As Object
Dim xlSheet As Object
Dim xlQuery As Object
' 假设Rs_Data 是你的记录集
With RSrecord
If .RecordCount < 1 Then
MsgBox "没有可导出的记录! ", vbInformation + vbOKOnly, "提示 "
Exit Function
End If
'记录总数
Irowcount = .RecordCount
'字段总数
Icolcount = .fields.Count
End With
'Set conn = New ADODB.Connection
'conn.Open "Provider=SQLOLEDB.1;Persist Security Info=False;User ID=sa;password=123;Initial Catalog=UFDATA_997_2011;Data Source=192.168.188.128;Use Procedure for Prepare=1;Auto Translate=True;Packet Size=4096;Workstation ID=XZL;Use Encryption for Data=False;Tag with column collation when possible=False"
Rs_Data.open RSrecord.Source, pobjConn, adOpenStatic
Set xlApp = CreateObject("Excel.Application")
' Set xlApp = New Excel.Application
Set xlBook = Nothing
Set xlSheet = Nothing
Set xlBook = xlApp.Workbooks().Add
Set xlSheet = xlBook.Worksheets("sheet1")
xlApp.Visible = True
'添加查询语句,导入EXCEL数据
Set xlQuery = xlSheet.QueryTables.Add(Rs_Data, xlSheet.Range("A1")) 就是到这行出的、错
With xlQuery
.FieldNames = True
.RowNumbers = False
.FillAdjacentFormulas = False
.PreserveFormatting = True
.RefreshOnFileOpen = False
.BackgroundQuery = True
.RefreshStyle = 1 'xlInsertDeleteCells
.SavePassword = True
.SaveData = True
.AdjustColumnWidth = True
.RefreshPeriod = 0
.PreserveColumnInfo = True
End With
xlQuery.FieldNames = True '显示字段名
xlQuery.Refresh
With xlSheet
.Range(.Cells(1, 1), .Cells(1, Icolcount)).Font.Name = "宋体" '设标题为黑体字
.Range(.Cells(1, 1), .Cells(1, Icolcount)).Font.Bold = True '标题字体加粗
.Range(.Cells(1, 1), .Cells(Irowcount + 1, Icolcount)).Borders.LineStyle = 1 'xlContinuous '设表格边框样式
' .PageSetup.PaperSize = xlPaperA4
' ' .PageSetup.PrintGridlines = True
End With
' With xlSheet.PageSetup
' .LeftHeader = " " & Chr(10) & "& " "楷体_GB2312,常规 " "&10公司名称: "
' & Gsmc
' .CenterHeader = "& " "楷体_GB2312,常规 " "公司人员情况表& " "宋体,常规 " " " & Chr(10) & "& " "楷体_GB2312,常规 " "&10日 期: "
' .RightHeader = " " & Chr(10) & "& " "楷体_GB2312,常规 " "&10单位: "
' .LeftFooter = "& " "楷体_GB2312,常规 " "&10制表人: "
' .CenterFooter = "& " "楷体_GB2312,常规 " "&10制表日期: "
' .RightFooter = "& " "楷体_GB2312,常规 " "&10第&P页 共&N页 "
' End With
xlApp.Application.Visible = True
Rs_Data.Close
' conn.Close
' xlApp.SaveWorkspace "c:\错误文件.xls"
Set xlApp = Nothing ' "交还控制给Excel
Set xlBook = Nothing
Set xlSheet = Nothing
Set Rs_Data = Nothing
' Set conn = Nothing
Exit Function
Err1: MsgBox Error & ",Excel 未安装! "
End Function --------------------编程问答-------------------- 不一定根代码有关系,EXCEL表是否规范。
补充:VB , 基础类