我在本站上找到个自定义函数,可是运行不起来,
提示: 编译错误,用户定义类型未定义
我的数据环境:VB6.0+Access2003+Excel2003
==================================================
错误的位置显示:
(1)黄底黑字
Public Function ExporToExcel(strOpen As String, strAppPath As String, sFileName As String)
(2)黑底白字
xlApp As New Excel.Application
==================================================
代码如下:
(我的调用方法:Call ExporToExcel("select * from Stu", App.Path, "test.xls"))Public Function ExporToExcel(strOpen As String, strAppPath As String, sFileName As String)
'*********************************************************
'* 名称:ExporToExcel
'* 功能:导出数据到EXCEL
'* 用法:ExporToExcel(strOpen-sql查询字符串,strAppPath-文件路经,sFileName-文件名)
'*********************************************************
Dim Rs_Data As New ADODB.Recordset
On Error Resume Next
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 ExclFileName As String
Dim i As Integer
With Rs_Data
If .State = adStateOpen Then
.Close
End If
.ActiveConnection = Cn
.CursorLocation = adUseClient
.CursorType = adOpenStatic
.LockType = adLockReadOnly
.Source = strOpen
.Open
End With
With Rs_Data
If .RecordCount < 1 Then
MsgBox ("没有记录!")
Exit Function
End If
'记录总数
Irowcount = .RecordCount
'字段总数
Icolcount = .Fields.Count
End With
Set xlApp = CreateObject("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 = 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 = xlContinuous
'设表格边框样式
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
'
' ExclFileName = App.Path & "\Excel\" & Date & sFileName & ".xls"
ExclFileName = strAppPath & Date & sFileName & ".xls"
i = 1
Sign: If Dir(ExclFileName) <> "" Then
'Kill ExclFileName
'ExclFileName = App.Path & "\Excel\" & Date & sFileName & i & ".xls"
ExclFileName = strAppPath & Date & sFileName & i & ".xls"
i = i + 1
GoTo Sign
End If
' xlApp.Application.Visible = True '"交还控制给Excel
' xlApp.WindowState = xlMaximized
xlBook.SaveAs (ExclFileName)
xlApp.Quit
Set xlApp = Nothing
Set xlBook = Nothing
Set xlSheet = Nothing
Exit Function
Err_Folder:
If Err.Number = 1004 Then
MsgBox Err.Description
MkDir strAppPath
Resume
Else
Resume Next
End If
End Function我该修改哪儿,恳求各位帮忙!
提示: 编译错误,用户定义类型未定义
我的数据环境:VB6.0+Access2003+Excel2003
==================================================
错误的位置显示:
(1)黄底黑字
Public Function ExporToExcel(strOpen As String, strAppPath As String, sFileName As String)
(2)黑底白字
xlApp As New Excel.Application
==================================================
代码如下:
(我的调用方法:Call ExporToExcel("select * from Stu", App.Path, "test.xls"))Public Function ExporToExcel(strOpen As String, strAppPath As String, sFileName As String)
'*********************************************************
'* 名称:ExporToExcel
'* 功能:导出数据到EXCEL
'* 用法:ExporToExcel(strOpen-sql查询字符串,strAppPath-文件路经,sFileName-文件名)
'*********************************************************
Dim Rs_Data As New ADODB.Recordset
On Error Resume Next
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 ExclFileName As String
Dim i As Integer
With Rs_Data
If .State = adStateOpen Then
.Close
End If
.ActiveConnection = Cn
.CursorLocation = adUseClient
.CursorType = adOpenStatic
.LockType = adLockReadOnly
.Source = strOpen
.Open
End With
With Rs_Data
If .RecordCount < 1 Then
MsgBox ("没有记录!")
Exit Function
End If
'记录总数
Irowcount = .RecordCount
'字段总数
Icolcount = .Fields.Count
End With
Set xlApp = CreateObject("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 = 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 = xlContinuous
'设表格边框样式
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
'
' ExclFileName = App.Path & "\Excel\" & Date & sFileName & ".xls"
ExclFileName = strAppPath & Date & sFileName & ".xls"
i = 1
Sign: If Dir(ExclFileName) <> "" Then
'Kill ExclFileName
'ExclFileName = App.Path & "\Excel\" & Date & sFileName & i & ".xls"
ExclFileName = strAppPath & Date & sFileName & i & ".xls"
i = i + 1
GoTo Sign
End If
' xlApp.Application.Visible = True '"交还控制给Excel
' xlApp.WindowState = xlMaximized
xlBook.SaveAs (ExclFileName)
xlApp.Quit
Set xlApp = Nothing
Set xlBook = Nothing
Set xlSheet = Nothing
Exit Function
Err_Folder:
If Err.Number = 1004 Then
MsgBox Err.Description
MkDir strAppPath
Resume
Else
Resume Next
End If
End Function我该修改哪儿,恳求各位帮忙!
至少要引用两个,ADO和EXCEL
在工程--引用--选Microsoft ActiveX Data Objects 2.* Library
和Microsoft Excel *.0 Object Library
*是版本号
先整个能用的就行了,当初想着以后有时间在改好现在过两年了看者客户用的挺好也就算了呵呵你可以试试看