将Access 2016中的特定信息导出到已创建的Word文档

时间：2017-02-26 08:35:25

标签： access-vba access

我正在尝试将Access 2016表单中的数据导出到Word文档。这是我正在使用的代码。

Public Function doWordAutomation()

On Error GoTo doWordAutomationErr

Dim objWordDoc As Word.Document

Dim objWord As Word.Application

Dim sDocument As String

sDocument = Application.CurrentProject.Path & "C:Desktop\No Notary Legal Dispatch Affidavit Fill.doc"
Set objWord = CreateObject("Word.Application")
Set objWordDoc = objWord.Documents.Open(Application.CurrentProject.Path & "\C:\Desktop\No Notary Legal Dispatch Affidavit Fill.doc")
If (sDocument) Then
    Kill sDocument
End If
objWordDoc.SaveAs sDocument

With objWordDoc.Bookmarks
    If .Exists("Cause") Then
        .Item("Cause").Range.Text = "Cause"
    If .Exists("Plaintiff") Then
        .Item("Plaintiff").Range.Text = "Plaintiff"
    If .Exists("Court") Then
        .Item("Court").Range.Text = "Court"
    If .Exists("County") Then
        .Item("County").Range.Text = "County"
    If .Exists("State") Then
        .Item("State").Range.Text = "State"
    If .Exists("Defendant") Then
        .Item("Defendant").Range.Text = "Defendant"
    If .Exists("Documents") Then
        .Item("Documents").Range.Text = "Documents"
    If .Exists("NameforService") Then
        .Item("NameforService").Range.Text = "NameforService"
    If .Exists("ServiceAddress") Then
        .Item("ServiceAddress").Range.Text = "ServiceAddress"
    If .Exists("ResultTime") Then
        .Item("ResultTime").Range.Text = "ResultTime"
    If .Exists("ResultDate") Then
        .Item("ResultDate").Range.Text = "ResultDate"
    End If
End

objWordDoc.Save
objWordDoc.Close

doWordAutomationExit:
Exit Function

doWordAutomationErr:

MsgBox Err.Description, vbOKOnly, Err.Source & ":" & Err.Number

Resume doWordAutomationExit

End Function

我已经在我的表单中创建了一个按钮并将此代码附加到它，但是当我尝试使用它时没有任何反应。我们将非常感谢您提供的任何帮助。 

Private Sub cmdPrint_Click()
  'Print customer slip for current customer.
  Dim appWord As Word.Application
  Dim doc As Word.Document
  'Avoid error 429, when Word isn’t open.
  On Error Resume Next
  Err.Clear
  'Set appWord object variable to running instance of Word.
  Set appWord = GetObject(, "Word.Application")
  If Err.Number <> 0 Then
    'If Word isn’t open, create a new instance of Word. 
    Set appWord = New Word.Application
  End If
  Set doc = appWord.Documents.Open("C:C:Desktop\No Notary Legal Dispatch Affidavit Fill.doc", , True)
  With doc
    .FormFields("Cause").Result = Me!Cause
    .FormFields("Plaintiff").Result = Me!Plaintiff
    .FormFields("Court").Result = Me!Court
    .FormFields("County").Result = Me!County
    .FormFields("State").Result = Me!State
    .FormFields("Defendant").Result = Me!Defendant
    .FormFields("Documents").Result = Me!Documents
    .FormFields("NameforService").Result = Me!NameforService
    .FormFields("ServiceAddress").Result = Me!ServiceAddress
    .FormFields("ResultTime").Result = Me!ResultTime
    .FormFields("ResultDate").Result = Me!ResultDate
    .Visible = True
    .Activate
  End With
  Set doc = Nothing
  Set appWord = Nothing
  Exit Sub

errHandler:
  MsgBox Err.Number & ": " & Err.Description
End Sub

我在Word文档中创建了书签，我想将表单信息导出到。我使用的代码都没有为我工作，所以任何帮助将不胜感激。

由于某种原因，它仍然无法正常工作。我不知道它是否是我在表单中放置的按钮，这是一个命令76按钮。我知道这不是我需要输出的确切右键，但它是我能看到的最接近的按钮。我附上了我正在尝试使用的访问文档和word文档。带有书签Word文档和访问表单访问文档的Word表单已链接到此处。再次感谢您的帮助。附上我正在尝试使用的两个文件。

1 个答案:

答案 0 :(得分：1)

现在您已经共享了文档和名称，我更改了代码以使用表单中的数据。您可能需要调整文档间距或插入的数据。让我知道它是怎么回事。

另外，我建议你删除不必要的描述和评论来清理这个帖子。

Option Compare Database
Option Explicit

Private Sub Command75_Click()
    Export_Form_Data_To_Word
End Sub


Public Function Export_Form_Data_To_Word()
Dim objWordDoc  As Word.Document
Dim objWord     As Word.Application
Dim objRange    As Word.Range
Dim sPath       As String
Dim sFileName   As String
Dim sSaveAs     As String
Dim sDocument   As String
Dim i           As Integer
    On Error GoTo Error_Trap

    ' For my testing....
    'sPath = "C:\temp\"                  '
    'sFileName = "NoNotaryLegalDispatchAffidavitFill.docx"        '

    sPath = "C:\Users\Josh Panger\Desktop"                  '
    sFileName = "No Notary Legal Dispatch Affidavit Fill.docx"        '
    i = InStrRev(sFileName, ".doc")        '
    ' Create a new file name
    sSaveAs = Left(sFileName, i - 1) & "_" & Format(Now(), "YYYYMMDD_HHMMSS") & Mid(sFileName, i)
    Set objWord = CreateObject("Word.Application")

    objWord.Visible = True

    Set objWordDoc = objWord.Documents.Open(sPath & sFileName)

    With objWordDoc.Bookmarks
        If .Exists("Cause") Then
            objWordDoc.Bookmarks("Cause").Range.InsertAfter Me.Cause
        Else
            MsgBox "Bookmark: 'Cause' does not exist in this Word Document!", vbOKOnly, "Missing Bookmark"
        End If

        If .Exists("Plaintiff") Then
            objWordDoc.Bookmarks("Plaintiff").Range.InsertAfter Me.Plaintiff & ", Plaintiff"
        Else
            MsgBox "Bookmark: 'Plaintiff' does not exist in this Word Document!", vbOKOnly, "Missing Bookmark"
        End If

        If .Exists("Defendant") Then
            objWordDoc.Bookmarks("Defendant").Range.InsertAfter Me.Defendant & ", Defendant"
        Else
            MsgBox "Bookmark: 'Defendant' does not exist in this Word Document!", vbOKOnly, "Missing Bookmark"
        End If

        If .Exists("Court") Then
            objWordDoc.Bookmarks("Court").Range.InsertAfter Me.Count
        Else
            MsgBox "Bookmark: 'Court' does not exist in this Word Document!", vbOKOnly, "Missing Bookmark"
        End If
        If .Exists("County") Then
            objWordDoc.Bookmarks("County").Range.InsertAfter Me.County
        Else
            MsgBox "Bookmark: 'County' does not exist in this Word Document!", vbOKOnly, "Missing Bookmark"
        End If
        If .Exists("State") Then
            objWordDoc.Bookmarks("State").Range.InsertAfter "My State"
        Else
            MsgBox "Bookmark: 'State' does not exist in this Word Document!", vbOKOnly, "Missing Bookmark"
        End If

        If .Exists("Documents") Then
            objWordDoc.Bookmarks("Documents").Range.InsertAfter Me.Documents
        Else
            MsgBox "Bookmark: 'Documents' does not exist in this Word Document!", vbOKOnly, "Missing Bookmark"
        End If

        If .Exists("NameforService") Then
            objWordDoc.Bookmarks("NameforService").Range.InsertAfter Me.NameforService
        Else
            MsgBox "Bookmark: 'NameforService' does not exist in this Word Document!", vbOKOnly, "Missing Bookmark"
        End If

        If .Exists("ServiceAddress") Then
            objWordDoc.Bookmarks("ServiceAddress").Range.InsertAfter Me.ServiceAddress
        Else
            MsgBox "Bookmark: 'ServiceAddress' does not exist in this Word Document!", vbOKOnly, "Missing Bookmark"
        End If

        If .Exists("ResultTime") Then
            objWordDoc.Bookmarks("ResultTime").Range.InsertAfter Me.ResultTime
        Else
            MsgBox "Bookmark: 'ResultTime' does not exist in this Word Document!", vbOKOnly, "Missing Bookmark"
        End If

        If .Exists("ResultDate") Then
            objWordDoc.Bookmarks("ResultDate").Range.InsertAfter Me.ResultDate
        Else
            MsgBox "Bookmark: 'ResultDate' does not exist in this Word Document!", vbOKOnly, "Missing Bookmark"
        End If

    End With

    objWordDoc.SaveAs2 sPath & sSaveAs, 16
    objWordDoc.Close

Exit_Code:
    Exit Function

Error_Trap:

    Debug.Print Err.Number & vbTab & Err.Description
    If Err.Number = 5174 Then
        MsgBox "The Word document can't be found at location: '" & sDocument & "'", vbOKOnly, "Missing File"
    Else
        MsgBox Err.Number & vbTab & Err.Description, vbOKOnly, Err.Source & ":" & Err.Number
    End If
    Resume Exit_Code
    Resume
End Function
相关问题
最新问题