导出网格DataGrid数据到Excel

代码虽然很垃圾，但希望大家从上面学到的是技术。呵呵。

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 "数据为空，不能导出!"
     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  '添加一个新的BOOK
    Set xlSheet = xlBook.Worksheets.Add  '添加一个新的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 '已经使用过的行
    beginRow = 6
    Irowcount = rs.RecordCount
    Icolcount = dgrid.Columns.Count
   
    Dim Datas() As String
    With dgrid
       '写内容
       '开始写DataGrid数据
       ReDim Datas(Irowcount, Icolcount)
         rs.MoveFirst
        For i = 1 To Irowcount + 1
            Select Case i
              Case 1:
                 'start 初始化工作表与写入表头
                 K = 0
                 For j = 0 To Icolcount - 1
                     If .Columns(j).Visible = True And .Columns(j).Width > 30 Then
                      K = K + 1
                         xlSheet.Columns(K).Font.Size = 10
                         xlSheet.Columns(K).VerticalAlignment = xlVAlignCenter  '垂直居中
                         xlSheet.Columns(K).ColumnWidth = .Columns(j).Width / 100
                         Select Case .Columns(j).Alignment
                            Case dbgRight:
                                xlSheet.Columns(K).HorizontalAlignment = 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
                  'end  －－－－－
              Case Else:
                 K = 0
                 Dim tempVal As String '值
                 Dim tempFmt As String '格式
                 For j = 0 To Icolcount - 1
                   If .Columns(j).Visible = True And .Columns(j).Width > 30 Then
                     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", "是", "否")
                     Else
                        Datas(i - 2, K) = Format(rs(dgrid.Columns(j).DataField) & "", dgrid.Columns(j).NumberFormat)
                     End If
                     K = K + 1
                   End If
                  Next j
                  rs.MoveNext
                End Select
         Next i
      End With
      '结束写DataGrid数据
     'xlApp.Visible = True
    If titleStr <> "" Then
     '写标题
        With xlSheet.Range(xlSheet.Cells(1, 1), xlSheet.Cells(4, ActualCols))
            .HorizontalAlignment = xlCenter
            .VerticalAlignment = xlCenter
            .MergeCells = True
            .Font.Name = "黑体"
            .Font.Bold = True
            .Font.Size = 25
            .Borders.LineStyle = xlContinuous
            .Value = titleStr
        End With
    End If
    If secStr <> "" Then
    '写时间及副标题行
        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
      '写数据尾
            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
      '结束写Excel
      Screen.MousePointer = vbDefault
     Exit Sub
Err_Proc:
    Screen.MousePointer = vbDefault
    MsgBox err.Description, vbExclamation, "提示"
    Set dgrid.DataSource = rs
End Sub