Copy Code code as follows:
'************************************************
' * * Function name: Exporttemplettoexcel
' * * Function function: output recordset to Excel template
' * * Parameter description:
' * * Strexcelfile the Excel file to save
' * * strSQL query statement, which is what to export
' * * strSheetName sheet name
' * * Adoconn database connection already open
' * * function returns:
' * * Boolean type
' * * True successfully exported template
' * * False failed
' * * Reference example:
' * * Call Exporttemplettoexcel (C:\\text.xls, query statement, worksheet 1,adoconn)
'************************************************
Private Function Exporttemplettoexcel (ByVal strexcelfile as String, _
ByVal strSQL as String, _
ByVal strSheetName as String, _
ByVal Adoconn as Object) as Boolean
Dim Adort as Object
Dim Lngrecordcount as Long ' number of records
Dim Intfieldcount as Integer field number
Dim Strfields as String ' all field names
Dim I as Integer
Dim exlapplication as Object ' Excel instance
Dim Exlbook as Object Excel workspace
Dim Exlsheet as Object ' Excel current worksheet to manipulate
On Error GoTo Localerr
Me.mousepointer = Vbhourglass
'//Create an ADO Recordset object
Set Adort = CreateObject (ADODB. Recordset)
With Adort
. ActiveConnection = Adoconn
. CursorLocation = 3 ' adUseClient
. CursorType = 3 ' adOpenStatic
. LockType = 1 ' adlockreadonly
. Source = strSQL
. Open
If. EOF and. BOF Then
Exporttemplettoexcel = False
Else
'//Get the total number of records, + 1 to indicate that there is also a row of field name name information
Lngrecordcount =. RecordCount + 1
Intfieldcount =. Fields.count-1
For i = 0 to Intfieldcount
'//Generate field name information (VbTab in Excel to represent the interval between each cell)
Strfields = Strfields &. Fields (i). Name & VbTab
Next
'//Remove the last VbTab tab
Strfields = left$ (Strfields, Len (strfields)-Len (VbTab))
'//Create an Excel instance
Set exlapplication = CreateObject (Excel.Application)
'//Add a workspace
Set Exlbook = ExlApplication.Workbooks.Add
'//Set the current workspace to be the first worksheet (3 by default)
Set Exlsheet = exlbook.worksheets (1)
'//change the first worksheet to the specified name
Exlsheet.name = strSheetName
'//Clear ' clipboard '
Clipboard.clear
'//Copy field name to Clipboard
Clipboard.settext Strfields
'//Select cell A1
Exlsheet.range (A1). Select
'//Paste field name
Exlsheet.paste
'//Copy recordset starting from A2
Exlsheet.range (A2). CopyFromRecordset Adort
'//Add a named range, which is the desired range at the time of import
ExlApplication.Names.Add strSheetName, = & strSheetName &! $A $1:$ & _
Ugetcolname (Intfieldcount + 1) & $ & Lngrecordcount
'//Save Excel File
Exlbook.saveas Strexcelfile
'//Exit Excel instance
Exlapplication.quit
Exporttemplettoexcel = True
End If
' adStateOpen = 1
If. State = 1 Then
. Close
End If
End With
Localerr:
'*********************************************
' * * Release all objects
'*********************************************
Set Exlsheet = Nothing
Set Exlbook = Nothing
Set exlapplication = Nothing
Set Adort = Nothing
'*********************************************
If err.number <> 0 Then
Err.Clear
End If
Me.mousepointer = Vbdefault
End Function
'//Get column name
Private Function ugetcolname (ByVal intnum as Integer) as String
Dim Strcolnames as String
Dim Strreturn as String
'//Usually the number of fields is not too much, so it's enough to 26*3 now.
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
End Function