【转贴】如何实现VB与EXCEL的无缝连接

细履平沙

作者:吴刚··yesky

　　VB是常用的应用软件开发工具之一，由于VB的报表功能有限，而且一但报表格式发生变化，就得相应修改程序，给应用软件的维护工作带来极大的不便。因此有很多程序员现在已经充分利用EXECL的强大报表功来实现报表功能。但由于VB与EXCEL由于分别属于不同的应用系统，如何把它们有机地结合在一起，是一个值得我们研究的课题。

一、 VB读写EXCEL表：

VB本身提自动化功能可以读写EXCEL表，其方法如下：

1、在工程中引用Microsoft Excel类型库：

从"工程"菜单中选择"引用"栏；选择Microsoft Excel 9.0 Object Library（EXCEL2000），然后选择"确定"。表示在工程中要引用EXCEL类型库。

2、在通用对象的声明过程中定义EXCEL对象：

Dim xlApp As Excel.Application
Dim xlBook As Excel.WorkBook
Dim xlSheet As Excel.Worksheet

3、在程序中操作EXCEL表常用命令：

Set xlApp = CreateObject("Excel.Application") '创建EXCEL对象
Set xlBook = xlApp.Workbooks.Open("文件名") '打开已经存在的EXCEL工件簿文件
xlApp.Visible = True '设置EXCEL对象可见（或不可见）
Set xlSheet = xlBook.Worksheets("表名") '设置活动工作表
xlSheet.Cells(row, col) =值 '给单元格（row,col）赋值
xlSheet.PrintOut '打印工作表
xlBook.Close (True) '关闭工作簿
xlApp.Quit '结束EXCEL对象
Set xlApp = Nothing '释放xlApp对象
xlBook.RunAutoMacros (xlAutoOpen) '运行EXCEL启动宏
xlBook.RunAutoMacros (xlAutoClose) '运行EXCEL关闭宏

4、在运用以上VB命令操作EXCEL表时，除非设置EXCEL对象不可见，否则VB程序可继续执行其它操作，也能够关闭EXCEL，同时也可对EXCEL进行操作。但在EXCEL操作过程中关闭EXCEL对象时，VB程序无法知道，如果此时使用EXCEL对象，则VB程序会产生自动化错误。形成VB程序无法完全控制EXCEL的状况，使得VB与EXCEL脱节。

二、 EXCEL的宏功能：

　　EXCEL提供一个Visual Basic编辑器，打开Visual Basic编辑器，其中有一工程属性窗口，点击右键菜单的"插入模块"，则增加一个"模块1"，在此模块中可以运用Visual Basic语言编写函数和过程并称之为宏。其中，EXCEL有两个自动宏：一个是启动宏（Sub Auto_Open()），另一个是关闭宏（Sub Auto_Close()）。它们的特性是：当用EXCEL打含有启动宏的工簿时，就会自动运行启动宏，同理，当关闭含有关闭宏的工作簿时就会自动运行关闭宏。但是通过VB的自动化功能来调用EXCEL工作表时，启动宏和关闭宏不会自动运行，而需要在VB中通过命令xlBook.RunAutoMacros (xlAutoOpen)和xlBook.RunAutoMacros (xlAutoClose) 来运行启动宏和关闭宏。

三、 VB与EXCEL的相互勾通：

充分利用EXCEL的启动宏和关闭宏，可以实现VB与EXCEL的相互勾通，其方法如下：

　　在EXCEL的启动宏中加入一段程序，其功能是在磁盘中写入一个标志文件，同时在关闭宏中加入一段删除此标志文件的程序。VB程序在执行时通过判断此标志文件存在与否来判断EXCEL是否打开，如果此标志文件存在，表明EXCEL对象正在运行，应该禁止其它程序的运行。如果此标志文件不存在，表明EXCEL对象已被用户关闭，此时如果要使用EXCEL对象运行，必须重新创建EXCEL对象。
四、举例：

　　1、在VB中，建立一个FORM，在其上放置两个命令按钮，将Ｃommand1的Caption属性改为EXCEL，Command2的Caption属性改为End。然后在其中输入如下程序：

Dim xlApp As Excel.Application '定义EXCEL类
Dim xlBook As Excel.Workbook '定义工件簿类
Dim xlsheet As Excel.Worksheet '定义工作表类
Private Sub Command1_Click() '打开EXCEL过程
　If Dir("D:\temp\excel.bz") = "" Then '判断EXCEL是否打开
　　Set xlApp = CreateObject("Excel.Application") '创建EXCEL应用类
　　xlApp.Visible = True '设置EXCEL可见
　　Set xlBook = xlApp.Workbooks.Open("D:\temp\bb.xls") '打开EXCEL工作簿
　　Set xlsheet = xlBook.Worksheets(1) '打开EXCEL工作表
　　xlsheet.Activate '激活工作表
　　xlsheet.Cells(1, 1) = "abc" '给单元格1行驶列赋值
　　xlBook.RunAutoMacros (xlAutoOpen) 运行EXCEL中的启动宏
　Else
　　MsgBox ("EXCEL已打开")
　End If
End Sub

Private Sub Command2_Click()
　If Dir("D:\temp\excel.bz") <> "" Then '由VB关闭EXCEL
　　xlBook.RunAutoMacros (xlAutoClose) '执行EXCEL关闭宏
　　xlBook.Close (True) '关闭EXCEL工作簿　
　　xlApp.Quit '关闭EXCEL
　End If
　Set xlApp = Nothing '释放EXCEL对象
　End
End Sub


　　2、在Ｄ盘根目录上建立一个名为Temp的子目录，在Temp目录下建立一个名为"bb.xls"的EXCEL文件。

　　3、在"bb.xls"中打开Visual Basic编辑器，在工程窗口中点鼠标键选择插入模块，在模块中输入入下程序存盘：


Sub auto_open()
　Open "d:\temp\excel.bz" For Output As #1 '写标志文件
　Close #1
End Sub
Sub auto_close()
　Kill "d:\temp\excel.bz" '删除标志文件
End Sub

　　4、运行VB程序，点击EXCEL按钮可以打开EXCEL系统，打开EXCEL系统后，VB程序和EXCEL分别属两个不同的应用系统，均可同时进行操作，由于系统加了判断，因此在VB程序中重复点击EXCEL按钮时会提示EXCEL已打开。如果在EXCEL中关闭EXCEL后再点EXCEL按钮，则会重新打开EXCEL。而无论EXCEL打开与否，通过VB程序均可关闭EXCEL。这样就实现了VB与EXCEL的无缝连接。

细履平沙

作者:mi6236 的 Blog  
关键字   VB中使用EXCEL输出  
Private Sub cmdSwatch_Click()
Dim xls As excel.Application
Dim xlbook As excel.Workbook
'On Error GoTo exlError
Dim i As Integer
    If Dir(Text1.Text) <> "" Then '此目录下如有同名文件给出提示,并作相应处理
        If MsgBox("文件已存在，是否覆盖！", vbYesNo + vbQuestion, "另存为工程造价文件") = vbNo Then
            Exit Sub
        Else
            Kill (Text1.Text) '删除文件
        End If
    End If

    '************打开工作表***************
    Set xls = New excel.Application
    xls.Visible = True
    Set xlbook = xls.Workbooks.Add
    '*********************************
    For i = 0 To 14
        If Check2(i).Value = vbChecked Then
            Select Case i
                Case 8
                    ToExcelJDanJiaSum.ToExcelJDanJiaSum xlbook, xls
                Case 9
                    ToExcelADanJiaSum.ToExcelADanJiaSum xlbook, xls
                Case 10
                    ToExcelCailiao.ToExcelCailiao xlbook, xls
                Case 11
                    ToExcelTsf.ToExcelTsf xlbook, xls
                Case 12
                    ToExcelZgcl.ToExcelZgcl xlbook, xls
            End Select
        End If
    Next
    For i = 0 To 6
        If Check3(i).Value = vbChecked Then
            Select Case i
                Case 0
                    ToExcelMan.ToExcelMan xlbook, xls
                Case 1
                    ToExcelFSD_CL.ToExcelFSD_CL xlbook, xls
                Case 2
                    ToExcelHNT.ToExcelHNT xlbook, xls
                Case 3
                    ToExcelZsf.ToExcelZsf xlbook, xls
                Case 4
                    ToExcelJingChang.ToExcelJingChang xlbook, xls
                Case 5
                    ToExcelJDanJia.ToExcelJDanJia xlbook, xls
                Case 6
                    ToExcelADanJia.ToExcelADanJia xlbook, xls
            End Select
        End If
    Next
   
    xlbook.SaveAs Text1.Text '保存EXCEL文件
    '***************************关闭EXCEL对象*******************
    If Check1.Value = vbChecked Then
        xlbook.Close
        xls.Quit
    End If
    Set xlbook = Nothing
    Set xls = Nothing
    Exit Sub
'exlError:
   ' MsgBox Err.Description, vbOKOnly + vbCritical, "警告"
End Sub

Option Explicit
Public Sub ToExcelZgcl(ByRef xlbook, ByRef xls) '输出总工程量
    Dim con As New ADODB.Connection
    Dim rst_gcl As New ADODB.Recordset
    Dim rst_qm As New ADODB.Recordset
    '**************************连接数据库****************************************
    con.CursorLocation = adUseClient
    con.ConnectionString = &quotrovider=Microsoft.Jet.OLEDB.4.0;Data Source=" & strConnection & "ersist Security Info=False"
    con.Open
    rst_gcl.Open "zonggcl", con, adOpenKeyset, adLockOptimistic, adCmdTable '打开工程量汇总表
    If Not (rst_gcl.BOF And rst_gcl.EOF) Then
        rst_gcl.MoveFirst
    End If
    rst_qm.Open "qianming", con, adOpenKeyset, adLockOptimistic, adCmdTable '打开签名表
    rst_qm.MoveFirst
    '****************************工作表初使化***********************************
    Dim xlsheet As excel.Worksheet
    Set xlsheet = xlbook.Sheets.Add '添加一张工作表
    xlsheet.Name = "工程量汇总"
    xls.ActiveSheet.PageSetup.Orientation = xlLandscape '纸张设置为横向
    xlsheet.Columns("a:j").Font.Size = 10
    xlsheet.Columns("a:j").VerticalAlignment = xlVAlignCenter  '垂直居中
    xlsheet.Columns(1).HorizontalAlignment = xlHAlignCenter '1列水平居中对齐
    xlsheet.Columns(1).ColumnWidth = 8
    xlsheet.Columns(2).HorizontalAlignment = xlHAlignLeft
    xlsheet.Columns(2).ColumnWidth = 26
    xlsheet.Columns("c:j").HorizontalAlignment = xlHAlignRight
    xlsheet.Columns("c:j").ColumnWidth = 10
    xlsheet.Columns("c:j").NumberFormatLocal = "0.00_ " '3到10列保留两位小数
    '***************************写入标头*************************************
    xlsheet.Rows(1).RowHeight = 40
    xlsheet.Range(xlsheet.Cells(1, 1), xlsheet.Cells(1, 10)).MergeCells = True
    xlsheet.Cells(1, 1).Value = "工程量汇总"
    xlsheet.Cells(1, 1).Font.Size = 14
    xlsheet.Cells(1, 1).Font.Bold = True
   
    xlsheet.Rows(2).RowHeight = 18
    xlsheet.Rows(2).HorizontalAlignment = xlHAlignCenter
    xlsheet.Cells(2, 1).Value = "序号"
    xlsheet.Cells(2, 2).Value = "工程项目及名称"
    xlsheet.Cells(2, 3).Value = "土方开挖(m3)"
    xlsheet.Cells(2, 4).Value = "石方开挖(m3)"
    xlsheet.Cells(2, 5).Value = "土方回填(m3)"
    xlsheet.Cells(2, 6).Value = "洞挖石方(m3)"
    xlsheet.Cells(2, 7).Value = "砼浇筑(m3)"
    xlsheet.Cells(2, 8).Value = "钢筋制安(t)"
    xlsheet.Cells(2, 9).Value = "砌石工程(m3)"
    xlsheet.Cells(2, 10).Value = "灌浆工程(m)"
   
    xls.ActiveSheet.PageSetup.PrintTitleRows = "$12" '固定表头
    '***************************写入内容*************************
    Dim i As Integer
    i = 3 'i控制行
    Dim j As Integer 'j控制列
    Dim countpage As Integer
    countpage = 0 '控制页
    Do While Not rst_gcl.EOF
        xlsheet.Rows(i).RowHeight = 18 '控制行高
        For j = 1 To 10
            xlsheet.Cells(i, j) = rst_gcl.Fields(j) '将工程理库中的一条记录的第一个字段写入工作表中
        Next
        '每18行为一页，如果数据超出一页时进行特殊处理
        If i > 18 Then
            xls.ActiveWindow.SmallScroll Down:=1 '活动窗口内容向下滚动1行
        End If
        If i Mod 18 = 0 Then
            If countpage = 0 Then
                xlsheet.Range(xlsheet.Cells(2, 1), xlsheet.Cells(i, 10)).Borders.LineStyle = xlContinuous '首页加边框
            Else
                xlsheet.Range(xlsheet.Cells(23 + (countpage - 1) * 18, 1), xlsheet.Cells(i, 10)).Borders.LineStyle = xlContinuous '中间页加边框
            End If
            i = i + 2 '加一条空行
        
            '******************************在非尾页写入签名**************************************
            xlsheet.Range(xlsheet.Cells(i, 1), xlsheet.Cells(i, 10)).MergeCells = True
            xlsheet.Cells(i, 1).Value = Space(64) & rst_qm.Fields(0)
            xlsheet.Rows(i).RowHeight = 30
            i = i + 1 '换行
            xlsheet.Range(xlsheet.Cells(i, 1), xlsheet.Cells(i, 10)).MergeCells = True
            xlsheet.Cells(i, 1).Value = Space(50) & rst_qm.Fields(1)
            xlsheet.Rows(i).RowHeight = 15
            i = i + 1
            xlsheet.Range(xlsheet.Cells(i, 1), xlsheet.Cells(i, 10)).MergeCells = True
            xlsheet.Cells(i, 1).Value = Space(55) & rst_qm.Fields(2)
            xlsheet.Rows(i).RowHeight = 30
            '****************************************************************************
            
            xlsheet.HPageBreaks.Add (xlsheet.Rows(i + 1)) '添加分页符
            countpage = countpage + 1 '换页
        End If
        i = i + 1
        rst_gcl.MoveNext
    Loop
        xlsheet.Range(xlsheet.Cells(23 + (countpage - 1) * 18, 1), xlsheet.Cells(i - 1, 10)).Borders.LineStyle = xlContinuous '尾页加边框
        i = i + 1 '加入一空行
        '*********************************在尾页加签名***************************************
        xlsheet.Range(xlsheet.Cells(i, 1), xlsheet.Cells(i, 10)).MergeCells = True
        xlsheet.Cells(i, 1).Value = Space(64) & rst_qm.Fields(0)
        xlsheet.Rows(i).RowHeight = 30
        i = i + 1 '换行
        xlsheet.Range(xlsheet.Cells(i, 1), xlsheet.Cells(i, 10)).MergeCells = True
        xlsheet.Cells(i, 1).Value = Space(50) & rst_qm.Fields(1)
        xlsheet.Rows(i).RowHeight = 15
        i = i + 1
        xlsheet.Range(xlsheet.Cells(i, 1), xlsheet.Cells(i, 10)).MergeCells = True
        xlsheet.Cells(i, 1).Value = Space(55) & rst_qm.Fields(2)
        xlsheet.Rows(i).RowHeight = 30
        '***********************************************************************************
        xls.ActiveWindow.View = xlPageBreakPreview '分页预览
        xls.ActiveWindow.Zoom = 100
   
    If con.State = adStateOpen Then
        rst_gcl.Close
        rst_qm.Close
        Set rst_gcl = Nothing
        Set rst_qm = Nothing
        con.Close
        Set con = Nothing
    End If
    Set xlsheet = Nothing
End Sub



Option Explicit

Public Sub ToExcelTsf(ByRef xlbook, ByRef xls)
    Dim con As New ADODB.Connection
    Dim rst_tsf As New ADODB.Recordset
    Dim rst_qm As New ADODB.Recordset
    '**********************************连接数据库************************
    con.CursorLocation = adUseClient
    con.ConnectionString = &quotrovider=Microsoft.Jet.OLEDB.4.0;Data Source=" & strConnection & "ersist Security Info=False"
    con.Open
    rst_tsf.Open "tdefeiyong", con, adOpenKeyset, adLockOptimistic, adCmdTable
    If Not (rst_tsf.BOF And rst_tsf.EOF) Then
        rst_tsf.MoveFirst
    End If
    rst_qm.Open "qianming", con, adOpenKeyset, adLockOptimistic, adCmdTable
    rst_qm.MoveFirst
    '*********************************工作表初使化**********************************
    Dim xlsheet As excel.Worksheet
    Set xlsheet = xlbook.Sheets.Add
    xlsheet.Name = "机械台时、组时费汇总表"
    xlsheet.Columns(1).ColumnWidth = 5
    xlsheet.Columns(2).ColumnWidth = 20
    xlsheet.Columns(3).ColumnWidth = 7
    xlsheet.Columns(4).ColumnWidth = 7
    xlsheet.Columns(5).ColumnWidth = 7
    xlsheet.Columns(6).ColumnWidth = 7
    xlsheet.Columns(7).ColumnWidth = 7
    xlsheet.Columns(8).ColumnWidth = 7
    xlsheet.Columns(9).ColumnWidth = 7
    xlsheet.Columns("A:I").Font.Size = 9
    xlsheet.Columns("A:I").VerticalAlignment = xlVAlignCenter  '垂直居中
    xlsheet.Columns(1).HorizontalAlignment = xlHAlignCenter '1列水平居中对齐
    xlsheet.Columns(2).HorizontalAlignment = xlHAlignLeft '2列水平左对齐
    '******************************写入标头************************************
    xlsheet.Rows(1).RowHeight = 35
    xlsheet.Range(xlsheet.Cells(1, 1), xlsheet.Cells(1, 9)).MergeCells = True
    xlsheet.Cells(1, 1).Font.Size = 14
    xlsheet.Cells(1, 1).Font.Bold = True
    xlsheet.Cells(1, 1).Value = "机械台时、组时费汇总表"
   
    xlsheet.Cells(2, 9).Value = "单位：元"
    xlsheet.Range(xlsheet.Cells(3, 1), xlsheet.Cells(5, 1)).MergeCells = True
    xlsheet.Cells(3, 1).Value = "编号"
    xlsheet.Range(xlsheet.Cells(3, 2), xlsheet.Cells(5, 2)).MergeCells = True
    xlsheet.Cells(3, 2).Value = "机械名称"
    xlsheet.Range(xlsheet.Cells(3, 3), xlsheet.Cells(5, 3)).MergeCells = True
    xlsheet.Cells(3, 3).Value = "台时费"
    xlsheet.Range(xlsheet.Cells(3, 4), xlsheet.Cells(3, 9)).MergeCells = True
    xlsheet.Cells(3, 4).Value = "其      中"
    xlsheet.Range(xlsheet.Cells(3, 3), xlsheet.Cells(5, 3)).MergeCells = True
    xlsheet.Cells(3, 3).Value = "台时费"
    xlsheet.Range(xlsheet.Cells(4, 4), xlsheet.Cells(5, 4)).MergeCells = True
    xlsheet.Cells(4, 4).Value = "折旧费"
    xlsheet.Range(xlsheet.Cells(4, 5), xlsheet.Cells(5, 5)).MergeCells = True
    xlsheet.Cells(4, 5).Value = "修理替换费"
    xlsheet.Range(xlsheet.Cells(4, 6), xlsheet.Cells(5, 6)).MergeCells = True
    xlsheet.Cells(4, 6).Value = "安拆费"
    xlsheet.Range(xlsheet.Cells(4, 7), xlsheet.Cells(5, 7)).MergeCells = True
    xlsheet.Cells(4, 7).Value = "人工费"
    xlsheet.Range(xlsheet.Cells(4, 8), xlsheet.Cells(5, 8)).MergeCells = True
    xlsheet.Cells(4, 8).Value = "燃料费"
    xlsheet.Range(xlsheet.Cells(4, 9), xlsheet.Cells(5, 9)).MergeCells = True
    xlsheet.Cells(4, 9).Value = "其他费"
   
    xlsheet.Range(xlsheet.Cells(1, 1), xlsheet.Cells(5, 9)).HorizontalAlignment = xlHAlignCenter
    xls.ActiveSheet.PageSetup.PrintTitleRows = "$15" '固定表头
    '****************************************写入内容*************************************
    Dim i As Integer
        i = 6
    Do While Not rst_tsf.EOF
        xlsheet.Cells(i, 1).Value = rst_tsf.Fields("nn")
        xlsheet.Cells(i, 2).Value = rst_tsf.Fields("name")
        xlsheet.Cells(i, 3).Value = rst_tsf.Fields("price")
        xlsheet.Cells(i, 4).Value = rst_tsf.Fields("zhejiu")
        xlsheet.Cells(i, 5).Value = rst_tsf.Fields("xiuli")
        xlsheet.Cells(i, 6).Value = rst_tsf.Fields("anchai")
        xlsheet.Cells(i, 7).Value = rst_tsf.Fields("rengong")
        xlsheet.Cells(i, 8).Value = rst_tsf.Fields("dongli")
        xlsheet.Cells(i, 9).Value = rst_tsf.Fields("qita")
        If i > 22 Then
            xls.ActiveWindow.SmallScroll Down:=1 '活动窗口内容向下滚动1行
        End If
        i = i + 1
        rst_tsf.MoveNext
    Loop
    xlsheet.Range(xlsheet.Cells(6, 3), xlsheet.Cells(i - 1, 9)).NumberFormatLocal = "0.00_ " '保留两位小数
   
    '*********************************添加边框**********************************
        xlsheet.Range(xlsheet.Cells(3, 1), xlsheet.Cells(i - 1, 9)).Borders.LineStyle = xlContinuous
    '******************************************************************************
    xls.ActiveSheet.PageSetup.BottomMargin = Application.InchesToPoints(2.2) '设置下侧面边距
    xls.ActiveSheet.PageSetup.FooterMargin = Application.InchesToPoints(1) '设置页脚高
    xls.ActiveSheet.PageSetup.CenterFooter = "&10" & rst_qm.Fields(0) & Chr(10) & Chr(10) & rst_qm.Fields(1) & Chr(10) & Chr(10) & rst_qm.Fields(2) '加页脚
    xls.ActiveWindow.View = xlPageBreakPreview '分页预览
    xls.ActiveWindow.Zoom = 100
    '***************************关闭记录集*******************
    If con.State = adStateOpen Then
        rst_tsf.Close
        rst_qm.Close
        Set rst_tsf = Nothing
        Set rst_qm = Nothing
        con.Close
        Set con = Nothing
    End If
    Set xlsheet = Nothing
End Sub

glietcn

看完了～！

真是好东西啊～！

可惜不懂～！嘿嘿！

iknow

高人啊  厉害厉害！！！

细履平沙

Private Sub Form_Load()

    If Dir("c:/处理程序") = "" Then
        Set xlapp = CreateObject("Excel.Application") '创建EXCEL应用类
        xlapp.Visible = True '设置EXCEL可见
        Set xlbook = xlapp.Workbooks.Open("c:/处理程序") '打开EXCEL工作簿
        Set xlsheet = xlbook.Worksheets(1) '打开EXCEL工作表
        xlsheet.Activate '激活工作表
        xlbook.RunAutoMacros (xlAutoOpen)
        xlapp.Run ("btchip")
        xlbook.RunAutoMacros (xlAutoClose) '执行EXCEL关闭宏
        xlbook.Close (False) '关闭EXCEL工作簿
   
        Set xlapp = Nothing
        
         
    End If
   
End Sub