利用access VBA批量输出word文档 + Excel VBA

　　最近忙一个小项目，要求根据已有的历史与现状资料填写对照表格，总共有几十份，里面要求填的数据项也很琐碎，而且细节上可能会有小的变更与修改。

　　本人很懒，最讨厌就是繁琐的手工劳动与无休止的改来改去，刚巧有之前用数据采集软件生成的access数据库，焉能有不加以充分利用之理？于是俺就想办法咯。

　　既然是access与Word，那就用传说中的VBA咯，但木用过，就上Google猛搜……

　　终于找到了方法：利用VBA查询出需要的数据，然后通过word模板批量生成对照表格。

　　综合access软件网 竹笛和另外一个叫 Access+VBA套打Word+模板(三种方法) 的资料，经过数小时的调试，终于大功告成，啊哈哈哈，人民群众的智慧是无穷的哦~~~

　　过程介绍如下：

　　1、先把用做模板的word表格需插入数据项的位置加上书签(Bookmarks)。数据项多的话，书签最好用文字标记，并设置书签为显示状态，这样一目了然，不容易出错误。

　　2、在access新建一个窗体，拖一个Button上去，触发单击命令，开始在VB编辑器中敲代码……

　　3、查询各表得出需要的数据记录集 (Recordset)，利用循环语句读取每条记录，打开word模板，用数据项替换对应的word书签，然后保存。

　　--------完事大吉，批量输出啦，欧拉拉欧拉拉~~~

　　代码如下：

Code 

Option Compare Database

Private Sub cmdExportAll_Click()

    Dim rownum As Integer
    Dim I, N As Integer

    \'使用DAO操作打开明细记录集
    Dim rs As DAO.Recordset
    Dim sqlStr As String

    \'单库多表查询，需事先将数据集中到一个mdb中
    \'sqlStr = "Select * from ckq b , yckq a where b.证号=a.证号"

    \'跨库多表查询，连接多个mdb中数据表，不用倒腾数据，直接利用已有的mdb数据库，方便多了~~~
    sqlStr = "Select * from [;database=" & CurrentProject.Path & "\ckq.mdb].ckq b , [;database=" & CurrentProject.Path & "\yckq.mdb].yckq a where b.证号=a.证号"
    Set rs = CurrentDb.OpenRecordset(sqlStr)

    \'如果没有记录 , 不执行下面程序
    If rs.EOF Then Exit Sub

    \'为了能得到记录总数量,DAO记录集要先把记录集位置移到最后,否则得不到RECORDCOUNT
    rs.MoveLast
    rs.MoveFirst

    rownum = rs.RecordCount

    \'多条数据的处理,使用循环
    For I = 1 To rownum
  
        \'创建Word对象
        Set doc = CreateObject("word.application")
        doc.Visible = True
        \'打开Word文件
        Dim mydoc As Object
        Set mydoc = doc.Documents.Add(CurrentProject.Path & "\表格模板.doc") \'使用定义好的模板创建新文件

        \'mydoc.Bookmarks("template_content_en").Range.Text = (rs!测试字段)
        \'(rs.Fiel(ds(0).Name) \'(rs.Fields(0).Value)

        \'最后面加上 & "" 避免了当字段为NULL时程序出错中断,省却不少代码行与麻烦,真TMD太有用了
        mydoc.Bookmarks("证号").Range.Text = rs.Fields("b.证号").Value & ""
        mydoc.Bookmarks("项目名称").Range.Text = rs.Fields("b.项目名称").Value & ""
        mydoc.Bookmarks("a传真").Range.Text = rs.Fields("a.传真").Value & ""
        mydoc.Bookmarks("b传真").Range.Text = rs.Fields("b.传真").Value & ""
        mydoc.Bookmarks("a电话").Range.Text = rs.Fields("a.电话").Value & ""
        mydoc.Bookmarks("b电话").Range.Text = rs.Fields("b.电话").Value & ""
        mydoc.Bookmarks("a地址").Range.Text = rs.Fields("a.地址").Value & ""
        mydoc.Bookmarks("b地址").Range.Text = rs.Fields("b.地址").Value & ""

        \'以下省略N项
        \'.........
        \'.........

        Select Case rs.Fields("a.项目类型").Value & ""
            Case "1"
                mydoc.Bookmarks("a1").Range.Text = "√"
                mydoc.Bookmarks("a2").Range.Text = ""
            Case "2"
                mydoc.Bookmarks("a1").Range.Text = ""
                mydoc.Bookmarks("a2").Range.Text = "√"
            Case Else
                mydoc.Bookmarks("a1").Range.Text = ""
                mydoc.Bookmarks("a2").Range.Text = ""
        End Select

        \'以下为坐标数字串，XY坐标分开存储，X11位，Y12位，读取时根据位数截取

        \'mid("1234",2,2)
        \'mid(string,start,len)
        \'Mid("1234",   insrt("1234","23"),   len("23"))
        Dim XA, YA, XB, YB As String
        XA = rs.Fields("a.经度坐标").Value & ""
        YA = rs.Fields("a.纬度坐标").Value & ""
        XB = rs.Fields("b.经度坐标").Value & ""
        YB = rs.Fields("b.纬度坐标").Value & ""
        \'Dim XYnum As Integer
        \'XYnum = Len(XB) / 11
        For N = 1 To 22
        mydoc.Bookmarks("XA" & N).Range.Text = Mid(XA, N * 11 + 1, 11) & ""
        mydoc.Bookmarks("YA" & N).Range.Text = Mid(YA, N * 12 + 1, 12) & ""
        mydoc.Bookmarks("XB" & N).Range.Text = Mid(XB, N * 11 + 1, 11) & ""
        mydoc.Bookmarks("YB" & N).Range.Text = Mid(YB, N * 12 + 1, 12) & ""
        Next

        \'If XYnum < 14 Then
        \'For N = XYnum + 1 To 14
        \'mydoc.Bookmarks("XB" & N).Range.Text = ""
        \'mydoc.Bookmarks("YB" & N).Range.Text = ""
        \'Next
        \'\'Else
        \'End If

        \'保存word文档
        mydoc.SaveAs CurrentProject.Path & "\" & rs.Fields("a.项目名称").Value & ".doc"

        \'释放对象变量
        Set doc = Nothing
        rs.MoveNext

    Next
    rs.Close

End Sub

  

　　2010年1月12日，试验了一下Excel VBA下的批量输出，代码如下： 

Code 

Private Sub CommandButton1_Click()
    Dim I As Integer
    For I = 1 To 5   \'rownum  \'多条数据的处理,使用循环
        \'创建Word对象
        Set doc = CreateObject("word.application")
        doc.Visible = True
        \'打开Word文件
        Dim mydoc As Object
        Set mydoc = doc.Documents.Add(ActiveWorkbook.Path & "\说明模板.doc") \'使用定义好的模板创建新文件，access中取当前路径为CurrentProject.Path
        \'开始替换书签
        mydoc.Bookmarks("许可证号").Range.Text = Cells(I + 1, 1).Value & ""
        mydoc.Bookmarks("法人代表").Range.Text = Cells(I + 1, 2).Value & ""
        mydoc.Bookmarks("地址").Range.Text = Cells(I + 1, 3).Value & ""
        mydoc.Bookmarks("名称").Range.Text = Cells(I + 1, 4).Value & ""
                
        mydoc.Bookmarks("日期").Range.Text = Format(Cells(I + 1, 23).Value & "", "yyyy年m月d日")
        
        Dim N&, Dr, Ddr$
        Dim pathFileSaved As String
        
        \'指定报表生成路径引用，正式路径
        \'pathFileSaved = CurrentProject.Path & "\CKQ\410000\" & Cells(I + 1, 1).Value & "\属性数据\说明"
        
        \'以下为测试路径
        pathFileSaved = ActiveWorkbook.Path & "\测试输出"
        \'文件目录不存在的情况下,建立文件目录,文件目录按 pathFileSaved
        On Error Resume Next
        Dr = Split(pathFileSaved, "\")
        Ddr = Dr(0)
        For N = 1 To UBound(Dr)
            Ddr = Ddr & "\" & Dr(N)
            MkDir Ddr
        Next
        Err.Clear
        On Error GoTo 0
        
        \'mydoc.SaveAs pathFileSaved & "\DQK" & Cells(I + 1, 1).Value & ".doc" \'正式名称
        mydoc.SaveAs pathFileSaved & "\" & Cells(I + 1, 4).Value & "DQK" & Cells(I + 1, 1).Value & ".doc" \'测试名称
        \'释放对象变量
        Set doc = Nothing
    Next
End Sub