[AccessD] 2007 Word merge

Fri Mar 8 22:05:09 CST 2013

John

I'm not sure if this helps, but I have two functions - one for creating and
printing a certificate from Access using a Word document as the template,
and another for creating and emailing the certificate.

I use command buttons on the form to fire the functions.

Bob Gajewski

=====
Private Sub cmdPrintCertificate_Click()
Dim Msg, Response
If StudentCourseCompleted = False Then
    Msg = "The student has not completed the course." & vbCrLf & vbCrLf &
"The certificate cannot be printed."
    Response = MsgBox(Msg, vbOKOnly + vbCritical + vbDefaultButton1)
    Exit Sub
    Msg = ""
End If
If StudentCourseEndDate > Date Then
    Msg = "The course has not been completed (Course End Date = '" &
StudentCourseEndDate & "')." & vbCrLf & vbCrLf & "Do you still want to print
the certificate?"
    Response = MsgBox(Msg, vbYesNo + vbQuestion + vbDefaultButton2)
    If Response = vbNo Then
    Exit Sub
    End If
    Msg = ""
End If
Dim CourseDays As String
If StudentCourseStartDate = StudentCourseEndDate Then
    CourseDays = "S"
Else
    CourseDays = "M"
End If
Call PrintCertificate(CourseID.Column(1) & CourseDays,
Trim(StudentFullNameFMLS), Format(StudentCourseStartDate, "mmmm d, yyyy"),
Format(StudentCourseEndDate, "mmmm d, yyyy"), Trim(InstructorFullNameFMLS))
End Sub

Private Sub cmdEmailCertificate_Click()
Dim Msg, Response
If StudentCourseCompleted = False Then
    Msg = "The student has not completed the course." & vbCrLf & vbCrLf &
"The certificate cannot be prnted."
    Response = MsgBox(Msg, vbOKOnly + vbCritical + vbDefaultButton1)
    Exit Sub
    Msg = ""
End If
If StudentCourseEndDate > Date Then
    Msg = "The course has not been completed (Course End Date = '" &
StudentCourseEndDate & "')." & vbCrLf & vbCrLf & "Do you still want to print
the certificate?"
    Response = MsgBox(Msg, vbYesNo + vbQuestion + vbDefaultButton2)
    If Response = vbNo Then
    Exit Sub
    End If
    Msg = ""
End If
Dim CourseDays As String
If StudentCourseStartDate = StudentCourseEndDate Then
    CourseDays = "S"
Else
    CourseDays = "M"
End If
Call EmailCertificate(CourseID.Column(1) & CourseDays,
Trim(StudentFullNameFMLS), Format(StudentCourseStartDate, "mmmm d, yyyy"),
Format(StudentCourseEndDate, "mmmm d, yyyy"), Trim(InstructorFullNameFMLS),
CourseID.Column(2), StudentMailTo)
End Sub

====

Function PrintCertificate(varCourseCode, varStudentFullNameFMLS,
varCourseStartDate, varCourseEndDate, varInstructorFullNameFMLS)

On Error GoTo PrintCertificate_Err

' Start Microsoft Word
    Dim objWord As Object
    Set objWord = CreateObject("Word.Application")

    Dim strCertificate As String
        strCertificate = "C:\Users\xxx\AppData\Roaming\Microsoft\Templates\"
& varCourseCode & ".dot"
        objWord.Documents.Open strCertificate
        objWord.Visible = True

With objWord
' Move to each bookmark and insert text from the form.
    .ActiveDocument.Bookmarks("CourseCode").Select
    .Selection.Text = CStr(varCourseCode)
    .ActiveDocument.Bookmarks("StudentFullNameFMLS").Select
    .Selection.Text = CStr(varStudentFullNameFMLS)
    If Not varCourseStartDate = varCourseEndDate Then
        .ActiveDocument.Bookmarks("CourseStartDate").Select
        .Selection.Text = CStr(varCourseStartDate)
    End If
    .ActiveDocument.Bookmarks("CourseEndDate").Select
    .Selection.Text = CStr(varCourseEndDate)
    .ActiveDocument.Bookmarks("InstructorFullNameFMLS").Select
    .Selection.Text = CStr(varInstructorFullNameFMLS)
End With

' Print the document in the foreground so Microsoft Word will not close
until the document finishes printing.
    objWord.ActiveDocument.PrintOut
    Do While objWord.BackgroundPrintingStatus > 0
    Loop

' Save the document
    objWord.ActiveDocument.SaveAs FileName:="C:\Users\xxx\Documents\Pxxxx
Oxxxxxx Txxxxxxx Axxxxxx\Sxxxxxxxx Gxxxx Pxxxxxx\Certificates\" & _
        varStudentFullNameFMLS & "-" & varCourseCode & "-" &
Format(varCourseEndDate, "yyyymmdd") & ".doc"

' Close the document without saving changes.
    objWord.ActiveDocument.Close False

' Quit Microsoft Word and release the object variable.
    objWord.Quit
    Set objWord = Nothing

Exit Function

PrintCertificate_Err:
' If a field on the form is empty, remove the bookmark text, and continue.
    If Err.Number = 94 Then
        objWord.Selection.Text = ""
        Resume Next
    Else
        MsgBox "Error: (" & Err.Number & ") " & Err.Description, vbCritical
    End If

End Function

====

Function EmailCertificate(varCourseCode, varStudentFullNameFMLS,
varCourseStartDate, varCourseEndDate, varInstructorFullNameFMLS,
varCourseName, varStudentMailTo)

On Error GoTo EmailCertificate_Err

' Start Microsoft Word
    Dim objWord As Object
    Set objWord = CreateObject("Word.Application")

    Dim strCertificate As String
        strCertificate = "C:\Users\xxx\AppData\Roaming\Microsoft\Templates\"
& varCourseCode & ".dot"
        objWord.Documents.Open strCertificate
        objWord.Visible = True

With objWord
' Move to each bookmark and insert text from the form.
    .ActiveDocument.Bookmarks("CourseCode").Select
    .Selection.Text = CStr(varCourseCode)
    .ActiveDocument.Bookmarks("StudentFullNameFMLS").Select
    .Selection.Text = CStr(varStudentFullNameFMLS)
    If Not varCourseStartDate = varCourseEndDate Then
        .ActiveDocument.Bookmarks("CourseStartDate").Select
        .Selection.Text = CStr(varCourseStartDate)
    End If
    .ActiveDocument.Bookmarks("CourseEndDate").Select
    .Selection.Text = CStr(varCourseEndDate)
    .ActiveDocument.Bookmarks("InstructorFullNameFMLS").Select
    .Selection.Text = CStr(varInstructorFullNameFMLS)
End With

' Save the document
    Dim varFileName As String
        varFileName = "C:\Users\xxx\Documents\Pxxxx Oxxxxxx Txxxxxxx
Axxxxxx\Sxxxxxxxx Gxxxx Pxxxxxx\Certificates\" & _
            varStudentFullNameFMLS & "-" & varCourseCode & "-" &
Format(varCourseEndDate, "yyyymmdd") & ".doc"
    objWord.ActiveDocument.SaveAs FileName:=varFileName

' Send the document by email
    Dim bStarted As Boolean
    Dim oOutlookApp As Object
    Dim oItem As Object
    On Error Resume Next

    If Len(objWord.ActiveDocument.Path) = 0 Then 'Document has not been
saved
         objWord.ActiveDocument.Save 'so save it
    End If

    'see if Outlook is running and if so turn your attention there
    Set oOutlookApp = GetObject(, "Outlook.Application")
    If Err <> 0 Then 'Outlook isn't running
         'So fire it up
         Set oOutlookApp = CreateObject("Outlook.Application")
         bStarted = True
         oOutlookApp.Visible = True
    End If

    'Open a new e-mail message
    Set oItem = oOutlookApp.CreateItem(0)
    With oItem
        .To = varStudentMailTo
        .Subject = "Training Certificate"
        .Body = "Attached is your training certificate for the " & _
            varCourseName & " that you completed on " &
Format(varCourseEndDate, "mmmm d, yyyy") & "." & vbCrLf & _
            vbCrLf & "Pxxxx Oxxxxxx Txxxxxxx Axxxxxx" & _
            vbCrLf & "FirstName LastName, Training Director" & _
            vbCrLf & "Email: director at domain.com" & _
            vbCrLf & "Phone: (xxx) xxx-xxxx"
        .Attachments.Add varFileName
        .ReadReceiptRequested = True
        .Send
    End With

' If the macro started Outlook, stop it again.
    If bStarted Then
        ' Send/receive all emails before closing Outlook
            Dim objCB As Object, msoControlButton As CommandButton
                On Error Resume Next
            Set objCB =
oOutlookApp.Application.ActiveExplorer.CommandBar.FindControl(msoControlButt
on, 5577)
                objCB.Execute
            Set objCB = Nothing
            ' oOutlookApp.Application.Wait Now + TimeSerial(0, 0, 30)
         oOutlookApp.Quit
    End If
' Clean up
    Set oItem = Nothing
    Set oOutlookApp = Nothing

' Close the document without saving changes.
        objWord.ActiveDocument.Close False

' Quit Microsoft Word and release the object variable.
        objWord.Quit
    Set objWord = Nothing

Exit Function

EmailCertificate_Err:
' If a field on the form is empty, remove the bookmark text, and continue.
    If Err.Number = 94 Then
        objWord.Selection.Text = ""
        Resume Next
    Else
        MsgBox "Error: (" & Err.Number & ") " & Err.Description, vbCritical
    End If

End Function

-----Original Message-----
From: accessd-bounces at databaseadvisors.com
[mailto:accessd-bounces at databaseadvisors.com] On Behalf Of Ralph Bryce
Sent: Friday, March 08, 2013 14:57 PM
To: Access Developers discussion and problem solving
Subject: Re: [AccessD] 2007 Word merge

Open your main document (containing all the fields, etc.)

 From the Mailings ribbon click the Edit Recipient List button

The Mail Merge Recipients dialog contains the Data Source.

HTH

At 14:54 08/03/2013, you wrote:
>I have an existing Word document that with fields defined etc which 
>when I open it tries to pull data.  My problem is I have no clue where 
>the data is supposed to be, and I cannot figure out how to tell inside 
>of the word document where /it/ thinks the data is coming from.
>
>So (step by step) how do I get to the properties of the word document 
>that says what the data source is?  Office 2007.
>
>This whole 'data source' thing is something I have never understood 
>very well.  8(
>
>--
>John W. Colby
>
>Reality is what refuses to go away
>when you do not believe in it
>
>--
>AccessD mailing list
>AccessD at databaseadvisors.com
>http://databaseadvisors.com/mailman/listinfo/accessd
>Website: http://www.databaseadvisors.com

--
AccessD mailing list
AccessD at databaseadvisors.com
http://databaseadvisors.com/mailman/listinfo/accessd
Website: http://www.databaseadvisors.com