复制代码 代码如下:
'************************************************
'**函数名称:ExportTempletToExcel
'**函数功能:将记录集输出到Excel模板
'**参数说明:
'**strExcelFile要保存的Excel文件
'**strSQL查询语句，就是要导出哪些内容
'**strSheetName工作表名称
'**adoConn已经打开的数据库连接
'**函数返回:
'**Boolean类型
'**True成功导出模板
'**False失败
'**参考实例:
'**CallExportTempletToExcel(c:text.xls,查询语句,工作表1,adoConn)
'************************************************
PrivateFunctionExportTempletToExcel(ByValstrExcelFileAsString,_
ByValstrSQLAsString,_
ByValstrSheetNameAsString,_
ByValadoConnAsObject)AsBoolean
DimadoRtAsObject
DimlngRecordCountAsLong'记录数
DimintFieldCountAsInteger'字段数
DimstrFieldsAsString'所有字段名
DimiAsInteger
DimexlApplicationAsObject'Excel实例
DimexlBookAsObject'Excel工作区
DimexlSheetAsObject'Excel当前要操作的工作表
OnErrorGoToLocalErr
Me.MousePointer=vbHourglass
'//创建ADO记录集对象
SetadoRt=CreateObject(ADODB.Recordset)
WithadoRt
.ActiveConnection=adoConn
.CursorLocation=3'adUseClient
.CursorType=3'adOpenStatic
.LockType=1'adLockReadOnly
.Source=strSQL
.Open
If.EOFAnd.BOFThen
ExportTempletToExcel=False
Else
'//取得记录总数，+1是表示还有一行字段名名称信息
lngRecordCount=.RecordCount+1
intFieldCount=.Fields.Count-1
Fori=0TointFieldCount
'//生成字段名信息（vbTab在Excel里表示每个单元格之间的间隔）
strFields=strFields&.Fields(i).Name&vbTab
Next
'//去掉最后一个vbTab制表符
strFields=Left$(strFields,Len(strFields)-Len(vbTab))
'//创建Excel实例
SetexlApplication=CreateObject(Excel.Application)
'//增加一个工作区
SetexlBook=exlApplication.Workbooks.Add
'//设置当前工作区为第一个工作表（默认会有3个）
SetexlSheet=exlBook.Worksheets(1)
'//将第一个工作表改成指定的名称
exlSheet.Name=strSheetName
'//清除“剪切板”
Clipboard.Clear
'//将字段名称复制到“剪切板”
Clipboard.SetTextstrFields
'//选中A1单元格
exlSheet.Range(A1).Select
'//粘贴字段名称
exlSheet.Paste
'//从A2开始复制记录集
exlSheet.Range(A2).CopyFromRecordsetadoRt
'//增加一个命名范围，作用是在导入时所需的范围
exlApplication.Names.AddstrSheetName,=&strSheetName&!$A$1:$&_
uGetColName(intFieldCount+1)&$&lngRecordCount
'//保存Excel文件
exlBook.SaveAsstrExcelFile
'//退出Excel实例
exlApplication.Quit
ExportTempletToExcel=True
EndIf
'adStateOpen=1
If.State=1Then
.Close
EndIf
EndWith
LocalErr:
'*********************************************
'**释放所有对象
'*********************************************
SetexlSheet=Nothing
SetexlBook=Nothing
SetexlApplication=Nothing
SetadoRt=Nothing
'*********************************************
IfErr.Number<>0Then
Err.Clear
EndIf
Me.MousePointer=vbDefault
EndFunction
'//取得列名
PrivateFunctionuGetColName(ByValintNumAsInteger)AsString
DimstrColNamesAsString
DimstrReturnAsString
'//通常字段数不会太多，所以到26*3目前已经够了。
strColNames=A,B,C,D,E,F,G,H,I,J,K,L,M,N,O,P,Q,R,S,T,U,V,W,X,Y,Z,&_
AA,AB,AC,AD,AE,AF,AG,AH,AI,AJ,AK,AL,AM,AN,AO,AP,AQ,AR,AS,AT,AU,AV,AW,AX,AY,AZ,&_
BA,BB,BC,BD,BE,BF,BG,BH,BI,BJ,BK,BL,BM,BN,BO,BP,BQ,BR,BS,BT,BU,BV,BW,BX,BY,BZ
strReturn=Split(strColNames,,)(intNum-1)
uGetColName=strReturn
EndFunction