将数据导出到Word中的函数

时　间:2010-05-10 11:06:28
作　者:wqm099   ID：5203  城市：郑州
摘　要:给出一个将数据导出到WORD的函数，供网友参考。
正　文:

给出一个将数据导出到WORD的函数，供网友参考。

使用时请引用一下Microsoft Word 11.0 Object Library

点击下载此附件

Function ZWord1(模板名, 文件名, 记录集, 起始行, 表号, Optional 条件 As String)
Dim doc As New Word.Document  ' 定义引用 Microsoft Word 的变量。
Dim BTable As Word.Table
Dim dbs As Database  '定义引用数据库的变量。
Dim rst As DAO.Recordset '定义引用记录集的变量。
Dim I, J, P As Integer
Dim s As String
'On Error GoTo err1
'使用DAO操作打开明细记录集
Set dbs = CurrentDb()
If Nz(条件) <> "" Then 记录集 = "select * from " & 记录集 & " where " & 条件
Set rst = dbs.OpenRecordset(记录集)                 '设置记录集
If InStr(1, UCase(模板名), ".DOC") > 0 Then
 WJ1 = CurrentProject.Path & "\" & 模板名
'模板文件名(CurrentProject.Path为当前数据库的路径）
Else
 WJ1 = CurrentProject.Path & "\" & 模板名 & ".DOC"
'模板文件名(CurrentProject.Path为当前数据库的路径)
End If
If InStr(1, UCase(文件名), ".DOC") > 0 Then
 WJ2 = CurrentProject.Path & "\" & 文件名           '目标文件名
Else
 WJ2 = CurrentProject.Path & "\" & 文件名 & ".DOC"  '目标文件名
End If
FileCopy WJ1, WJ2                                   '拷贝文件（模板文件拷贝成目标文件）
Set doc = GetObject(WJ2, "Word.Document")           '建立与Word的连接变量
doc.Application.Visible = True                      '打开属性为真
doc.Activate
Set BTable = doc.Application.ActiveDocument.Tables(表号)
Set rst = dbs.OpenRecordset(记录集)   '设置记录集
If Not rst.EOF Then rst.MoveFirst
I = 起始行
While Not rst.EOF
 Set rowNew = BTable.Rows.Add() '加入一行
 J = 0
 For Each HCell In BTable.Rows(I).Cells
  HCell.Range.InsertAfter Nz(rst.Fields(J))
  J = J + 1
 Next HCell
 rst.MoveNext
 I = I + 1
Wend
doc.Save                                             '保存Word
doc.Application.Quit                                 '关闭Word
Set doc = Nothing                                    '清除内存变量
Set BTable = Nothing
Set dbs = Nothing
Set rst = Nothing
ZWord1 = True
Exit Function
err1:
doc.Application.Quit
Set doc = Nothing                                   '清除内存变量
Set BTable = Nothing
Set dbs = Nothing
Set rst = Nothing
ZWord1 = False
MsgBox ("出现错误，可能是Word已打开，请关闭Word后再试")
End Function