How can I use Access VBA to insert a watermark background image, or any background image, into a generated WORD doc?

The last time that I tried recording a macro for adding Watermarks, it had syntax errors.

You could try starting with this. It puts a washed-out picture in the header, so that it appears on each page.

Sub AddWaterMarkStylePicture(strFileName As String, wdDoc As Word.Document)
    Dim sh As Word.Shape
    Dim rng As Word.Range
   
    Set rng = wdDoc.Sections(1).Headers(wdHeaderFooterPrimary).Range
    Set sh = wdDoc.Sections(1).Headers(wdHeaderFooterPrimary).Shapes.AddPicture(strFileName, False, True, 0, 0, 400, 400, rng)
    'sh.LockAspectRatio = false
    'sh.height = CentimetersToPoints(18)
    sh.PictureFormat.ColorType = msoPictureWatermark
    sh.WrapFormat.Type = wdWrapThrough
End Sub

Well, I tried the first solution - ran the macro and copied the code with appropriate modificactions into my code, see the entire script below.  It doesn't seem to do anything...but that could be because I'm missing something?  The new code starts at the comment "'Following is the new code which was generated from the macro:" - and note, there are also some other comments in that code...

Below the code example I respond to the second solution, which is also a near-miss...I feel we're close!
thanks
Marc

_______________________________________________________________
Private Sub cmdPrintProfile_Click()
    Dim oWordApp As Word.Application
    Dim oWordDoc As Word.Document
    Dim oRange As Word.Range
    Dim myrange As Word.Range
    Dim myTable As Table
   
    Dim db As DAO.Database
    Dim rs As DAO.Recordset
    Dim rs1 As DAO.Recordset
    Dim rs2 As DAO.Recordset
    Dim rs3 As DAO.Recordset
    Dim rs4 As DAO.Recordset
    Dim rs5 As DAO.Recordset
   
    Dim bLink As Boolean
    Dim bSaveWithdoc As Boolean
    Dim sSql As String
    Dim cFont As String
    Dim cHeaderImage As String
    Dim tbl As TableDef
    Dim i As Integer
    Dim nResult As Integer
    Dim cFullname As String
    Dim cFooterLinePage2 As String
   
    bLink = False
    bSaveWithdoc = False
   
    'On Error GoTo ErrorLike
   
    'Create a new document in Word
    Set oWordApp = CreateObject("Word.Application")
    oWordApp.Visible = True
    Set oWordDoc = oWordApp.Documents.Add
    oWordDoc.PageSetup.RightMargin = 50
    oWordDoc.PageSetup.LeftMargin = 50
    oWordDoc.PageSetup.BottomMargin = 50
   
    ' Open images table
    Set db = CurrentDb
   
    Set rs = db.OpenRecordset("SELECT dbo_tbl_Speaker_Profile.iSpeakerID, dbo_tbl_Speaker_Profile.sOneLiners FROM dbo_tbl_Speaker_Profile WHERE dbo_tbl_Speaker_Profile.iSpeakerID = " & Me.iSpeakerID)
    Set rs1 = db.OpenRecordset("Select iSpeakerID,sSurname,sGivenName,iExclusiveLevel FROM dbo_tbl_Speaker WHERE iSpeakerID = " & Me.iSpeakerID, dbOpenForwardOnly, dbSeeChanges)
    Set rs2 = db.OpenRecordset("Select * from dbo_tbl_config", dbOpenForwardOnly, dbSeeChanges)
    Set rs5 = db.OpenRecordset("Select * from dbo_tbl_Speaker_Comments WHERE iSpeakerID = " & Me.iSpeakerID, dbOpenForwardOnly, dbSeeChanges)
   
    cFont = rs2("font_size_profile")
    cHeaderImage = rs2("image_directory") & "saxton_header_for_profile.jpg"
   
    Set myrange = oWordDoc.Range(Start:=0, End:=0)
    oWordDoc.Tables.Add Range:=myrange, NumRows:=1, NumColumns:=2
    Set myTable = oWordDoc.Tables(1)
    myTable.Columns(1).Width = 360
    myTable.Columns(2).Width = 185
    myTable.LeftPadding = 30
   
   
    If Me.letter_choice = 1 Then
        'It is Saxton footer
        cFooterLinePage2 = "Melbourne Telephone: +61 3 9811 3500 Facsimile: +61 3 9813 2366 - Sydney Telephone: +61 2 9231 1900 Facsimile: +61 2 9231 1911 - Website: www.saxton.com.au - Email: speakers@saxton.com.au"
    End If
    If Me.letter_choice = 2 Then
        'It is SSB footer
        cFooterLinePage2 = "Suite 9, 385 Canterbury Road - PO Box 279 Dulwich Hill NSQ 2203 - Telephone: +61 2 9569 2966 - Mobile: 0408 020 263 - Website: www.sydneyspeakers.com.au - Email: tstafford@sydneyspeakers.com.au"
    End If
    If Me.letter_choice = 3 Then
        'It is QSB footer
        cFooterLinePage2 = "75 Markwell Street - Hamilton Qld 4007 - Telephone: +61 7 3868 1724 - Mobile: 0407 771 748 - Website: www.queenslandspeakers.com.au - Email: jbrophy@queenslandspeakers.com.au"
    End If
    If Me.letter_choice = 4 Then
        'It is SNI footer
        cFooterLinePage2 = "Level 2, 44a Avenue Road - Mosman NSW 2088 Australia - Telephone: +61 2 8968 6666 - Fax: +61 2 8968 6600 - Website: www.speakerseeker.com.au - Email: contact@speakerseeker.com.au"
    End If
    If Me.letter_choice = 5 Then
        'It is E&S footer
        cFooterLinePage2 = "Suite 605,Level 6, 276 Pitt Street, Sydney NSW 2000 - Telephone: +61 2 9267-5220 - Fax: +61 2 9267-4202 - Website: www.espeak.com.au - Email: info@espeak.com.au"
    End If
    If Me.letter_choice = 6 Then
        cFooterLinePage2 = "18-20 Fitzroy Stret, St Kilda VIC 3182 - Telephone: +61 3 8598 7806 - Fax: +61 3 8598 9222 - Website: www.profiletalent.com.au - Email: enq@profiletalent.com.au"
    End If
   
    With oWordDoc
        .Sections(1).Footers(wdHeaderFooterPrimary).Range.InsertBefore (cFooterLinePage2)
        .Sections(1).Footers(wdHeaderFooterPrimary).Range.Font.Name = "Arial"
        .Sections(1).Footers(wdHeaderFooterPrimary).Range.Font.Size = 5.5
        .Sections(1).Footers(wdHeaderFooterPrimary).Range.ParagraphFormat.Alignment = wdAlignParagraphCenter
        .Sections(1).Headers(wdHeaderFooterPrimary).Range.InlineShapes.AddPicture (cHeaderImage)
    End With
   
    'Following is the new code which was generated from the macro:
   
    With oWordDoc
        .Sections(1).Range.Select
       
        ActiveWindow.ActivePane.View.SeekView = wdSeekCurrentPageHeader
        Selection.HeaderFooter.Shapes.AddPicture(FileName:= _
            "D:\Common Images\qsb_header_page1.jpg", LinkToFile:=False, _
            SaveWithDocument:=True).Select
       'The following line generated a permissions error when I tried to run it the first time so I commented it out -
       'it didn't look important - is it?
        'Selection.ShapeRange.Name = "WordPictureWatermark1"
        Selection.ShapeRange.PictureFormat.Brightness = 0.5
        Selection.ShapeRange.PictureFormat.Contrast = 0.5
        Selection.ShapeRange.LockAspectRatio = True
        Selection.ShapeRange.Height = CentimetersToPoints(3.92)
        Selection.ShapeRange.Width = CentimetersToPoints(8.08)
        Selection.ShapeRange.WrapFormat.AllowOverlap = True
        Selection.ShapeRange.WrapFormat.Side = wdWrapNone
        Selection.ShapeRange.WrapFormat.Type = 3
        Selection.ShapeRange.RelativeHorizontalPosition = _
            wdRelativeVerticalPositionMargin
        Selection.ShapeRange.RelativeVerticalPosition = _
            wdRelativeVerticalPositionMargin
        Selection.ShapeRange.Left = wdShapeCenter
        Selection.ShapeRange.Top = wdShapeCenter
        ActiveWindow.ActivePane.View.SeekView = wdSeekMainDocument
    End With
   
   
    If IsNull(rs1("sGivenName")) Then
        cGivenName = ""
    Else
        cGivenName = StripName(Trim(rs1("sGivenName")))
    End If
    If IsNull(rs1("sSurname")) Then
        cSurname = ""
    Else
        cSurname = StripName(Trim(rs1("sSurname")))
    End If
   
    If cGivenName = "" Or cGivenName = Null Then
        cFullname = cSurname
        cFullname1 = rs1("sSurname")
    Else
        cFullname = cGivenName & "_" & cSurname
        cFullname1 = rs1("sGivenname") & " " & rs1("sSurname")
    End If
   

    '**************************************************************************
    'Note because of the bizarre nature of this object and the way ranges work,
    'we need to build the document from the bottom up!
    '**************************************************************************
   
    If Not rs5.EOF Then
        Set oRange = oWordDoc.Range(0, 0)
   
        With oRange
            .InsertBefore (vbCrLf & vbCrLf & "Click here to read Client Comments about " & rs1("sGivenName") & " " & rs1("sSurName"))
            oWordDoc.Hyperlinks.Add Address:="http://www.saxton.com.au/client_comments/" & cFullname & "_" & Me.iSpeakerID & ".html", Anchor:=oRange
        End With
       
        With oRange
            .Font.Name = "Verdana"
            .Font.Size = cFont
            .Font.Color = wdColorDarkBlue
            .Font.Bold = True
        End With
   
    End If
   
    If rs1("iExclusivelevel") = 1 Then
        ' We have an exclusive speaker which will have a full length profile
        Set oRange = oWordDoc.Range(0, 0)
       
        With oRange
            .InsertBefore (vbCrLf & vbCrLf & "Click to Read Full-Length Profile for " & rs1("sGivenName") & " " & rs1("sSurName"))
            oWordDoc.Hyperlinks.Add Address:="http://www.saxton.com.au/default.asp?nc8=4&sc8=140&sd8=" & Me.iSpeakerID, Anchor:=oRange
        End With
       
        With oRange
            .Font.Name = "Verdana"
            .Font.Size = cFont
            .Font.Color = wdColorDarkBlue
            .Font.Bold = True
        End With
       
    End If
   
    Set oRange = oWordDoc.Range(0, 0)
   
    With oRange
        If Not IsNull(rs("sOneLiners")) Then
            .InsertBefore (vbCrLf & vbCrLf & StripHTML(rs("sOneLiners")))
        End If
    End With
   
    With oRange
        .Font.Name = "Verdana"
        .Font.Size = cFont
        .ParagraphFormat.Alignment = wdAlignParagraphJustify
        .Font.Bold = False
    End With
   
    Set oRange = oWordDoc.Range(0, 0)
   
    If rs1("iExclusiveLevel") = 1 Then
        With oRange
             .InsertBefore (vbCrLf & "Exclusively represented by Saxton")
        End With
       
        With oRange
            .Font.Name = "Verdana"
            .Font.Size = "10"
            .Font.Italic = True
        End With
    End If
   
    Set oRange = oWordDoc.Range(0, 0)
   
    With oRange
         .InsertBefore (cFullname1)
    End With
   
    With oRange
        .Font.Name = "Verdana"
        .Font.Size = "12"
        .Font.Bold = True
        .Font.Italic = False
    End With
           
    With oWordDoc.Tables(1).Cell(1, 2)
       
        Set rs3 = db.OpenRecordset("SELECT * from dbo_tbl_Images WHERE [iSpeakerID] = " & rs("iSpeakerId") & " AND [iImageTypeID] = 2")
        If Not rs3.EOF Then
            If rs3("sImageLocation") <> "" Then
                With oWordDoc.InlineShapes.AddPicture(rs3("sImageLocation"), True, True, .Range)
                    .Borders.Enable = True
                    .Borders.OutsideLineWidth = wdLineWidth100pt
                End With
            End If
        End If
               
        Set rs4 = db.OpenRecordset("SELECT iSpeakerID,cTopic from dbo_tbl_Topics WHERE [iSpeakerID] = " & rs("iSpeakerId"))

        If Not rs4.EOF Then
            .Range.InsertAfter (vbCrLf & vbCrLf & "Speaking Topics" & vbCrLf)
        End If
       
        Do While Not rs4.EOF
            .Range.InsertAfter (vbCrLf & Chr(149) & " " & rs4("cTopic"))
            rs4.MoveNext
        Loop
       
        .Range.Font.Name = "Verdana"
        .Range.Font.Size = 8
        .Range.Font.Color = wdColorDarkBlue
       
    End With
   
    Set oWordDoc = Nothing
    Set oWordApp = Nothing
    Set rs = Nothing
    Set rs2 = Nothing
    Set rs1 = Nothing
    Set rs3 = Nothing
    Set rs4 = Nothing
    Set rs5 = Nothing
    Set db = Nothing
   
    Exit Sub
   
ErrorLike:

             
End Sub

_______________________________________________________________

Then I tried the second solution, and it worked, but only to the extent that it put a washed out image into the HEADER - I need it in the BODY...not the header...note: the good news is that I COULD type over the image, which is brilliant, now if only I could find a way to get this into the BODY background and not the header.  (I guess I could just have the header act as the body and have no body...if I needed to...)

So I'm not quite there yet...!  Please advise

yes please do and thanks for the headsup - doh!
your service is great!
Marc

If you want the image to appear on each page, then it must be anchored in the header (or footer). It is possible by adjusting the top, left, height and width properties to make the image appear anywhere that you wish on the page - whole page, body text only, etc. It could even be positioned to appear in the footer only, though it is anchored in the header. Note that these position properties are parameters in the AddPicture method, though they can be set later.

'either set dimensions to use in addpicture method
    sTop = CentimetersToPoints(1)
    sLeft= CentimetersToPoints(1)
    sHeight = CentimetersToPoints(20)
    sWidth= CentimetersToPoints(15)

    Set sh = wdDoc.Sections(1).Headers(wdHeaderFooterPrimary).Shapes.AddPicture(strFileName, False, True, sLeft, sTop, sWidth, sHeight, rng)

'or Change dimensions after insertion
    sh.LockAspectRatio = false 'allow aspect ratio to change
    sh.top= CentimetersToPoints(1)
   sh.left= CentimetersToPoints(1)
   sh.height = CentimetersToPoints(20)
   sh.width= CentimetersToPoints(15)


If you only want it to appear on a single page, it could be anchored to a paragraph in the body text and would appear on the same page as the paragraph. Let us know if that is what you need.

Oh, you've accepted the macro-recording answer while I was typing. Glad you got that to work. I couldn't.

the following works, and works for multiple pages - I modified it from the macro recording answer...took a while to fiddle but it is all good now - thanks a million

    dim oSelection as selection

    oWordDoc.Sections(1).Range.Select
    oWordDoc.ActiveWindow.ActivePane.View.SeekView = wdSeekCurrentPageHeader
    Set oSelection = oWordDoc.ActiveWindow.Selection
    oSelection.HeaderFooter.Shapes.AddPicture(FileName:="D:\Common Images\qsb_header_page1.jpg", LinkToFile:=False, SaveWithDocument:=True).Select
    oSelection.ShapeRange.PictureFormat.Brightness = 0.5
    oSelection.ShapeRange.PictureFormat.Contrast = 0.5
    oSelection.ShapeRange.LockAspectRatio = True
    oSelection.ShapeRange.WrapFormat.AllowOverlap = True
    oSelection.ShapeRange.WrapFormat.Side = wdWrapNone
    oSelection.ShapeRange.WrapFormat.Type = 3
    oSelection.ShapeRange.RelativeHorizontalPosition = wdRelativeVerticalPositionMargin
    oSelection.ShapeRange.RelativeVerticalPosition = wdRelativeVerticalPositionMargin
    oSelection.ShapeRange.Left = wdShapeCenter
    oSelection.ShapeRange.Top = wdShapeCenter
    oWordDoc.ActiveWindow.ActivePane.View.SeekView = wdSeekMainDocument

Yes. What I can't get to work from the macro recording is inserting a Watermark. Ordinary graphics aren't a problem.

interesting...this code was generated from inserting a watermark macro...

I might just be a problem in Word 2003, where recorded macros refer to a "PowerPlusWaterMarkObject"

a line I had to comment out from the macro gen routine was as follows:

    Selection.ShapeRange.Name = "WordPictureWatermark1"

If this doesn't relate to your issue then...I don't know.

I guess I'll find out when the client upgrades to 2003!

thanks again, I'm closing the book on this one...too busy!

cheers

Marc

That's slightly different. I doubt if you'll get a problem. Code usually works in later versions. Thanks for the feedback information and good luck.

actually there is a small problem that you might be able to help me with - at some point in the midst of all this macro and VBA code running my WORD module modified its configuration so images and links no longer show up properly except when I finally print a document

images are showing up like this: { INCLUDEPICTURE path-to-image * MERGEFORMAT }

and links are showing up like this: {HYPERLINK "mailto:blah@blah.com"}

in ALL my word docs.  (Note headers and footers and background images are all showing up fine!)

Not the end of the world but quite frustrating.  I have spent an hour trying to find the right word configuration element to change this back to the way it is supposed to be, but I can't find it.  Any idea what happened and how to fix it?

Thanks a million

There is a option - Tools/Options..., View tab, Field Codes checkbox or you can toggle the display with Alt+F9.

thanks - that did it...now you'll probably find the other problem soon!

cheers

Marc

Yes, I am working on it now.