Excel VBA creating Word Document and Field codes
Good Afternoon.
I have been working on a LIMS system based in excel and have nearly finish but one minor niggle.
(Note, before the suggestions come in,
No, creating a template with bookmarks and using that will not work (due to network security setting in place - they cannot/will not be change.)
No, creating the template as an embedded Object does not work either and the fidelity keeps getting lost.)
So userform is used to collect the data required, this then updates a log sheet before populating an excel sheet which is then copied and pasted into a new word document which is then automatically saved.
Titivation then takes place playing around with margins and adding standardised Header/Footer, This is where the problem arises....:banghead:
I am trying to put "Page 'X' of 'Y' " into the footer in column 2 of the table as marked in the code below [RED]. However, I cannot work out how to get the vbascript to add the field code in at this point. I have tried the code detailed below which causes the function to stop and kills any further running. If I leave this [With/End With] bit out then the report is generated but without the page numbers.
Help ??
Code:
Function FnWriteToWordDoc()
Set objWord = CreateObject("Word.Application")
Set objDoc = objWord.Documents.Add
Set objSelection = objWord.Selection
objWord.Visible = False ''
'######## Page Setup #############
With objSelection.PageSetup
.LineNumbering.Active = False
.Orientation = wdOrientPortrait
.TopMargin = CentimetersToPoints(2.27)
.BottomMargin = CentimetersToPoints(2.27)
.LeftMargin = CentimetersToPoints(1.27)
.RightMargin = CentimetersToPoints(1.27)
.Gutter = CentimetersToPoints(0)
.HeaderDistance = CentimetersToPoints(0.75)
.FooterDistance = CentimetersToPoints(0.75)
.PageWidth = CentimetersToPoints(21)
.PageHeight = CentimetersToPoints(29.7)
.FirstPageTray = wdPrinterDefaultBin
.OtherPagesTray = wdPrinterDefaultBin
.SectionStart = wdSectionNewPage
.OddAndEvenPagesHeaderFooter = False
.DifferentFirstPageHeaderFooter = False
.VerticalAlignment = wdAlignVerticalTop
.SuppressEndnotes = False
.MirrorMargins = False
.TwoPagesOnOne = False
.BookFoldPrinting = False
.BookFoldRevPrinting = False
.BookFoldPrintingSheets = 1
.GutterPos = wdGutterPosLeft
End With
With objSelection
.Paste '> Paste the Excel Data into Word
.InsertBreak Type:=wdPageBreak
.Font.Size = 14
.Font.Bold = True
.Font.Underline = wdUnderlineSingle
.TypeText Text:="Summary:"
.TypeParagraph
.Font.Size = 11
.Font.Bold = False
.Font.Underline = wdUnderlineNone
.TypeText Text:="xx:"
.TypeParagraph
.TypeParagraph
.Font.Size = 14
.Font.Bold = True
.Font.Underline = wdUnderlineSingle
.TypeText Text:="Report:"
.TypeParagraph
.Font.Size = 11
.Font.Bold = False
.Font.Underline = wdUnderlineNone
.TypeText Text:="xx:"
.TypeParagraph
.TypeParagraph
End With
Dim oTbl
'HEADER<<<<<<<<<
objDoc.Sections(1).Headers(wdHeaderFooterPrimary).Range.Tables.Add _
Range:=objDoc.Sections(1).Headers(wdHeaderFooterPrimary).Range, _
NumRows:=1, _
NumColumns:=3
Set oTbl = objDoc.Sections(1).Headers(1).Range.Tables(1)
With oTbl.Cell(1, 1).Range
.Font.Size = 16
.Font.Color = 192
.ParagraphFormat.Alignment = wdAlignParagraphLeft
.Text = "MATERIALS REVIEW"
End With
With oTbl.Cell(1, 2).Range
.Font.Size = 14
.ParagraphFormat.Alignment = wdAlignParagraphCenter
.Text = "Laboratory Report"
End With
With oTbl.Cell(1, 3).Range
.Font.Size = 14
.Font.Color = 192
.ParagraphFormat.Alignment = wdAlignParagraphRight
.Text = "Request: " & E_Req
End With
Set oTbl = Nothing
'FOOTER <<<<<<<<<
objDoc.Sections(1).Footers(wdHeaderFooterPrimary).Range.Tables.Add _
Range:=objDoc.Sections(1).Footers(wdHeaderFooterPrimary).Range, _
NumRows:=1, _
NumColumns:=3
Set oTbl = objDoc.Sections(1).Footers(1).Range.Tables(1)
With oTbl.Cell(1, 1).Range
.Font.Size = 11
.ParagraphFormat.Alignment = wdAlignParagraphLeft
.Text = "DO NOT COPY WITHOUT PERMISSION OF QUALITY MANAGER"
End With
With oTbl.Cell(1, 2).Range <<This 'WITH Section' is where the issue is.
.Fields.Add Range:=oTbl.Cell(1, 2).Range, _
Type:=wdFieldEmpty, _
Text:="NUMPAGES \* Arabic", _
PreserveFormatting:=True
End With
With oTbl.Cell(1, 3).Range
.Font.Size = 12
.Font.Color = 192
.ParagraphFormat.Alignment = wdAlignParagraphRight
.Text = "CONFIDENTIAL"
End With
Set oTbl = Nothing
'## Save Script
If REPRINT = True Then
objDoc.SaveAs (S_PATH & E_Req & "rp - " & E_DESC)
Else
objDoc.SaveAs (S_PATH & E_Req & " - " & E_DESC) 'Save the template with data in by RQ number and description in the Reports Path
End If
MsgBox ("Your Lab request has been raised." & vbCrLf & _
"to add any further information please open the word file " & vbCrLf & _
E_Req & " - " & E_DESC)
objWord.Visible = True
End Function
