vb程程序，导出到EXCEL的有关问题

vb程程序，导出到EXCEL的问题
大家好，我想把datagrid中显示的记录的记录导出到excel
我在module模块中加入以下代码
Public ExcelApp As Excel.Application
Public ExcelBook As Excel.Workbook
Public ExcelSheet As Excel.Worksheet
Public IsOpen As Integer

'取值
Public Function GetExcelKey(r As Long, c As Long) As String
On Error GoTo SysErr

GetExcelKey = ExcelSheet.Cells(r, c)

Exit Function
SysErr:
MsgBox Error, vbInformation + vbOKOnly, ""

End Function
'设置背景颜色
Public Sub SetExcelColor(r As Long, c As Long, Color As Long)
On Error GoTo SysErr

ExcelSheet.Cells(r, c).Interior.ColorIndex = Color

Exit Sub
SysErr:
MsgBox Error, vbInformation + vbOKOnly, ""
End Sub
'赋值
Public Sub SetExcelKey(r As Long, c As Long, str As String)

On Error GoTo SysErr

ExcelSheet.Cells(r, c) = str

Exit Sub
SysErr:
MsgBox Error, vbInformation + vbOKOnly, ""
End Sub

'打开一个excel文档
Public Function OpenExcel(Fn As String) As Integer

On Error GoTo SysErr

Set ExcelApp = CreateObject("excel.application")
ExcelApp.Visible = False
ExcelApp.SheetsInNewWorkbook = 1

If Dir(Fn, vbDirectory) <> "" Then
Set ExcelBook = ExcelApp.Workbooks.Open(Fn)
Else
Set ExcelBook = ExcelApp.Workbooks.Add
End If
Set ExcelSheet = ExcelBook.Worksheets(1)

IsOpen = 1
OpenExcel = 0
Exit Function

SysErr:
IsOpen = 0
OpenExcel = 1
MsgBox Error, vbInformation + vbOKOnly, "打开excel"
End Function
'保存当前文档
Public Sub SaveExcel()
On Error GoTo SysErr
If IsOpen = 0 Then Exit Sub
ExcelBook.Save

Exit Sub
SysErr:
MsgBox Error, vbInformation + vbOKOnly, ""
End Sub
'另存为当前文档
Public Sub SaveAsExcel(NewFn As String)
On Error GoTo SysErr
If IsOpen = 0 Then Exit Sub
ExcelBook.SaveAs NewFn

Exit Sub
SysErr:
MsgBox Error, vbInformation + vbOKOnly, ""

End Sub
'关闭excel 文档
Public Sub QuitExcel()
On Error GoTo SysErr
IsOpen = 0
ExcelBook.Close
ExcelApp.Quit
Set ExcelApp = Nothing
Set ExcelBook = Nothing

Exit Sub
SysErr:
MsgBox Error, vbInformation + vbOKOnly, ""

End Sub

之后在窗体的按钮中加入以下调用代码
OpenExcel App.Path & "\发票表.xls" '打开模板如果没有找到模板会新建一个xls空文档
SetExcelKey rr, cc, "内容" ' rr行、cc列写入内容'结束操作
SaveAsExcel App.Path
QuitExcel '关闭文档

在 SetExcelKey rr, cc, "内容" ' rr行、cc列写入内容这里提示：ByRef argument type mismatch的错误，
应该怎么调用啊，谢谢

------解决方案--------------------
rr,cc没有定义，SetExcelKey 已经声明rr,cc应为Long,所以会报错，在SetExcelKey rr, cc, "内容" 前面加上：
Dim rr as Long,cc As Long
rr=...
cc=...
------解决方案--------------------
我一直使用的datagrid控件导出excel过程

VB code

'导出
Private Sub LoadExport()

If picView.Visible = False Then LoadView

Dim xlApp     As New Excel.Application
Dim xlBook     As Excel.Workbook
Dim xlSheet     As Excel.Worksheet
Dim xlQuery     As Excel.QueryTable

Set xlBook = xlApp.Workbooks().Add
Set xlSheet = xlBook.Worksheets("sheet1")
Set xlQuery = xlSheet.QueryTables.Add(rsLoadAdd, xlSheet.Range("a1 "))

With xlQuery
        .FieldNames = True
        .RowNumbers = False
        .FillAdjacentFormulas = False
        .PreserveFormatting = True
        .RefreshOnFileOpen = False
        .BackgroundQuery = True
        .RefreshStyle = xlInsertDeleteCells
        .SavePassword = True
        .SaveData = True
        .AdjustColumnWidth = True
        .RefreshPeriod = 0
        .PreserveColumnInfo = True
End With

xlQuery.FieldNames = True
xlQuery.Refresh
cmdlg.Flags = 2
cmdlg.Filter = "EXCEL文档(*.xls)"
cmdlg.ShowSave

If cmdlg.FileName <> "" Then
    xlApp.DisplayAlerts = False
    xlBook.SaveAs FileName:=cmdlg.FileName

    If MsgBox("导出成功,是否打开查看?", vbOKCancel, "导出EXCEL") = vbOK Then
        xlApp.Workbooks().Open cmdlg.FileName
        xlApp.Visible = True
    Else
        xlApp.Quit
    End If
End If
If xlApp <> Null Then Set xlApp = Nothing

End Sub

vb程程序，导出到EXCEL的有关问题

相关推荐