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