Although the code is very rubbish, I hope that everyone will learn from above. Ha ha.
Public Sub Export (rs As ADODB.Recordset, dgrid As DataGrid, Optional titleStr As String, Optional secStr As String, Optional lastStr As String) On Error Resume Next If rs.RecordCount <= 0 Then MsgBox "data is empty, you can not be derived! "Exit Sub End If Dim xlApp As new Excel.Application Dim xlBook As new Excel.Workbook Dim xlSheet As new Excel.Worksheet Dim rsnew As new ADODB.Recordset Set xlBook = xlApp.Workbooks.Add 'add a new BOOK Set xlSheet = xlBook.Worksheets.Add 'add a new SHEET xlApp.Visible = False Screen.MousePointer = vbHourglass On Error GoTo Err_Proc Dim Irowcount, Icolcount, ActualCols As Long Dim i As Long Dim j As Long Dim K As Long Dim beginRow As Long' Already used BEGINROW = 6 irowcount = rs.recordcount iColcount = DGRID.COLUMNS.COUNT DIM DATAS () AS STRING WITH DGRID 'Write content' Start Write DataGrid Data Redim Data (IROWCOUNT, ICOLCOUNT) rs.MoveFirst for i = 1 To irowcount 1 Select Case I Case 1: 'Start Initialization Worksheet and Writing Head K = 0 for J = 0 To Icolcount - 1 if .columns (j) .visible = true and .columns (j) .width> 30 TEN K = K 1 Xlsheet.columns (k) .font.size = 10 xlsheet.columns (k) .vertagelignment = xlvaligncenter 'vertical hidden xlsheet.columns (k) .ColumnWidth = .columns (j) .Width / 100 select case .columns (j) .Alignment case dbgright: xlsheet.columns (k) .hizontalalignment =
xlRight Case dbgLeft: xlSheet.Columns (K) .HorizontalAlignment = xlLeft Case Else xlSheet.Columns (K) .HorizontalAlignment = xlCenter End Select xlSheet.Cells (beginRow, K) .Value = .Columns (j) .Caption End If Next j BeginRow = BeginRow 1 actualcols = k = 0 DIM TEMPVAL AS STRING 'FOR TEMPFMT AS STRING' Format for J = 0 to icolcount - 1 if .columns (j) .visible = True and .Columns (j) .width> 30 TEMPFMT = DGRID.COLUMNS (J) .Numberformat Tempval = RS (DGrid.columns (j) .datafield & "If ucase (tempval) =" True "or ucase Tempval = "false" then Datas (i - 2, k) = IIF (ucase (Tempval) = "true", "Yes", "No" ELSE DATAS (I - 2, K) = Format (RS (DGrid.columns (j) .datafield ) & "", dgrid.columns (j) .numberformat) end if k = k 1 end if next j qs.movenext End Select Next I end with 'end writing DataGrid data' xlapp.visible = true if titlestr <> "THEN '
Write the title with xlsheet.Range (xlsheet.cells (1, 1), xlsheet.cells (4, actualcols)). Horizontalalignment = XlCenter .verticalALIGNMENT = XLCenter .mergecells = true .font.name = "black body" .font.bold = True .font.size = 25 .borders.LineStyle = Xlcontinuous .value = Titlestr End with end ifness = titlestr End with end ififfstr <> "" The 'Write time and subtitle line with xlsheet.range (xlsheet.cells (5, 1), Xlsheet. Cells (5, ActualCols)) .HorizontalAlignment = xlLeft .VerticalAlignment = xlBottom .MergeCells = True .Borders.LineStyle = xlContinuous .Value = secStr End With End If With xlSheet.Range (xlSheet.Cells (6, 1), xlSheet.Cells (6, ActualCols)) .Borders.LineStyle = xlContinuous End With xlApp.Visible = True With xlSheet.Range (xlSheet.Cells (beginRow, 1), xlSheet.Cells (Irowcount beginRow - 1, ActualCols)) .Value = Datas .Borders.LineStyle = xlContinuous End With beginRow = beginRow Irowcount If lastStr <> "" Then 'Write Data End With xlSheet.Range (xlSheet.Cells (beginRow, 1), xlSheet.Cells (beginRow, ActualCols)) .HorizontalAlignment = xlLeft .VerticalAlignment = xlBottom .MergeCells = True .Borders.LineStyle = xlContinuous .Value = lastStr end With end If 'end write Excel Screen.MousePointer = vbDefault Exit SubErr_Proc: Screen.MousePointer =
