导出到excel.frm

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

      TabIndex        =   6
      Top             =   4635
      Width           =   6390
   End
   Begin VB.Label Label2 
      AutoSize        =   -1  'True
      BackColor       =   &H00FFF7E8&
      Caption         =   " 选择导出的内容 "
      ForeColor       =   &H00808080&
      Height          =   180
      Left            =   390
      TabIndex        =   0
      Top             =   1050
      Width           =   1440
   End
   Begin VB.Image Image1 
      Height          =   885
      Left            =   -15
      Picture         =   "导出到excel.frx":2FD6
      Top             =   -15
      Width           =   9885
   End
   Begin VB.Shape Shape1 
      BorderColor     =   &H00E0E0E0&
      Height          =   1245
      Left            =   255
      Top             =   1140
      Width           =   7080
   End
End
Attribute VB_Name = "Form17"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = False
'****************************************************************************
'人人为我，我为人人
'枕善居收藏整理
'发布日期：2007/12/24
'描    述：商务名片及客户资料管理系统 Ver 1.73
'网    站：http://www.Mndsoft.com/  (VB6源码博客)
'网    站：http://www.VbDnet.com/   (VB.NET源码博客,主要基于.NET2005)
'e-mail  ：[e-mail]
'e-mail  ：[e-mail]
'OICQ    ：88382850
'          如果您有新的好的代码别忘记给枕善居哦!
'****************************************************************************
Option Explicit
Dim h As Long
Dim w As Long
Dim xlApp As Excel.Application
Dim xlBook As Excel.Workbook
Dim xlSheet As Excel.Worksheet

Private Sub Command1_Click()
    CommonDialog1.Filter = "excel文件(*.xls)|*.xls"
    CommonDialog1.CancelError = False
    Me.CommonDialog1.ShowSave
    'MsgBox CommonDialog1.FileName
    If CommonDialog1.FileName = "" Then
        Exit Sub
    End If
    Text1.Text = Trim(CommonDialog1.FileName)
End Sub

Private Sub Command2_Click()
    If Check1.Value + Check2.Value + Check3.Value + Check4.Value + Check5.Value + Check6.Value < 1 Then
        Exit Sub
    End If
On Error GoTo eee
            Dim BFdb As Database
            Dim BFrs As Recordset

    Command1.Enabled = False
    Label5.Visible = True
    Command2.Enabled = False
    If Trim(Text1.Text) = "" Then
        Command1.Enabled = True
        Command2.Enabled = True
        Command1.SetFocus
        Exit Sub
    End If
    If Dir(Trim(Text1.Text)) <> "" Then
        MsgBox "设定的目标文件 Excel 文件已经存在，不得使用已经存在的文件的文件名。", vbInformation
        Command1.Enabled = True
        Command2.Enabled = True
        Exit Sub
    End If
    Command3.Enabled = True
    Dim x As Integer
    x = 1
    Set xlApp = CreateObject("Excel.Application") '创建EXCEL对象
    Label5.Caption = "目标 Excel 对象已经创建 ..."
    If Check7.Value = 0 Then
        xlApp.Visible = True
    End If
    'xlApp.Visible = False '设置EXCEL对象可见（或不可见）
    Set xlBook = xlApp.Workbooks.Add
    'Set xlSheet = xlBook.Worksheets.Add  '设置活动工作表
If Check1.Value = 1 Then '单位信息
    Image2.Visible = True
    Image2.Top = Check1.Top + 30
    Image2.Left = Check1.Left - Image2.Width - 50
    Label5.Caption = "正在准备写入目标 Excel 文件 ..."
    Label7.Caption = "当前任务：处理[单位信息]表。"
    Label5.Caption = "正在定义目标 Excel 文件的数据结构 ..."
    If x < 4 Then
        Set xlSheet = xlBook.Worksheets(x)
        x = x + 1
    Else
        Set xlSheet = xlBook.Worksheets.Add  '设置活动工作表
    End If
    Dim db As Database
    Dim rs As Recordset
    Set db = OpenDatabase(MdbPath)
    Set rs = db.OpenRecordset("select * from com")
    If rs.RecordCount > 0 Then
        rs.MoveFirst
        rs.MoveLast
    End If
    If rs.RecordCount > 0 Then
        Dim r, i As Long
        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) = "邮政编码"
            xlSheet.Cells(1, 10) = "企业地址"
            xlSheet.Cells(1, 11) = "企业网站地址"
            xlSheet.Cells(1, 12) = "企业经营范围"
        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!企业性质
            xlSheet.Cells(r, 5) = rs!企业行业
            xlSheet.Cells(r, 6) = rs!企业电话
            xlSheet.Cells(r, 7) = rs!企业传真
            xlSheet.Cells(r, 8) = rs!法人代表
            xlSheet.Cells(r, 9) = rs!邮政编码
            xlSheet.Cells(r, 10) = rs!企业地址
            xlSheet.Cells(r, 11) = rs!企业网址
            If IsNull(rs!经营范围) = False Then
                If Len(Trim(rs!经营范围)) > 820 Then
                    xlSheet.Cells(r, 12) = Left(rs!经营范围, 800) & "(*：此处原文过长，只导出前800字符。）"
                Else
                    xlSheet.Cells(r, 12) = Trim(rs!经营范围)
                End If
            Else
                xlSheet.Cells(r, 12) = ""
            End If
            rs.MoveNext

            DoEvents
            Label6.Visible = True
            Label6.Caption = "正在输出：" & r & "/" & rs.RecordCount
             r = r + 1
             If StopToExcel = True Then
                Exit Do
            End If
        Loop
        rs.Close
        db.Close
        
        Label6.Visible = False
        Label5.Caption = "正在让表格的列宽自动适应文字长度 ..."
        xlSheet.Cells.EntireColumn.AutoFit     '自动调整列宽
        Label7.Caption = "任务处理完毕，处理过程结束。"
    End If
End If
If Check2.Value = 1 Then '[联系人信息]表
    Image2.Visible = True
    Image2.Left = Check2.Left - Image2.Width - 50
    Image2.Top = Check2.Top + 30

    Label5.Caption = "正在准备写入目标 Excel 文件 ..."
    Label7.Caption = "当前任务：处理[联系人信息]表。"
    Label5.Caption = "正在定义目标 Excel 文件的数据结构 ..."
    'xlApp.Visible = False '设置EXCEL对象可见（或不可见）
    
    'x = x + 1
    'Set xlSheet = xlBook.Worksheets(x)
    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 ren 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) = "助记码"
            xlSheet.Cells(1, 4) = "性别"
            xlSheet.Cells(1, 5) = "(企业编号)所属企业名称"
            xlSheet.Cells(1, 6) = "手机号码"
            xlSheet.Cells(1, 7) = "小灵通号码"
            xlSheet.Cells(1, 8) = "QQ号码"
            xlSheet.Cells(1, 9) = "电子信箱"
            xlSheet.Cells(1, 10) = "家庭电话"
            xlSheet.Cells(1, 11) = "家庭地址"
            xlSheet.Cells(1, 12) = "所在部门"
            xlSheet.Cells(1, 13) = "担任职务"
            xlSheet.Cells(1, 14) = "办公电话"
            xlSheet.Cells(1, 15) = "办公传真"
            xlSheet.Cells(1, 16) = "其他说明"
        Do While rs.EOF = False
            xlSheet.Cells(r, 1) = rs!id
            'xlSheet.Cells(r, 2) = rs!姓名
                'If Len(Trim(rs!姓名)) = 2 Then
                '    xlSheet.Cells(r, 2) = Left(Trim(rs!姓名), 1) & "  " & Right(Trim(rs!姓名), 1)
                'Else
                    xlSheet.Cells(r, 2) = rs!姓名
                'End If
            xlSheet.Cells(r, 3) = rs!助记码
            'xlSheet.Cells(r, 4) = rs!性别
                If IsNull(rs!性别) <> True Then
                    If rs!性别 = 0 Then
                        xlSheet.Cells(r, 4) = ""
                    ElseIf rs!性别 = 1 Then
                        xlSheet.Cells(r, 4) = "男"
                    ElseIf rs!性别 = 2 Then
                        xlSheet.Cells(r, 4) = "女"
                    Else
                        xlSheet.Cells(r, 4) = ""
                    End If
                Else
                    xlSheet.Cells(r, 4) = ""
                End If
            'xlSheet.Cells(r, 5) = rs!所属企业
                Dim dd As Database
                Dim rr As Recordset
                Set dd = OpenDatabase(MdbPath)
                Set rr = db.OpenRecordset("select 企业名称 from com where id =" & rs!所属企业)
                If rr.RecordCount < 1 Then
                    xlSheet.Cells(r, 5) = "（没有找到相应的企业）"
                    rr.Close
                    dd.Close
                    
                ElseIf rr.RecordCount > 0 Then
                    rr.MoveLast
                    rr.MoveFirst
                    If rr.RecordCount > 1 Then
                        xlSheet.Cells(r, 5) = "（ID：" & rs!所属企业 & "）" & "所属企业不唯一，数据库错误）"
                        rr.Close
                        dd.Close
                    ElseIf rr.RecordCount = 1 Then
                        xlSheet.Cells(r, 5) = "（ID：" & rs!所属企业 & "）" & rr!企业名称
                        rr.Close
                        dd.Close
                    End If
                End If
            xlSheet.Cells(r, 6) = rs!手机号码
            xlSheet.Cells(r, 7) = rs!小灵通
            xlSheet.Cells(r, 8) = rs!QQ号码
            xlSheet.Cells(r, 9) = rs!电子信箱
            xlSheet.Cells(r, 10) = rs!家庭电话
            xlSheet.Cells(r, 11) = rs!家庭地址
            xlSheet.Cells(r, 12) = rs!部门
            xlSheet.Cells(r, 13) = rs!职务