导出表格.frm

软件用到的技巧：透明窗体

        Command2.Enabled = True
        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
Private Sub RenToExcel() '本函数用于导出商家列表信息
Command2.Enabled = False
On Error GoTo ddde
    Label9 = "正在验证目标文件名称是否可以使用。"
    If Trim(Text1.Text) = "" Then
        Label9.Caption = "没有可用的目标文件名。"
        Command2.Enabled = True
        Exit Sub
    End If
    If Right(Trim(Text1.Text), 4) <> ".xls" Then
        Label9.Caption = "非法的目标文件名。"
        Command2.Enabled = True
        Exit Sub
    End If
    If Dir(Trim(Text1.Text)) <> "" Then
        MsgBox "设定的目标文件 Excel 文件已经存在，不得使用已经存在的文件的文件名。", vbInformation
        Label9.Caption = "准备就绪。"
        Command2.Enabled = True
        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) = Trim(Label5.Caption)
        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 = FrmShowAllRen.MSFlexGrid1.Cols
        Dim d As Long
        d = FrmShowAllRen.MSFlexGrid1.Rows
        Dim f As Long
        For f = 1 To d
            For i = 1 To t
                xlSheet.Cells(f, i) = FrmShowAllRen.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
ddde:
    Label9.Caption = "数据输出的过程中出现了错误，无法继续 ..."
    Label10.Caption = "错误代码：" & Err.Number & "，" & Err.Description
    xlApp.Visible = True
    Command2.Enabled = True
    
End Sub
Private Sub BaifangToExcel() '本函数用于导出商家列表信息
On Error GoTo ddde
    Command2.Enabled = False
    Label9 = "正在验证目标文件名称是否可以使用。"
    If Trim(Text1.Text) = "" Then
        Label9.Caption = "没有可用的目标文件名。"
        Command2.Enabled = True
        Exit Sub
    End If
    If Right(Trim(Text1.Text), 4) <> ".xls" Then
        Label9.Caption = "非法的目标文件名。"
        Command2.Enabled = True
        Exit Sub
    End If
    If Dir(Trim(Text1.Text)) <> "" Then
        MsgBox "设定的目标文件 Excel 文件已经存在，不得使用已经存在的文件的文件名。", vbInformation
        Label9.Caption = "准备就绪。"
        Command2.Enabled = True
        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) = Trim(Label5.Caption)
        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 = AllBaiFang.MSFlexGrid1.Cols
        Dim d As Long
        d = AllBaiFang.MSFlexGrid1.Rows
        Dim f As Long
        For f = 1 To d
            For i = 1 To t
                xlSheet.Cells(f, i) = AllBaiFang.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
ddde:
    Label9.Caption = "数据输出的过程中出现了错误，无法继续 ..."
    Label10.Caption = "错误代码：" & Err.Number & "，" & Err.Description
    xlApp.Visible = True
    Command2.Enabled = True
End Sub
Private Sub UrlsToExcel() '本函数用于导出商家列表信息
On Error GoTo ddde
    Command2.Enabled = False
    Label9 = "正在验证目标文件名称是否可以使用。"
    If Trim(Text1.Text) = "" Then
        Label9.Caption = "没有可用的目标文件名。"
        Command2.Enabled = True
        Exit Sub
    End If
    If Right(Trim(Text1.Text), 4) <> ".xls" Then
        Label9.Caption = "非法的目标文件名。"
        Command2.Enabled = True
        Exit Sub
    End If
    If Dir(Trim(Text1.Text)) <> "" Then
        MsgBox "设定的目标文件 Excel 文件已经存在，不得使用已经存在的文件的文件名。", vbInformation
        Label9.Caption = "准备就绪。"
        Command2.Enabled = True
        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) = Trim(Label5.Caption)
        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 = Form12.MSFlexGrid1.Cols
        Dim d As Long
        d = Form12.MSFlexGrid1.Rows
        Dim f As Long
        For f = 1 To d
            For i = 1 To t
                xlSheet.Cells(f, i) = Form12.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
ddde:
    Label9.Caption = "数据输出的过程中出现了错误，无法继续 ..."
    Label10.Caption = "错误代码：" & Err.Number & "，" & Err.Description
    xlApp.Visible = True
    Command2.Enabled = True
End Sub

Private Sub Form_Load()
    MDIForm1.Enabled = False
    Me.Icon = MDIForm1.Icon
    Me.BackColor = FormBackColor
    Label1.BackColor = Me.BackColor
    Text1.Text = ""
    Text1.Locked = True
End Sub

Private Sub Form_Unload(Cancel As Integer)
    MDIForm1.Enabled = True
End Sub