06毕业设计 - VB导出Excel文档

Private Sub xlsout1_Click()         '导出Excel文档
  If rs1.RecordCount < 1 Then
  MsgBox "导出失败，当前列表中没有记录!"
  outstate1.Visible = False
    Exit Sub
  End If

On Error GoTo not_installexcel '当电脑没装excel软件时的出错处理
If MsgBox(Chr(13) + "是否将当前列表中的数据导出为EXCEL数据？  ", vbQuestion + vbYesNo) = vbNo Then Exit Sub

Dim iRow, iCol As Integer
Dim iRowCount, iColCount As Integer
Dim FieldLen() '存字段长度值
Dim xlApp As Excel.Application
Dim xlBook As Excel.Workbook
Dim xlSheet As Excel.Worksheet
main.Enabled = False
outstate1.Visible = True '显示导出状态
outstate1.Caption = "正在导出，请稍后..."

Set xlApp = CreateObject("Excel.Application")
Set xlBook = xlApp.Workbooks.Add
Set xlSheet = xlBook.Worksheets(1)
With rs1
  .MoveLast
  iRowCount = .RecordCount '记录总数
  iColCount = .Fields.Count '字段总数
  ReDim FieldLen(iColCount)
  .MoveFirst
 
  '写入标头
  xlSheet.Rows(1).RowHeight = 35
  xlSheet.Range(xlSheet.Cells(1, 1), xlSheet.Cells(1, rs1.Fields.Count)).MergeCells = True
  xlSheet.Cells(1, 1).Font.Size = 14
  xlSheet.Cells(1, 1).Font.Bold = True
  If usetype = "系统管理员" Then
     xlSheet.Cells(1, 1).Value = "课时津贴明细列表"
  Else
     xlSheet.Cells(1, 1).Value = usepart & "课时津贴明细列表"
  End If
  '写入记录
  For iRow = 2 To iRowCount + 2
    For iCol = 1 To iColCount
      Select Case iRow
      Case 2 '在Excel中的第一行加标题
        xlSheet.Cells(iRow, iCol).Value = .Fields(iCol - 1).Name
      Case 3 '将数组FIELDLEN()存为第一条记录的字段长
        If IsNull(.Fields(iCol - 1)) = True Then
          FieldLen(iCol) = LenB(.Fields(iCol - 1).Name) '如果字段值为NULL,则将数组Filelen(Icol)的值设为标题名的宽度
        Else
          FieldLen(iCol) = LenB(.Fields(iCol - 1))
        End If
        If FieldLen(iCol) < LenB(.Fields(iCol - 1).Name) Then '如果字段值的长度小于标题名的宽度，则将数组Filelen(Icol)的值设为标题名的宽度
          FieldLen(iCol) = LenB(.Fields(iCol - 1).Name)
        End If
        xlSheet.Columns(iCol).ColumnWidth = FieldLen(iCol)  'Excel列宽等于字段长
        xlSheet.Cells(iRow, iCol).Value = .Fields(iCol - 1) '向Excel的CellS中写入字段值
      Case Else
        FieldLen1 = LenB(.Fields(iCol - 1))
        If FieldLen(iCol) < FieldLen1 Then
          xlSheet.Columns(iCol).ColumnWidth = FieldLen1 '表格列宽等于较长字段长
          FieldLen(iCol) = FieldLen1 '数组Fieldlen(Icol)中存放最大字段长度值
        Else
          xlSheet.Columns(iCol).ColumnWidth = FieldLen(iCol)
        End If
        xlSheet.Cells(iRow, iCol).Value = .Fields(iCol - 1)
      End Select
      DoEvents
    Next iCol
    If iRow > 2 Then
      If Not .EOF Then .MoveNext
    End If
    DoEvents
    outstate1.Caption = "正在导出，完成: " + CStr(Int(100 * (iRow - 2) / iRowCount)) + "%" '显示导出进度
  Next iRow
  '添加年月日
    xlSheet.Cells(iRowCount + 3, iColCount).Value = Format$(Now, "yyyy年mm月dd日") '在最后一行后加是年月日
    xlSheet.Range(xlSheet.Cells(iRowCount + 3, 1), xlSheet.Cells(iRowCount + 3, iColCount)).MergeCells = True '合并年月日所在的行
    xlSheet.Cells(iRowCount + 3, 1).HorizontalAlignment = xlHAlignRight '设置为右对齐
 
  With xlSheet
    .Range(.Cells(2, 1), .Cells(2, iCol - 1)).Font.Bold = True  '标题字体加粗
    .Range(.Cells(1, 1), .Cells(iRow, iCol - 1)).Borders.LineStyle = xlContinuous   '设表格边框样式
    .Columns("A:I").VerticalAlignment = xlVAlignCenter  '垂直居中
    .Range(.Cells(1, 1), .Cells(iRow - 1, iCol - 1)).HorizontalAlignment = xlHAlignCenter   '水平居中对齐
  End With
  .MoveFirst
  xlApp.Visible = True '显示表格
  Set xlApp = Nothing '交还控制给Excel
End With
outstate1.Visible = False
main.Enabled = True
Exit Sub

not_installexcel:  '当电脑没有装excel软件时的处理
    MsgBox "导出错误！请检查电脑是否装有不低于Excel2000版本的Excel软件！" & Chr(13) & Chr(10) & "然后检查一下出错处的记录是否有问题！"
    outstate1.Visible = False
    main.Enabled = True
End Sub