VB MS Word header

Thread view:

Enable EMail Alerts

Start New Thread

Thread rating:

graham_s - 06 Feb 2006 21:26 GMT

Hi,
I have copied some code that previously wrote to a Word doc page to write to
the page header. The code below is as far as I have got as there are some
problems.
1. The font.bold and font.size do not work
2. The copy and paste of the logo.bmp does not work
3. The tabstops are at different spacings compared to those when set on a
'normal' page
4. The line does not draw.

Can anyone help?
I would appreciate learning the best way to achieve this as my VBA word
knowledge is minimal (as evidenced by the code below!).

Thanks

Graham

////
code
Sub PrintStandardHeaderMSwordHeader(mobjWord As Object, RegisteredUser, _
Project, _
jobno, _
Subject, _
Calcby)

' Called from PrintCalcSheetHeader()

With mobjWord.ActiveDocument.Sections(1).Headers(wdHeaderFooterPrimary).Range

.Paragraphs.tabstops.Add position:=370 ' 72 points/inch

If FileExists(App.Path & "\userlogo.bmp") Then
Clipboard.Clear
Clipboard.SetData LoadPicture(App.Path & "\userlogo.bmp") ' Get bitmap.
.Paste
.text = vbTab
Clipboard.Clear
Else
.font.Name = "arial"
.font.SIZE = 14
.font.Bold = True
.text = RegisteredUser & vbTab
End If

.font.SIZE = 11
.font.Bold = False
.insertafter "Vol. . . . . . "
.insertafter " Sec . . . . ." & vbCrLf

.insertafter "PROJECT : "
.insertafter Project & vbTab

.insertafter "Sheet . . . . . . of . . . . ." & vbCrLf
.insertafter "SUBJECT : "
.insertafter Subject & vbTab
.insertafter "Job No : "
.insertafter jobno & vbCrLf

.Paragraphs.tabstops(1).Clear
.Paragraphs.tabstops.Add position:=100
.Paragraphs.tabstops.Add position:=230
.Paragraphs.tabstops.Add position:=350

.insertafter "Calc by : "
.insertafter Calcby & vbTab
.insertafter "Date : "
.insertafter Format(Now, "dd-mmm-yy") & vbTab
.insertafter "Checked : " & vbTab
.insertafter "Date :" & vbCrLf

' draw a line under the header
.Paragraphs(1).tabstops.clearall
.Paragraphs.tabstops.Add position:=490
.font.underline = True
.insertafter vbTab
.font.underline = False
End With

End Sub

Reply to this Message

Cindy M -WordMVP- - 08 Feb 2006 14:14 GMT

Hi =?Utf-8?B?Z3JhaGFtX3M=?=,

> I have copied some code that previously wrote to a Word doc page to write to
> the page header. The code below is as far as I have got as there are some
> problems.
> 1. The font.bold and font.size do not work

Since we don't have sample values for the parameters, we can't really test, but
from looking through the code...

You start with an If-test, and in the Else part you apply formatting to the
Range. After the IF, you apply formatting again - to the SAME range. This will
override the formatting applied previously.

You should assign the range to a range variable:
dim rng as Word.Range
set rng =
ActiveDocument.Sections(1).PageSetup.Headers(wdHeaderFooterPrimariy).Range

Then use this in the code that follows. After the IF, in order to not lose what
you've done to the range, move the focus to the end of the range:
rng.Collapse wdCollapseEnd

Apply the formatting to a range AFTER you insert the text (unlike with the
Selection object).

> 2. The copy and paste of the logo.bmp does not work

Try using the InlineShapes.AddPicture method instead of copy/paste

> 3. The tabstops are at different spacings compared to those when set on a
> 'normal' page

Please provide more information (what you get vs what you expect)

> 4. The line does not draw.

The information on formatting and ranges may help, here

Cindy Meister
INTER-Solutions, Switzerland
http://homepage.swissonline.ch/cindymeister (last update Jun 8 2004)
http://www.word.mvps.org

This reply is posted in the Newsgroup; please post any follow question or reply
in the newsgroup and not by e-mail :-)

Reply to this Message

graham_s - 08 Feb 2006 21:29 GMT

Cindy,
Many thanks.
The code simply prints a facsimile engineering calculation sheet and the
input is generally strings except for the MS Word object, see comments in the
sub.

I found I had to use 'collapsestart' after the first format otherwise the
first text became the last.

I now only need to sort out the tabs. I cannot get them to work at all.
I want the first tab to be approx 75% of page width,

Sub PrintStandardHeaderMSwordHeader(mobjWord As Object, RegisteredUser, _
Project, _
jobno, _
Subject, _
Calcby)

'IN
' mobjWord = a MS word object, created as below
'Set mobjWord = CreateObject("Word.application")
'If Not mobjWord Is Nothing Then mobjWord.Visible = True
'Set mobjDoc = mobjWord.Documents.Add(App.Path & "\toolkit.dot")

'RegisteredUser =string for printing on output sheet
'Project =string
'jobno =string
'Subject =string
'Calcby =string

' Called from PrintCalcSheetHeader()

With mobjWord.ActiveDocument.Sections(1)
.Footers(wdHeaderFooterPrimary).PageNumbers.Add FirstPage:=True ',
Alignment:=wdAlignleft
End With

With mobjWord.ActiveDocument.Sections(1).Headers(wdHeaderFooterPrimary).Range

If FileExists(App.Path & "\userlogo.bmp") Then
.InlineShapes.AddPicture Filename:=App.Path & "\userlogo.bmp"
.insertafter vbTab '(First tab space)
Else
.text = RegisteredUser & vbTab '(First tab space)
End If
.font.Name = "Arial"
.font.SIZE = 20
.Bold = True
'.Paragraphs.TabStops.Add position:=270 ' 72 points/inch 'FIRST TAB setting
.Collapse wdCollapseStart 'if I use wdCollapseEnd here, the text is moved to
the bottom of the header

.insertafter "Vol. . . . . . Sec . . . . ." & vbCrLf

.insertafter "PROJECT : " & Project & vbTab '(first tab space)

.insertafter "Sheet . . . . . . of . . . . ." & vbCrLf
.insertafter "SUBJECT : " & Subject & vbTab '(first tab space)
.insertafter "Job No : " & jobno & vbCrLf

.insertafter "Calc by : " & Calcby & vbTab '(2nd tab space)
.insertafter "Date : " & Format(Now, "dd-mmm-yy") & vbTab ' '(3rd tab space)
.insertafter "Checked : " & vbTab '(4th tab space)
.insertafter "Date :" & vbCrLf

'.Paragraphs.TabStops(1).Clear
'.Paragraphs.TabStops.Add position:=100 '2nd
'.Paragraphs.TabStops.Add position:=230 '3rd
'.Paragraphs.TabStops.Add position:=350 '4th

.font.SIZE = 11
.Bold = False
.Collapse wdCollapseStart

' draw a line under the header
.InlineShapes.AddHorizontalLineStandard

End With
End Sub

> Hi =?Utf-8?B?Z3JhaGFtX3M=?=,
>
[quoted text clipped - 42 lines]
> This reply is posted in the Newsgroup; please post any follow question or reply
> in the newsgroup and not by e-mail :-)

Reply to this Message

graham_s - 11 Feb 2006 11:01 GMT

For the archives.
The final solution is below. No thanks to MS 'upside down' logic. ;-)

Sub PrintStandardHeaderMSwordHeader(mobjWord As Object, RegisteredUser, _
Project, _
jobno, _
Subject, _
Calcby)

'IN
' mobjWord = a MS word object, created as below
'Set mobjWord = CreateObject("Word.application")
'If Not mobjWord Is Nothing Then mobjWord.Visible = True
'Set mobjDoc = mobjWord.Documents.Add(App.Path & "\toolkit.dot")

'RegisteredUser =string for printing on output sheet
'Project =string
'jobno =string
'Subject =string
'Calcby =string

' Called from PrintCalcSheetHeader()

With mobjWord.ActiveDocument.Sections(1)
.Footers(wdHeaderFooterPrimary).PageNumbers.Add FirstPage:=True
End With

With mobjWord.ActiveDocument.Sections(1).Headers(wdHeaderFooterPrimary).Range

.text = "" 'set a default font size otherwise get font 20 as last line
feed after the header "underline"

If FileExists(App.Path & "\userlogo.bmp") Then

.InlineShapes.AddPicture Filename:=App.Path & "\userlogo.bmp"
.InsertAfter vbTab

.font.Name = "Arial"
.font.SIZE = 8 'apply default font of 8
.Collapse wdCollapseStart

Else
.font.Name = "Arial"
.font.SIZE = 8
.Collapse wdCollapseStart

.InsertAfter RegisteredUser & vbTab
End If

'Apply formatting to above text (RegisteredUser)
.font.Name = "Arial"
.font.SIZE = 20
.Bold = True
.Paragraphs.TabStops.Add position:=375
.Collapse wdCollapseStart

.InsertAfter "Vol. . . . . . Sec . . . . ." & vbCrLf
.InsertAfter "PROJECT : " & Project & vbTab
.InsertAfter "Sheet . . . . . . of . . . . ." & vbCrLf
.InsertAfter "SUBJECT : " & Subject & vbTab
.InsertAfter "Job No : " & jobno & vbCrLf

'Apply formatting to text immediately above, (tabstop unchanged)
.font.SIZE = 11
.Bold = False
.Collapse wdCollapseStart

.InsertAfter "Calc by : " & Calcby & vbTab
.InsertAfter "Date : " & Format(Now, "dd-mmm-yy") & vbTab
.InsertAfter "Checked :. . . . . . . . ." & vbTab
.InsertAfter "Date :. . . . . . . . " & vbCrLf

' Apply (add) new tabstops to above and re-state text format (otherwise
the first size is applied)
.font.SIZE = 11
.Bold = False
.Paragraphs.TabStops.Add position:=120
.Paragraphs.TabStops.Add position:=230
.Collapse wdCollapseStart

' draw a line under the header
.font.SIZE = 8
.InsertAfter vbCrLf 'move line down a little
.InlineShapes.AddHorizontalLineStandard

.Collapse wdCollapseEnd

End With

End Sub

> Cindy,
> Many thanks.
[quoted text clipped - 123 lines]
> > This reply is posted in the Newsgroup; please post any follow question or reply
> > in the newsgroup and not by e-mail :-)

Reply to this Message