导出到excel.frm

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

            xlSheet.Cells(r, 14) = rs!办公电话
            xlSheet.Cells(r, 15) = rs!办公传真
            xlSheet.Cells(r, 16) = rs!其他说明
            rs.MoveNext: DoEvents: Label6.Visible = True
            Label6.Caption = "正在输出：" & r & "/" & rs.RecordCount
             r = r + 1
             If StopToExcel = True Then
                Exit Do
            End If
        Loop
        Label6.Visible = False: Label5.Caption = "正在让表格的列宽自动适应文字长度 ..."
        xlSheet.Cells.EntireColumn.AutoFit     '自动调整列宽
        Label7.Caption = "任务处理完毕，处理过程结束。"
    End If
End If
If Check5.Value = 1 Then '输出本单位联系人表
    Image2.Visible = True
    Image2.Left = Check5.Left - Image2.Width - 50
    Image2.Top = Check5.Top + 30

    Label5.Caption = "正在准备写入目标 Excel 文件 ..."
    Label7.Caption = "当前任务：处理[本单位联系人信息]表。"
    Label5.Caption = "正在定义目标 Excel 文件的数据结构 ..."
    'xlApp.Visible = False '设置EXCEL对象可见（或不可见）
    If x < 4 Then
        Set xlSheet = xlBook.Worksheets(x)
        x = x + 1
    Else
        Set xlSheet = xlBook.Worksheets.Add  '设置活动工作表
    End If
    Set db = OpenDatabase(MdbPath)
    Set rs = db.OpenRecordset("select * from mycom order by 姓名")
    If rs.RecordCount > 0 Then
        rs.MoveFirst
        rs.MoveLast
    End If
    If rs.RecordCount > 0 Then
        r = 2
        rs.MoveFirst
            Label5.Caption = "正在将 联系人信息 写入到目标 Excel 文件中，请稍候 ..."
            xlSheet.Cells(1, 1) = "编号"
            xlSheet.Cells(1, 2) = "姓 名"
            xlSheet.Cells(1, 3) = "手机号码"
       Do While rs.EOF = False
            xlSheet.Cells(r, 1) = rs!id
            xlSheet.Cells(r, 2) = rs!姓名
            xlSheet.Cells(r, 3) = rs!手机号码
            rs.MoveNext: DoEvents: Label6.Visible = True
            Label6.Caption = "正在输出：" & r & "/" & rs.RecordCount
             r = r + 1
             If StopToExcel = True Then
                Exit Do
            End If
        Loop
        Label6.Visible = False: Label5.Caption = "正在让表格的列宽自动适应文字长度 ..."
        xlSheet.Cells.EntireColumn.AutoFit     '自动调整列宽
        Label7.Caption = "任务处理完毕，处理过程结束。"
    End If
End If
If Check3.Value = 1 Then '网址信息表
    Image2.Visible = True
    Image2.Left = Check3.Left - Image2.Width - 50
    Image2.Top = Check3.Top + 30

    Label5.Caption = "正在准备写入目标 Excel 文件 ..."
    Label7.Caption = "当前任务：处理[网址信息]表。"
    Label5.Caption = "正在定义目标 Excel 文件的数据结构 ..."
    'xlApp.Visible = False '设置EXCEL对象可见（或不可见）
    If x < 4 Then
        Set xlSheet = xlBook.Worksheets(x)
        x = x + 1
    Else
        Set xlSheet = xlBook.Worksheets.Add  '设置活动工作表
    End If
    Set db = OpenDatabase(MdbPath)
    Set rs = db.OpenRecordset("select * from urls")
    Dim dt As Database
    Dim rt As Recordset
    Set dt = OpenDatabase(MdbPath)

    If rs.RecordCount > 0 Then
        rs.MoveFirst
        rs.MoveLast
    End If
    If rs.RecordCount > 0 Then
        r = 2
        rs.MoveFirst
            Label5.Caption = "正在将 网址信息 写入到目标 Excel 文件中，请稍候 ..."
            xlSheet.Cells(1, 1) = "编号"
            xlSheet.Cells(1, 2) = "网址名称"
            xlSheet.Cells(1, 3) = "助记码"
            xlSheet.Cells(1, 4) = "网络地址"
            xlSheet.Cells(1, 5) = "所属类别"
            xlSheet.Cells(1, 6) = "网站性质"
            xlSheet.Cells(1, 7) = "登录用户名"
            xlSheet.Cells(1, 8) = "登录密码"
            xlSheet.Cells(1, 9) = "网站摘要"
       Do While rs.EOF = False
            xlSheet.Cells(r, 1) = rs!id
            xlSheet.Cells(r, 2) = rs!网址名称
            xlSheet.Cells(r, 3) = rs!助记码
            xlSheet.Cells(r, 4) = rs!网络地址
            Set rt = dt.OpenRecordset("select * from urlleibie where id=" & rs!所属类别)
            If rt.RecordCount = 0 Then
                xlSheet.Cells(r, 5) = "（类别定义错误。）"
            ElseIf rt.RecordCount > 0 Then
                rt.MoveLast
                rt.MoveFirst
                If rt.RecordCount = 1 Then
                    xlSheet.Cells(r, 5) = rt!所属类别
                ElseIf rt.RecordCount > 1 Then
                    xlSheet.Cells(r, 5) = "（" & rs!所属类别 & "：不唯一，数据库错误。）"
                End If
            End If
            
            Set rt = dt.OpenRecordset("select * from urlxingzhi where id=" & rs!网站性质)
            If rt.RecordCount = 0 Then
                xlSheet.Cells(r, 6) = "（性质定义错误。）"
            ElseIf rt.RecordCount > 0 Then
                rt.MoveLast
                rt.MoveFirst
                If rt.RecordCount = 1 Then
                    xlSheet.Cells(r, 6) = rt!网站性质
                ElseIf rt.RecordCount > 1 Then
                    xlSheet.Cells(r, 6) = "（" & rs!网站性质 & "：不唯一，数据库错误。）"
                End If
            End If
            xlSheet.Cells(r, 7) = rs!登录用户名
            xlSheet.Cells(r, 8) = rs!登录密码
            xlSheet.Cells(r, 9) = rs!网站摘要
            rs.MoveNext
            DoEvents
            Label6.Visible = True
            Label6.Caption = "正在输出：" & r & "/" & rs.RecordCount
            r = r + 1
            If StopToExcel = True Then
                Exit Do
            End If
        Loop
        Label6.Visible = False
        Label5.Caption = "正在让表格的列宽自动适应文字长度 ..."
        xlSheet.Cells.EntireColumn.AutoFit     '自动调整列宽
        Label7.Caption = "任务处理完毕，处理过程结束。"
    End If
End If
If Check4.Value = 1 Then '拜访记录表
    Image2.Visible = True
    Image2.Left = Check4.Left - Image2.Width - 50
    Image2.Top = Check4.Top + 30
    Label5.Caption = "正在准备写入目标 Excel 文件 ..."
    Label7.Caption = "当前任务：处理[拜访记录]表。"
    Label5.Caption = "正在定义目标 Excel 文件的数据结构 ..."
    'xlApp.Visible = False '设置EXCEL对象可见（或不可见）
    If x < 4 Then
        Set xlSheet = xlBook.Worksheets(x)
        x = x + 1
    Else
        Set xlSheet = xlBook.Worksheets.Add  '设置活动工作表
    End If
    Set db = OpenDatabase(MdbPath)
    Set rs = db.OpenRecordset("select * from baifang")
    If rs.RecordCount > 0 Then
        rs.MoveFirst
        rs.MoveLast
    End If
    If rs.RecordCount > 0 Then
        r = 2
        rs.MoveFirst
            Label5.Caption = "正在将 拜访记录 写入到目标 Excel 文件中，请稍候 ..."
            xlSheet.Cells(1, 1) = "编号"
            xlSheet.Cells(1, 2) = "受访企业"
            xlSheet.Cells(1, 3) = "拜访时间"
            xlSheet.Cells(1, 4) = "拜访人"
            xlSheet.Cells(1, 5) = "受访人"
            xlSheet.Cells(1, 6) = "备忘内容"
            
       Do While rs.EOF = False
            xlSheet.Cells(r, 1) = rs!id
            Set BFdb = OpenDatabase(MdbPath)
            Set BFrs = BFdb.OpenRecordset("select * from com where id =" & rs!企业ID号)
            If BFrs.RecordCount = 0 Then
                xlSheet.Cells(r, 2) = "（" & rs!企业ID号 & "：定义错误。）"
            ElseIf BFrs.RecordCount > 0 Then
                BFrs.MoveLast
                BFrs.MoveFirst
                If BFrs.RecordCount > 1 Then
                    xlSheet.Cells(r, 2) = "（" & rs!企业ID号 & "：定义不唯一。）"
                ElseIf BFrs.RecordCount = 1 Then
                    xlSheet.Cells(r, 2) = BFrs!企业名称
                End If
                BFrs.Close
                BFdb.Close
                Set BFrs = Nothing
                Set BFdb = Nothing
            End If
            xlSheet.Cells(r, 3) = Format(rs!拜访时间, "YYYY-MM-DD")
            xlSheet.Cells(r, 4) = rs!拜访人
            xlSheet.Cells(r, 5) = rs!受访人
            xlSheet.Cells(r, 6) = rs!内容
            rs.MoveNext: DoEvents: Label6.Visible = True
            Label6.Caption = "正在输出：" & r & "/" & rs.RecordCount
             r = r + 1
             If StopToExcel = True Then
                Exit Do
            End If
        Loop
        Label6.Visible = False: Label5.Caption = "正在让表格的列宽自动适应文字长度 ..."
        xlSheet.Cells.EntireColumn.AutoFit     '自动调整列宽
        Label7.Caption = "任务处理完毕，处理过程结束。"
    End If
End If
        
    Image2.Visible = False
    Label5.Caption = "正在保存生成的 Excel 文件的内容 ..."
    xlApp.ActiveWorkbook.SaveAs Trim(Text1.Text)
    Label5.Caption = "正在关闭目标 Excel 文件 ..."
    If Check7.Value = 1 Then
        xlBook.Close (True) '关闭工作簿
        xlApp.Quit '结束EXCEL对象
    End If
    Set xlSheet = Nothing
    Set xlBook = Nothing
    Set xlApp = Nothing '释放xlApp对象
    Command1.Enabled = True
    Text1.Enabled = True
    Label5.Caption = "目标 Excel 文件已经输出完毕。"
    
    StopToExcel = False
    Command2.Enabled = True
    Command3.Enabled = False
    Exit Sub
eee:
    xlApp.Visible = True '设置EXCEL对象可见（或不可见）
    Command1.Enabled = True
    Text1.Enabled = True
    Label5.Caption = "数据输出的过程中出现了错误，无法继续 ..."
    Label6.Caption = "错误代码：" & Err.Number & "，" & Err.Description
    Command3.Enabled = True
End Sub

Private Sub Command3_Click()
    StopToExcel = True
    Command3.Enabled = False
    Command2.Enabled = True
End Sub

Private Sub Form_Load()
    Me.Icon = MDIForm1.Icon
    h = Me.Height
    w = Me.Width
    Me.Left = (Screen.Width - Me.Width) / 2
    Me.Top = (Screen.Height - Me.Height) / 3
    '下面用于设置窗体透明
    Dim rtn As Long
    rtn = GetWindowLong(Me.hwnd, GWL_EXSTYLE) '注释：取的窗口原先的样式
    rtn = rtn Or WS_EX_LAYERED '注释：使窗体添加上新的样式WS_EX_LAYERED
    SetWindowLong Me.hwnd, GWL_EXSTYLE, rtn '注释：把新的样式赋给窗体
    SetLayeredWindowAttributes Me.hwnd, 0, 240, LWA_ALPHA
    Label6.Visible = False
    '上面用于设置窗体透明
End Sub

Private Sub Form_Resize()
    On Error GoTo ddd
    Me.Height = h
    Me.Width = w
    Exit Sub
ddd:
End Sub

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