给出一个将数据导出到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