复制代码 代码如下:

'************************************************

'**函数名称: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