VB数据库导出WORD

这里的数据库采用的是ACCESS生成的MDB数据库。考虑到在VB中画表等操作比较繁琐，所以采用了饮用模版的导出形式。仅供大家学习参考。

Dim cn As New ADODB.Connection ‘定义数据库
Dim rs As New ADODB.Recordset
Dim scan As String ‘存储查找数据库
Dim Appword As Word.Application ’定义WORD模型变量
Dim Newword As Word.Document
Set Appword = New Word.Application
Set Newword = Appword.Documents.Add(App.Path + "/stencil" + "/stencil.doc") ‘这里是打开模版文档。stencil是模板的意思。可根据自己的需要替换。
Appword.Visible = False ‘隐藏WORD。导出时不在任务栏出现WORD文档。
Appword.WindowState = wdWindowStateMinimize
scan = text2(0).Text '按编号搜索需要导出word的记录，一次只能导出一条记录
rs.CursorLocation = adUseClient
ConnectionString = "Provider=Microsoft.Jet.OLEDB.4.0;Data Source=" + App.Path + "/data.mdb;Jet OLEDB:Database Password=harry2000"
cn.Open ConnectionString
rs.Open "select * from ADMIN where 编号 = '" & scan & "'", cn, adOpenKeyset, adLockOptimistic‘查找需要导出的记录
If rs.RecordCount = 0 Then ’如果不存在该记录
MsgBox "请在左边选择需要导出的记录"
Appword.Documents.Close
Appword.Quit
Exit Sub
Else ‘如果存在记录则运行以下代码
With Newword ’设置模版表格和在表格中填入数据库内容。
.Tables(1).Cell(1, 1).Range.Text = (Format(rs!日期, "yyyy年mm月dd日"))
.Tables(1).Cell(1, 3).Range.Text = "第" & rs!次数 & "次到访"
.Tables(2).Cell(1, 2).Range.Text = (rs!姓名)
.Tables(2).Cell(1, 4).Range.Text = (rs!性别)
.Tables(2).Cell(1, 6).Range.Text = (rs!年龄)
.Tables(2).Cell(2, 2).Range.Text = (rs!所在单位 & rs!所在职位)
.Tables(2).Cell(2, 4).Range.Text = (rs!联系电话)
.Tables(2).Cell(3, 2).Range.Text = (rs!领导)
.Tables(2).Cell(3, 4).Range.Text = (rs!时间) '可以根据自己的需要设置填写内容。
End With
Appword.ChangeFileOpenDirectory (App.path+ "/导出WORD文件夹")
Appword.ActiveDocument.SaveAs FileName:=(App.path+ "/导出WORD文件夹/" & rs!姓名 & Format(Now, "yyyy-mm-dd") & ".doc"), FileFormat:=wdFormatDocument, LockComments:=False, Password:="", AddToRecentFiles:=True, WritePassword:="", ReadOnlyRecommended:=False, EmbedTrueTypeFonts:=False, SaveNativePictureFormat:=False, SaveFormsData:=False, SaveAsAOCELetter:=False
Appword.Documents.Close
Appword.Quit
MsgBox "导出成功，" & rs!姓名 & Format(Now, "yyyy-mm-dd") & "的资料保存于" & vbCrLf & vbCrLf & App.path + "/导出WORD文件夹"
End If
Set Appword = Nothing ‘交还控制权
Set Newword = Nothing
Newword.Close
rs.Close ’关闭数据库





注意事项:

1 以上是基本的操作，如果想在VB中对WORD操作。可以在WORD中录制宏看一下代码，然后复制过来稍作修改即可。



2 上面的代码中用到的模版是之前设置好表格。

.Tables(1).Cell(1, 1).Range.Text 这个意思是在表格1中的第一个表格的内容



3 导出完毕后主要交还控制权。



4 这段代码运行时确保电脑中没有运行WORD程序，不然会弹出“由于应用程序忙。。。”所以在到处前应判断程序中是否运行WORD程序。

判断代码如下：

'在通用写入如下代码。

Private Declare Function CreateToolhelp32Snapshot Lib "kernel32" (ByVal dwFlags As Long, ByVal th32ProcessID As Long) As Long
Private Declare Function Process32First Lib "kernel32" (ByVal hSnapshot As Long, lppe As PROCESSENTRY32) As Long
Private Declare Function Process32Next Lib "kernel32" (ByVal hSnapshot As Long, lppe As PROCESSENTRY32) As Long
Private Declare Function CloseHandle Lib "kernel32" (ByVal hObject As Long) As Long
Private Declare Function OpenProcess Lib "kernel32" (ByVal dwDesiredAccess As Long, ByVal blnheritHandle As Long, ByVal dwAppProcessId As Long) As Long
Private Declare Function TerminateProcess Lib "kernel32" (ByVal ApphProcess As Long, ByVal uExitCode As Long) As Long
Private Type PROCESSENTRY32
dwSize As Long
cntUsage As Long
th32ProcessID As Long
th32DefaultHeapID As Long
th32ModuleID As Long
cntThreads As Long
th32ParentProcessID As Long
pcPriClassBase As Long
dwFlags As Long
szExeFile As String * 1024
End Type
Const TH32CS_SNAPHEAPLIST = &H1
Const TH32CS_SNAPPROCESS = &H2
Const TH32CS_SNAPTHREAD = &H4
Const TH32CS_SNAPMODULE = &H8
Const TH32CS_SNAPALL = (TH32CS_SNAPHEAPLIST Or TH32CS_SNAPPROCESS Or TH32CS_SNAPTHREAD Or TH32CS_SNAPMODULE)
Const TH32CS_INHERIT = &H80000000
Dim pid As Long





Private Sub Closeword() '关闭系统中运行的WORD
Dim my As PROCESSENTRY32
Dim l As Long
Dim l1 As Long
Dim mName As String
Dim i As Integer
l = CreateToolhelp32Snapshot(TH32CS_SNAPPROCESS, 0)
If l Then
Y.dwSize = 1060
If (Process32First(l, my)) Then '遍历第一个进程
Do
i = InStr(1, my.szExeFile, Chr(0))
mName = LCase(Left(my.szExeFile, i - 1))
If Trim(mName) = "winword.exe" Then '这里填你调用的程序进程名
pid = my.th32ProcessID
Dim mProcID As Long
mProcID = OpenProcess(1&, -1&, pid)
TerminateProcess mProcID, 0&
Exit Sub
End If
Loop Until (Process32Next(l, my) < 1) '遍历所有进程知道返回值为False
End If
l1 = CloseHandle(l)
End If
End Sub

Private Sub Command1_Click()

Dim o As Object
Set o = GetObject(, "Word.Application")
If o Is Nothing Then
Set o = Nothing
Else
sc = MsgBox("程序检测到您的系统中正在运行着“word”程序，请先保存，按确定以后会自动关闭所有word程序!", vbOKCancel + vbQuestion, 提示)
If sc = 1 Then
Closeword
Else
Exit Sub
End If
End If

......这里填写导出WORD的代码。

End sub

 

原帖:

http://topic.csdn.net/u/20091102/10/03b90cf2-2254-4b41-8c43-094bc882527d.html  2f