Results 1 to 11 of 11
  1. #1
    Star Lounger
    Join Date
    Apr 2002
    Location
    Sydney Australia, New South Wales, Australia
    Posts
    72
    Thanks
    0
    Thanked 0 Times in 0 Posts

    Inserting Picture in Header (VBA Word 2000)

    I am trying to insert a logo in the header of each section of my documents
    I am accessing the logo from a meta file as add picture
    My problem is that if I step through the code it all works, however if I run it some headers don't get the logo.
    I think this is because the file is still open when that header gets attention.

    Is there a way I can create the first Logo then insert this in following headers ?
    I would prefer not to use select as this causes the screen to jump between views.
    I have therefore based my code on range rather than select.
    I also convert to shape after insertion so I can position the Logo.

    Any Ideas

    From Ralph DownUnder

  2. #2
    Super Moderator jscher2000's Avatar
    Join Date
    Feb 2001
    Location
    Silicon Valley, USA
    Posts
    23,112
    Thanks
    5
    Thanked 93 Times in 89 Posts

    Re: Inserting Picture in Header (VBA Word 2000)

    You might need to post your code for better answers, but I have a suggestion. How about you insert the graphic in the first header and bookmark it. Then, in the other first page headers, assuming you do not have them linked to previous, just use a REF field with the name of the bookmark. (This is not to say that inserting a Field to a Range without wiping out the contents isn't a tad tricky, but there is code here in the lounge for doing it in the footer that should be adaptable to your needs.)

  3. #3
    Star Lounger
    Join Date
    Apr 2002
    Location
    Sydney Australia, New South Wales, Australia
    Posts
    72
    Thanks
    0
    Thanked 0 Times in 0 Posts

    Re: Inserting Picture in Header (VBA Word 2000)

    Thanks for the suggestion.
    The problem is even stranger than I first thought.
    I put a wait between the insert of each picture and it didn't help !
    What is realy strange is that If I run the code once it Fails to insert past the first section.
    If I run it a second time it works.
    The code deletes then re-creates each header for a section (also adjusts for margins and paper size) so it isn't building.
    This behaviour seems consistent and I have no explanation.

    I have to go now but I will post my code later.

    Thanks again

    Ralph

  4. #4
    Star Lounger
    Join Date
    Apr 2002
    Location
    Sydney Australia, New South Wales, Australia
    Posts
    72
    Thanks
    0
    Thanked 0 Times in 0 Posts

    Re: Inserting Picture in Header (VBA Word 2000)

    Here is the code for the Header Footer Update
    This is called from another module which sets the Authority, RevType and UpdateData veriables according to where the document is about to get saved and user input as to if an update to the Revision and Authorisation Data is required (UpdateData Boolean)
    The reason for the complexity in obtaining OldRevDate is that I am in the process of changing over from one layout to another as the documents are updated.
    Any way here is the code.

    Option Explicit
    Option Compare Text
    Dim TextWidth As Long
    Dim LMargin As Long
    Dim RMargin As Long
    Dim PgNumbers As Variant
    Public SectX As Section
    Public ThisSection As Range
    Dim Logo As Variant
    Public OldRevDate As String
    Public OldAuthority As String
    Dim Position1 As Integer
    Dim Position2 As Integer
    Dim DatePosition As Integer
    Dim x As Integer
    Dim y As Integer
    Dim z As Integer
    Dim SectNo As Integer
    Dim TargetDate As Date
    Dim RevData As String

    Function UpDateHandF()
    ActiveDocument.UpdateStyles
    Call CheckUserName
    'ActiveDocument.StoryRanges(1).Select
    For Each SectX In ActiveDocument.Sections
    Set ThisSection = SectX.Headers(wdHeaderFooterPrimary).Range
    OldRevDate = Mid(Right(ThisSection.Text, 12), 1, 11) 'Mid strips the CRLF off the end
    If UpdateData = False Then 'Preserve the old date
    If OldRevDate Like "##?*?####" Then 'This is the old Rev date from the Header
    RevData = RevType & OldRevDate
    Else 'Get the old Rev date from the footer
    DatePosition = InStr(1, ThisSection.Paragraphs(1).Range.Text, " ") + 2
    OldRevDate = Mid(SectX.Footers(wdHeaderFooterPrimary).Range.Tex t, DatePosition, 11)
    If OldRevDate Like "##-*-####" Then 'found the old rev in the footer
    RevData = RevType & OldRevDate
    Else 'Revision not on document put it in
    RevData = RevType & Format(Now(), "dd-mmm-yyyy")
    End If
    End If
    Else ' update is true refresh revision date
    RevData = RevType & Format(Now(), "dd-mmm-yyyy")
    End If
    ThisSection.Delete ' Clear the Header
    'Set ThisSection = SectX.Headers(wdHeaderFooterPrimary).Range
    Call SetHeaderMargins_Tabs
    Call UpdateHeaderInformation
    Call UnderlineHeader
    Set ThisSection = SectX.Footers(wdHeaderFooterPrimary).Range
    ThisSection.Collapse
    Position1 = ThisSection.MoveEndUntil(Cset:=vbTab, Count:=100)
    Position2 = InStr(1, ThisSection.Paragraphs(1).Range.Text, "Page")
    Set ThisSection = SectX.Footers(wdHeaderFooterPrimary).Range
    If Position2 > Position1 Then
    OldAuthority = Mid(ThisSection.Text, Position1 + 1, Position2 - Position1 - 2)
    End If
    If UpdateData = False Then
    Approver = ""
    End If
    If Approval = "Use OldAuthority" Then
    Approval = OldAuthority
    Else
    Approval = Approval
    End If
    Set ThisSection = SectX.Footers(wdHeaderFooterPrimary).Range
    ThisSection.Delete ' Clear the Footer
    Call SetFooterMargins_Tabs
    Call UpdateFooterInformation
    Next SectX
    ActiveDocument.Characters(1).Select
    Selection.Collapse
    End Function
    Private Sub SetHeaderMargins_Tabs()
    'Set ThisSection = SectX.Headers(wdHeaderFooterPrimary).Range
    TextWidth = SectX.PageSetup.PageWidth
    LMargin = SectX.PageSetup.LeftMargin
    RMargin = SectX.PageSetup.RightMargin
    TextWidth = TextWidth - LMargin - RMargin
    With ThisSection.ParagraphFormat.TabStops
    .ClearAll
    .Add Position:=TextWidth, Alignment:=wdAlignTabRight
    .Add Position:=Int(TextWidth / 2), Alignment:=wdAlignTabCenter
    End With
    End Sub
    Private Sub UpdateHeaderInformation()
    With ThisSection
    .InsertAfter Text:="A Leighton Group Company" & vbTab & vbTab
    .InlineShapes.AddPicture FileName:= _
    "G:TEMPLATElse_logo_colour.wmf", LinkToFile:=True, SaveWithDocument:= _
    True
    'If SectX.Index > 1 Then Wait (0)
    .InlineShapes(x).LockAspectRatio = msoTrue
    .InlineShapes(x).Height = 25.5
    .InlineShapes(x).Width = 42.25
    .InlineShapes(x).ConvertToShape
    End With
    For Each Logo In SectX.Headers(wdHeaderFooterPrimary).Shapes
    With Logo
    .RelativeHorizontalPosition = wdRelativeHorizontalPositionMargin
    .RelativeVerticalPosition = wdRelativeVerticalPositionParagraph
    .LockAspectRatio = msoTrue
    .Top = CentimetersToPoints(0.4)
    .Left = wdShapeRight
    .LockAnchor = True
    End With
    Next Logo
    End Sub
    Private Sub UnderlineHeader()
    With ThisSection.ParagraphFormat
    .Borders(wdBorderLeft).LineStyle = wdLineStyleNone
    .Borders(wdBorderRight).LineStyle = wdLineStyleNone
    .Borders(wdBorderTop).LineStyle = wdLineStyleNone
    '.Borders(wdBorderHorizontal).LineStyle = wdLineStyleNone
    With .Borders(wdBorderBottom)
    .LineStyle = wdLineStyleSingle
    .LineWidth = wdLineWidth025pt
    .Color = wdColorGray50
    End With
    With .Borders
    .DistanceFromTop = 1
    .DistanceFromLeft = 4
    .DistanceFromBottom = 15
    .DistanceFromRight = 4
    .Shadow = False
    End With
    End With
    With Options
    .DefaultBorderLineStyle = wdLineStyleSingle
    .DefaultBorderLineWidth = wdLineWidth025pt
    .DefaultBorderColor = wdColorGray50
    End With
    End Sub
    Private Sub SetFooterMargins_Tabs()
    Set ThisSection = SectX.Footers(wdHeaderFooterPrimary).Range
    TextWidth = SectX.PageSetup.PageWidth
    LMargin = SectX.PageSetup.LeftMargin
    RMargin = SectX.PageSetup.RightMargin
    TextWidth = TextWidth - LMargin - RMargin
    With ThisSection.ParagraphFormat.TabStops
    .ClearAll
    .Add Position:=TextWidth, Alignment:=wdAlignTabRight
    .Add Position:=Int(TextWidth / 2), Alignment:=wdAlignTabCenter
    End With
    End Sub
    Private Sub UpdateFooterInformation()
    ' Write Footer Information
    ThisSection.Font.Color = wdColorGray50
    ThisSection.InsertAfter RevData & vbTab & Approval & Approver & vbTab
    ThisSection.EndOf
    NormalTemplate.AutoTextEntries("page x of y").Insert Where:=ThisSection
    Call OverlineParagraph
    Set ThisSection = SectX.Footers(wdHeaderFooterPrimary).Range
    ThisSection.InsertParagraphAfter
    ThisSection.Font.Color = wdColorGray50
    With ThisSection.Paragraphs(2)
    .SpaceBefore = 0
    .SpaceBeforeAuto = False
    .SpaceAfter = 4
    .SpaceAfterAuto = False
    .LineSpacingRule = wdLineSpaceSingle
    End With
    ThisSection.InsertAfter Text:=FileAndPath
    End Sub
    Private Sub OverlineParagraph()
    With ThisSection.Paragraphs(1)
    .Borders(wdBorderLeft).LineStyle = wdLineStyleNone
    .Borders(wdBorderRight).LineStyle = wdLineStyleNone
    .Borders(wdBorderBottom).LineStyle = wdLineStyleNone
    With .Borders(wdBorderTop)
    .LineStyle = wdLineStyleSingle
    .LineWidth = wdLineWidth025pt
    .Color = wdColorGray50
    End With
    With .Borders
    .DistanceFromTop = 1
    .DistanceFromLeft = 4
    .DistanceFromBottom = 1
    .DistanceFromRight = 4
    .Shadow = False
    End With
    End With
    With Options
    .DefaultBorderLineStyle = wdLineStyleSingle
    .DefaultBorderLineWidth = wdLineWidth025pt
    .DefaultBorderColor = wdColorGray50
    End With
    End Sub
    Function Wait(TimeDelay)
    Dim TargetDate As Date
    TargetDate = Now()
    While DateDiff("s", TargetDate, Now()) < TimeDelay
    Wend
    'MsgBox "Time is up", vbOKOnly, "Timer"
    End Function

  5. #5
    Super Moderator jscher2000's Avatar
    Join Date
    Feb 2001
    Location
    Silicon Valley, USA
    Posts
    23,112
    Thanks
    5
    Thanked 93 Times in 89 Posts

    Re: Inserting Picture in Header (VBA Word 2000)

    This is way too complicated to parse out at midnight, and I am not good with Shape objects. But...if all your headers are identical, why not link them to previous and just insert the first one?

  6. #6
    Star Lounger
    Join Date
    Apr 2002
    Location
    Sydney Australia, New South Wales, Australia
    Posts
    72
    Thanks
    0
    Thanked 0 Times in 0 Posts

    Re: Inserting Picture in Header (VBA Word 2000)

    That's my Problem I have to accomodate different sections with different layouts so the heasers vary considerably.
    Most of the code is to accomodate different page widths and to get old data from the old documents, I also have to convert to shape and re-position the Logo to get it where I want it.

    I am off for the weekend now so have a good weekend yourself.

    Thanks

  7. #7
    Super Moderator
    Join Date
    Jan 2001
    Location
    Melbourne, Victoria, Australia
    Posts
    3,852
    Thanks
    4
    Thanked 259 Times in 239 Posts

    Re: Inserting Picture in Header (VBA Word 2000)

    Without looking at your code I might throw something else into the mix in case it is a factor here.

    If you are using floating objects in your headers, you may notice an oddity in that these objects appear not to be held as objects within that header only. For instance this code does not restrain itself to the Section 1 Primary header.
    <pre> 'Note this actually deletes every floating object in every header
    For Each aShape In ActiveDocument.Sections(1).Headers(wdHeaderFooterP rimary).Shapes
    aShape.Delete
    Next aShape</pre>

    If you are using inline objects then you might get more predictable results. This same oddity can bite you when trying to check if the floating object is already present in the specified header.
    Andrew Lockton, Chrysalis Design, Melbourne Australia

  8. #8
    Star Lounger
    Join Date
    Apr 2002
    Location
    Sydney Australia, New South Wales, Australia
    Posts
    72
    Thanks
    0
    Thanked 0 Times in 0 Posts

    Re: Inserting Picture in Header (VBA Word 2000)

    That is very interesting.
    I do float the objects as I need to place them 2/3 below the line.

    Does this mean that ActiveDocument.Sections(1).Headers(wdHeaderFooterP rimary).Shapes
    aShape.Delete
    will delete all occurances of aShape in all Sections of the document ?

    PS How do you put indents in your posts.
    If I could do that it would make code i post a lot more readable.

  9. #9
    Plutonium Lounger
    Join Date
    Dec 2000
    Location
    Sacramento, California, USA
    Posts
    16,775
    Thanks
    0
    Thanked 1 Time in 1 Post

    Re: Inserting Picture in Header (VBA Word 2000)

    I'll answer the question about the indents. There are two methods. One is to use the <!t>[tab]<!/t> tag from the 1-click tagpanel (you see link to it when you create a post) or to simply type the tag into your post without using the panel. The other is to use the <!t>[Pre]text<!t>[/Pre]<!/t> tags from the same panel. The latter applies to a block of text, not just a line, but they also change the font to a courier with fixed spacing, which makes the code more readable if punctuation is involved.
    Charlotte

  10. #10
    Super Moderator
    Join Date
    Jan 2001
    Location
    Melbourne, Victoria, Australia
    Posts
    3,852
    Thanks
    4
    Thanked 259 Times in 239 Posts

    Re: Inserting Picture in Header (VBA Word 2000)

    Yes, unfortunately it does. It was a major problem for me when I needed a macro to insert a watermark on all the pages of a document.

    The code I came up with in the end was a kludge but did the job sufficiently as I don't generally float objects (no choice on a watermark) because of the file size and control issues that come along with it. I had to insert a bookmark as a placeholder in each header to indicate whether the floating object is being placed there. Just placing a floating object in each header is no good because some of the headers may be linked to previous and some may not. Similarly just testing for this condition wont catch all headers as the header can be there but not picked up in the troll through because the section may be too short (eg and first page special is on). I liken this approach to leaving breadcrumbs along the path.

    If you are interested, the code is below
    <pre>'Prompts the user to input the watermark text and then creates it
    Dim iResponse As Integer, aShape As Shape
    Dim sWarning As String, sWord As String, iCount As Integer

    On Error GoTo ErrCatcher
    With ActiveWindow
    If .View.SplitSpecial <> wdPaneNone Then .Panes(2).Close
    .ActivePane.View.Type = wdNormalView
    End With
    'move to the Top of file
    Selection.HomeKey Unit:=wdStory

    ' Ask to remove all floating shapes from all headers/footers
    iResponse = MsgBox("Do you want to delete all floating objects from all Headers?" _
    & vbCr & vbCr & "This includes any existing Watermarks", _
    vbYesNoCancel, "Remove Floating Objects")
    If iResponse = vbYes Then
    'Note this actually deletes every floating object in every header
    For Each aShape In ActiveDocument.Sections(1).Headers(wdHeaderFooterP rimary).Shapes
    aShape.Delete
    Next aShape
    ElseIf iResponse = vbCancel Then
    Exit Sub
    End If

    'Gets user input to type the word to use as a watermark
    sWarning = "Please type in the word you want watermarked!" & vbCr & _
    "Click CANCEL to not add a Watermark"
    sWord = InputBox(sWarning, "Watermarker", "D R A F T")
    If sWord = "" Then Exit Sub 'If the user clicked cancel end the macro

    'Now creates the graphic which will be used as the watermark
    With ActiveWindow
    If .View.SplitSpecial <> wdPaneNone Then .Panes(2).Close
    .ActivePane.View.Type = wdPageView
    .ActivePane.View.SeekView = wdSeekCurrentPageHeader
    End With
    Selection.HeaderFooter.Shapes.AddTextEffect(msoTex tEffect13, sWord, _
    "Arial Black", 80#, msoFalse, msoFalse, 144.95, 139.1).Select
    With Selection.ShapeRange
    .Fill.ForeColor.RGB = RGB(180, 180, 180)
    .Fill.Visible = msoTrue
    .Fill.Solid
    .Shadow.Visible = msoFalse
    .IncrementRotation -30#
    If .Width > PointsToCentimeters(16) Then
    .Width = CentimetersToPoints(16)
    End If
    .Align msoAlignCenters, True
    .Align msoAlignMiddles, True
    End With
    Selection.Copy 'stores this graphic in the clipboard
    'add a bookmark to indicate that a floater is here
    ActiveDocument.Bookmarks.Add Name:="zAnchor" & iCount, Range:=Selection.Range

    With ActiveWindow.ActivePane.View
    While Not False '(.NextHeaderFooter Is Nothing) 'doesn't work
    .NextHeaderFooter 'error 4605 if already in last header in doc
    iCount = iCount + 1
    If IncludesAnchor("zAnchor") = False Then
    'leave a bread crumb to mark the spot
    ActiveDocument.Bookmarks.Add Name:="zAnchor" & iCount, Range:=Selection.Range
    'stick in the graphic and centre on page
    Selection.Paste
    Selection.ShapeRange.Align msoAlignCenters, True
    Selection.ShapeRange.Align msoAlignMiddles, True
    End If
    Wend
    End With

    Exit Sub 'will never see this line unless error is avoided

    ErrCatcher:
    If Err.Number = 4605 Then 'caused by going forward from last header
    ActiveWindow.ActivePane.View.SeekView = wdSeekMainDocument
    ActiveWindow.ActivePane.View.Type = wdNormalView
    AnchorsAway ("zAnchor") 'clean away the bread crumbs
    Else
    MsgBox "There was an unexpected error. Please check the result" & vbCr & _
    vbCr & Err.Number & vbCr & Err.Description
    End If
    End Sub
    Function IncludesAnchor(sBk As String) As Boolean
    Dim aBookmark As Bookmark
    IncludesAnchor = False
    Selection.WholeStory
    For Each aBookmark In Selection.Bookmarks
    If Left(aBookmark.Name, 7) = sBk Then IncludesAnchor = True
    Next aBookmark
    Selection.Collapse Direction:=wdCollapseStart
    End Function
    Function AnchorsAway(sBk As String)
    Dim aBookmark As Bookmark
    For Each aBookmark In ActiveDocument.Bookmarks
    If Left(aBookmark.Name, 7) = sBk Then aBookmark.Delete
    Next aBookmark
    End Function</pre>

    Andrew Lockton, Chrysalis Design, Melbourne Australia

  11. #11
    Star Lounger
    Join Date
    Apr 2002
    Location
    Sydney Australia, New South Wales, Australia
    Posts
    72
    Thanks
    0
    Thanked 0 Times in 0 Posts

    Re: Inserting Picture in Header (VBA Word 2000)

    Thanks for the suggestion and code
    I don't think bookmarks will help in my case since I actually delete and re-create the headers and footers of the entire document each time a change is implemented.
    I think I will try deleting them all first then re-creating them, this may get arround the problem, since it appears that my detetions may be deleting my previous creations.
    I have other things on my plate for the next couple of weeks but I will let you know how this works when I get to it.

    Thanks Again

Posting Permissions

  • You may not post new threads
  • You may not post replies
  • You may not post attachments
  • You may not edit your posts
  •