Formating book mark text inserted using automation

[kamulegs]

Hello friends

I am using office 2007
I use a code to automate creation of employee contracts using a word template.

I want to add formatting to the information inserted like bold, italics, etc

Here is the part of the code where information is inserted from the record set

With wrdDoc
.Bookmarks("Post").Range.Text = rst!PositionTitle
.Bookmarks("Name").Range.Text = rst!Name
.Bookmarks("Name1").Range.Text = rst!Name
.Bookmarks("Name2").Range.Text = rst!Name
.Bookmarks("Post1").Range.Text = rst!PositionTitle
.Bookmarks("Post2").Range.Text = rst!PositionTitle
.Bookmarks("Period").Range.Text = rst!Period
.Bookmarks("Date").Range.Text = rst!StartDate
.Bookmarks("Scale").Range.Text = rst!Scale
.Bookmarks("Salary").Range.Text = Format(rst!BasicPay, "Currency")
'Save Document
 strFilePath = CurrentProject.Path & "\" & "Contracts" & "\"
        If Len(Dir(strFilePath, vbDirectory)) = 0 Then
            MkDir strFilePath
            End If
strName = strFilePath & rst!Name & ".docx"
.SaveAs (strName)
.Close
End With
Set wrdDoc = Nothing
rst.MoveNext
Loop

I have tried adding

For Each varBookmark In wrdDoc.Bookmarks
varBookmark.Range.Font.Bold = True
Next varBookmark

But it is not working

Any suggestions?

Ronald

 

[vbaInet]

You're barking up the wrong tree on this one. This is a Modules & VBA section for Access not Word. You will be better off asking this in the Word section of this forum or in an appropriate Word VBA forum.

In any case, where within your code did you put that loop?
Do all other changes get saved?

 

[kamulegs]

Hello

Thank you for the reply

I did not know that this forum only applies to access VBA

Every thing was works except formating the bookmarks


Ronald

 

[vbaInet]

The forum caters for different technologies, but this particular section is for Access VBA. There's a Word section but I don't know how frequent that's being used.

So, tell me where exactly did you put your For Each code? Which line?

 

[kamulegs]

Hello

I searched for a word forum where they helped me make it work

Just for benefit of some one who may have the same problem here below is the working code

Private Sub cmdContracts_Click()
Dim db As DAO.Database
Dim rst As DAO.Recordset
Dim strSQL As String
Dim strFilePath As String
Dim strName As String
Dim strTemp As String
Dim objWord As Word.Application
Dim wrdDoc As Word.Document
Dim myBookmark As Bookmark
Dim intCount As Integer
Dim strMsg As String
Dim objRange As Word.Range
     strSQL = "SELECT tblHREmployeeContracts.*, tblEmployees.IDNumber, tblHRSalaryScale.Scale, [tblEmployees]![s_Name] & "" "" & [tblEmployees]![f_Name] AS Name, tblHREmployeeSalaries.BasicPay, tblHRPositions.PositionTitle, DateDiff(""m"",[tblHREmployeeContracts]![StartDate],[tblHREmployeeContracts]![EndDate]) & "" "" & "" Months "" AS Period " & vbCrLf & _
            "FROM ((tblHRSalaryScale INNER JOIN tblHRPositions ON tblHRSalaryScale.ScaleID = tblHRPositions.ScaleID) INNER JOIN tblHRSalaryScales_SalaryRanges ON tblHRSalaryScale.ScaleID = tblHRSalaryScales_SalaryRanges.ID) INNER JOIN (((tblHREmployeeContracts INNER JOIN tblEmployees ON tblHREmployeeContracts.EmpployeeID = tblEmployees.EmployeeID) INNER JOIN tblHRPositions_Employees ON tblEmployees.EmployeeID = tblHRPositions_Employees.EmployeeID) INNER JOIN tblHREmployeeSalaries ON tblEmployees.EmployeeID = tblHREmployeeSalaries.EmployeeID) ON tblHRPositions.PostionID = tblHRPositions_Employees.PositionID " & vbCrLf & _
            "WHERE tblHREmployeeSalaries.CurrentSalary=True " & _
            "AND tblHRSalaryScales_SalaryRanges.CurrentFlag=True" & _
            " AND tblHRPositions_Employees.CurrentFlag=True" & _
            " And tblHREmployeeContracts.Print =True;"
On Error GoTo myErr
If Me.lstTemps.ItemsSelected.Count = 0 Then
        MsgBox " No Template selected", vbExclamation
            Exit Sub
                End If
Set db = CurrentDb()
Set rst = db.OpenRecordset(strSQL, dbOpenSnapshot)
If rst.EOF Then
        MsgBox " No Contract Selected for Printing", vbInformation
            Exit Sub
                End If
rst.MoveFirst
rst.MoveLast
intCount = rst.RecordCount
strMsg = "Printing " & intCount & " Set of Employee Contracts"
strTemp = Me.lstTemps.Column(3)
'Launch word and load the template
Set objWord = CreateObject("Word.Application")
Application.SysCmd acSysCmdInitMeter, strMsg, intCount
rst.MoveFirst
DoCmd.Hourglass True
Do While Not rst.EOF
        Set wrdDoc = objWord.Documents.Add(strTemp)
        objWord.Visible = False
        'Add information to the template
    With wrdDoc
        Set objRange = .Bookmarks("Post").Range
        objRange.Text = rst!PositionTitle
        objRange.Font.Bold = True
        objRange.Font.Italic = True
        .Bookmarks.Add "Post", objRange
        Set objRange = .Bookmarks("Name").Range
        objRange.Text = rst!Name
        objRange.Font.Bold = True
        objRange.Font.Italic = True
        .Bookmarks.Add "Name", objRange
        Set objRange = .Bookmarks("Name1").Range
        objRange.Text = rst!Name
        objRange.Font.Bold = True
        objRange.Font.Italic = True
        .Bookmarks.Add "Name1", objRange
        Set objRange = .Bookmarks("Name2").Range
        objRange.Text = rst!Name
        objRange.Font.Bold = True
        objRange.Font.Italic = True
        .Bookmarks.Add "Name2", objRange
        Set objRange = .Bookmarks("Post1").Range
        objRange.Text = rst!PositionTitle
        objRange.Font.Bold = True
        objRange.Font.Italic = True
        .Bookmarks.Add "Post1", objRange
        Set objRange = .Bookmarks("Post2").Range
        objRange.Text = rst!PositionTitle
        objRange.Font.Bold = True
        objRange.Font.Italic = True
        .Bookmarks.Add "Post2", objRange
        Set objRange = .Bookmarks("Period").Range
        objRange.Text = rst!Period
        objRange.Font.Bold = True
        objRange.Font.Italic = True
        .Bookmarks.Add "Period", objRange
        Set objRange = .Bookmarks("Date").Range
        objRange.Text = Format(rst!StartDate, "dd/mmmm/yyyy")
        objRange.Font.Bold = True
        objRange.Font.Italic = True
        .Bookmarks.Add "Date", objRange
        Set objRange = .Bookmarks("Scale").Range
        objRange.Text = rst!Scale
        objRange.Font.Bold = True
        objRange.Font.Italic = True
        .Bookmarks.Add "Scale", objRange
        Set objRange = .Bookmarks("Salary").Range
        objRange.Text = Format(rst!BasicPay, "Currency")
        objRange.Font.Bold = True
        objRange.Font.Italic = True
        .Bookmarks.Add "Salary", objRange
         strFilePath = CurrentProject.Path & "\" & "Contracts" & "\"
                If Len(Dir(strFilePath, vbDirectory)) = 0 Then
                    MkDir strFilePath
                    End If
        strName = strFilePath & rst!Name & ".docx"
        .SaveAs (strName)
        .Close
End With
rst.MoveNext
Application.SysCmd acSysCmdUpdateMeter, intCount
Loop
rst.Close
'Exit Word
myExit:
Set objRange = Nothing
Application.SysCmd acSysCmdClearStatus
DoCmd.Hourglass False
Set rst = Nothing
Set wrdDoc = Nothing
objWord.Quit False
Set objWord = Nothing
Exit Sub
myErr:
MsgBox "Err" & Err.Description
Resume myExit
End Sub

Ronald

 

[vbaInet]

Thanks for posting back with your working solution.