设为首页收藏本站Access中国
Office中国(www.office-cn.net),专业Office论坛

Office中国论坛/Access中国论坛

 找回密码
 注册

QQ登录

只需一步,快速开始

扫一扫,访问微社区

返回列表 发新帖
查看: 794|回复: 1

[与其它组件] [源码]Access导出到Word的VBA代码

[复制链接]
发表于 2015-12-22 12:00:20 | 显示全部楼层 |阅读模式
可以通过VBA将access内容导出到word,代码如下
Private Sub 导出word_Click()
    On Error GoTo ErrorHandler
    Dim strTemplate As String
    Dim strFileName As String
    Dim objApp As Object    'New Word.Application
    Dim objDoc As Object    'Word.Document
    Dim objField As Object    'Word.Field
    Dim rst As Object
    Dim blnNoQuit As Boolean
    strTemplate = CurrentProject.Path & "\模板\通知单模板.doc"
    '设置鼠标指针为沙漏形状
    DoCmd.Hourglass True
    Set objApp = CreateObject("Word.Application")
    Set objDoc = objApp.Documents.Open(strTemplate)
    Set rst = CurrentDb.OpenRecordset("SELECT * FROM tbl通知单 WHERE ID=" & ID, , 4)    'dbReadOnly
    If Not rst.EOF Then
        strFileName = CurrentProject.Path & "\存放位置\" & "通知单" & rst!ID & ".doc"
        '如果文件已存在,先删除已有文件
        If Dir(strFileName) <> "" Then Kill strFileName
        objDoc.FormFields("钢筋绑扎胎具").result = rst!钢筋绑扎胎具
        objDoc.FormFields("桥梁名称").result = rst!桥梁名称
        objDoc.FormFields("箱梁编号").result = rst!箱梁编号
        objDoc.FormFields("份数").result = Nz(rst!份数)
        objDoc.FormFields("钢筋吊装时间").result = Format(rst!钢筋吊装时间, "yyyy年m月d日")
        objDoc.FormFields("交接人").result = rst!交接人
        objDoc.FormFields("字段1").result = rst!字段1
    End If
    rst.Close
    objDoc.SaveAs strFileName
    Beep
    If MsgBox("导出已完成,是否打开该文件?", vbQuestion + vbYesNo, "导出完成") = vbYes Then
        objApp.Visible = True
        objDoc.Saved = True
        blnNoQuit = True
    End If
ExitHere:
    On Error Resume Next
    If Not blnNoQuit Then
        If Not objDoc Is Nothing Then objDoc.Saved = True
        If Not objApp Is Nothing Then objApp.Quit
    End If
    '恢复鼠标指针
    DoCmd.Hourglass False
    '释放对象变量内存
    Set objApp = Nothing
    Set objDoc = Nothing
    Set rst = Nothing
    Exit Sub
ErrorHandler:        '错误处理程序
    If Err = 70 Then
        MsgBox "不能替换文件,因为无法删除已有文件,可能的原因有:" & vbCrLf & vbCrLf & _
               "1.该文件处于打开状态。" & vbCrLf & _
               "2.没有对此目录的写入权限。", vbCritical
    Else
        MsgBox Err.Description, vbCritical, "出错 #" & Err
    End If
    Resume ExitHere
End Sub
摘自网络

发表于 2016-1-15 07:44:42 | 显示全部楼层
正好需要,谢谢
您需要登录后才可以回帖 登录 | 注册

本版积分规则

关闭

站长推荐上一条 /6 下一条

QQ|站长邮箱|小黑屋|手机版|Office中国/Access中国 ( 粤ICP备10043721号-1 )  

GMT+8, 2018-8-18 01:39 , Processed in 0.079465 second(s), 28 queries .

Powered by Discuz! X3.3

© 2001-2017 Comsenz Inc.

快速回复 返回顶部 返回列表