'********************************************** ** Function Name: EXPORTTEMPLETTOEXCEL '** Function: Output Record Set to Excel Template' ** Parameter Description: '** Street' ** STRSQL Query Statement, which is to export? ** strsheetname Worksheet Name '** Adoconn has opened database connection' ** function return: '** boolean type' ** true success export template '** false failed' ** reference instance: '** 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 'record number DIM INTFIELDCOUNT AS INTEGER 'Field DIM STRFIELDS AS STRING' All FRD DIM I AS INTEGER DIM EXLAPPLICATION AS Object 'Excel Instance DIM EXLBOOK As Object' Excel Workspace DIX EXLSHEET AS Object 'Excel Current Worksheet
On Error GoTo LocalErr Me.MousePointer = vbHourglass' // Create 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' // Number of acquisition records, there is a line 1 is a name information field name lngRecordCount = .RecordCount 1 intFieldCount = .Fields.Count - 1 for i = 0 to intfieldcount '// Generate field name information (VBTAB represents the interval between each cell in Excel) Strfields = Strfields & .fields (i) .name & vbtab next' // remove the last VBTAB Table 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 work area for the first Worksheet (3 by default) SET EXLSHEET = EXLBOOK.WORKSHEETS (1) '// convert the first work table to the specified name EXLSHEET.NAME = strsheetname' // Clear "Cut Board" Clipboard.clear ' // Copy the field name to "Clipboard" Clipboard.Settext Strfield '// Select the A1 cell exlsheet.range ("a1"). SELECT' // Paste Field Name EXLSHEET.PASTE
'// Start copying record set exlsheet.Range from A2. CopyFromRecordSet AdoT' // Add a naming range, the role is the range required for EXLApplication.names.add strsheetname, "=" & strsheetname & STRSHETNAME & "$ A $ 1:! $" & _ uGetColName (intFieldCount 1) & "$" & lngRecordCount '// save Excel files exlBook.SaveAs strExcelFile' // quit 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 = vbdefaultend function '// Get column name Private Function Ugetcolname (Byval Intnum As Integer) AS STRING DIM STRCOLNAMES The AS STRING DIM STRRETURN AS STRING '// The number of usual fields will not be too much, so 26 * 3 is now enough. 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, BZ "strreturn = split (strcolnames,", ") (intNum - 1) ugetcolname = strreturnend function
