dnf深渊补丁老马之墓:导出MSFlexGrid表格的内容到excel文件

Private Sub ShangJiaToExcel() '本函数用于导出商家列表信息
Command2.Enabled = False
On Error GoTo ddd
Label9 = "正在验证目标文件名称是否可以使用。"
If Trim(Text1.Text) = "" Then
Label9.Caption = "没有可用的目标文件名。"
Exit Sub
End If
If Right(Trim(Text1.Text), 4) <> ".xls" Then
Label9.Caption = "非法的目标文件名。"
Exit Sub
End If
If Dir(Trim(Text1.Text)) <> "" Then
MsgBox "设定的目标文件 Excel 文件已经存在，不得使用已经存在的文件的文件名。", vbInformation
Label9.Caption = "准备就绪。"
Exit Sub
End If
Label9.Caption = "正在初始化 Excel 后台工作环境。"
Dim xlApp As Excel.Application
Dim xlBook As Excel.Workbook
Dim xlSheet As Excel.Worksheet
Label9.Caption = "正在创建用于写入的 Excel 对象及工作表。"
Set xlApp = CreateObject("Excel.Application") '创建EXCEL对象
Set xlBook = xlApp.Workbooks.Add
Label9.Caption = "正在写入窗体里表格中的数据，请稍候 ..."
Label10.Caption = "正在写入数据备忘信息..."
Set xlSheet = xlBook.Worksheets(1)
xlSheet.Cells(1, 1) = "写入数据的程序的版本号："
xlSheet.Cells(1, 2) = App.Major & "." & App.Minor & "." & App.Revision & "。 本软件更新速度较快，请及时更新最新版本。"
xlSheet.Cells(2, 1) = "导出的内容："
xlSheet.Cells(2, 2) = "商家列表"
xlSheet.Cells(3, 1) = "数据的查询条件："
xlSheet.Cells(3, 2) = Label7.Caption
xlSheet.Cells(4, 1) = "导出时间："
xlSheet.Cells(4, 2) = Now()
xlSheet.Cells(5, 1) = "导出的资料条数："
xlSheet.Cells(5, 2) = Label6.Caption
xlSheet.Cells.EntireColumn.AutoFit '自动调整列宽
Set xlSheet = xlBook.Worksheets(2)
Label10.Caption = "正在写入数据..."
Dim i As Long
Dim t As Long
t = Form2.MSFlexGrid1.Cols
Dim d As Long
d = Form2.MSFlexGrid1.Rows
Dim f As Long
For f = 1 To d
For i = 1 To t
xlSheet.Cells(f, i) = Form2.MSFlexGrid1.TextMatrix(f - 1, i - 1)
DoEvents
Next i
DoEvents
Label10.Caption = "正在写入数据（" & f & " / " & d - 1 & "）"
Next f
Label10.Caption = "正在让表格的列宽自动适应文字长度 ..."
xlSheet.Cells.EntireColumn.AutoFit '自动调整列宽
Label9.Caption = "正在保存生成的 Excel 文件的内容 ..."
Label10.Caption = "数据写入完毕，正在保存文件！"
xlApp.ActiveWorkbook.SaveAs Trim(Text1.Text)
Label10.Caption = "正在关闭目标 Excel 文件 ..."
Label10.Caption = "输出执行完毕！"
Label9.Caption = "正在结束 Excel 后台工作环境。"
xlBook.Close (True) '关闭工作簿
xlApp.Quit '结束EXCEL对象Set xlSheet = Nothing
Set xlBook = Nothing
Set xlApp = Nothing '释放xlApp对象
Label9.Caption = "准备就绪。"
Command2.Enabled = True
Exit Sub
ddd:
Label9.Caption = "数据输出的过程中出现了错误，无法继续 ..."
Label10.Caption = "错误代码：" & Err.Number & "，" & Err.Description
xlApp.Visible = True
Command2.Enabled = True
End Sub
来源: 芯友网 http://www.xy-365.com 详细点击：http://www.xy-365.com/company/s_16513.htm