I am able to update the header of a document with text and field properties with the code below
Dim myRange As Range
With ActiveDocument
Set myRange = .Sections(1).Headers(wdHeaderFooterPrimary).Range
.Fields.Add Range:=myRange, Type:=wdFieldEmpty, Text:="STYLEREF Title", PreserveFormatting:=True
myRange.Collapse wdCollapseStart
myRange.Text = ""
myRange.ParagraphFormat.Alignment = wdAlignParagraphRight
Set myRange = .Sections(1).Headers(wdHeaderFooterPrimary).Range
myRange.Collapse wdCollapseEnd
myRange.InsertParagraphAfter
myRange.Collapse wdCollapseEnd
myRange.Text = "Name: "
myRange.Collapse wdCollapseEnd
.Fields.Add Range:=myRange, Type:=wdFieldEmpty, Text:="Name_1", PreserveFormatting:=True
myRange.Fields.Update
Set myRange = .Sections(1).Headers(wdHeaderFooterPrimary).Range
myRange.Collapse wdCollapseEnd
myRange.InsertParagraphAfter
myRange.Collapse wdCollapseEnd
.Fields.Add Range:=myRange, Type:=wdFieldDate, PreserveFormatting:=True
myRange.Collapse wdCollapseStart
myRange.Text = "Date: "
myRange.Fields.Update
myRange.ParagraphFormat.Alignment = wdAlignParagraphRight
Set myRange = .Sections(1).Headers(wdHeaderFooterPrimary).Range
myRange.Collapse wdCollapseEnd
myRange.InsertParagraphAfter
myRange.Collapse wdCollapseEnd
myRange.Text = "Page: "
myRange.Collapse wdCollapseEnd
.Fields.Add Range:=myRange, Type:=wdFieldPage, PreserveFormatting:=True
myRange.Fields.Update
Set myRange = .Sections(1).Headers(wdHeaderFooterPrimary).Range
myRange.Collapse wdCollapseEnd
myRange.Text = " of "
myRange.Collapse wdCollapseEnd
.Fields.Add Range:=myRange, Type:=wdFieldNumPages, PreserveFormatting:=True
myRange.Collapse wdCollapseEnd
myRange.ParagraphFormat.Alignment = wdAlignParagraphRight
myRange.Fields.Update
End With
I've tried to place the Text and Field Codes from the above code into the cell of an existing table(Row 1, Column 2) within the header section of the word doc using variations of the code below.
Dim MyRange As Range
With ActiveDocument
Set MyRange = ActiveDocument.Sections(1). _
Headers(wdHeaderFooterPrimary). _
Range.Tables(1).Cell(1, 2).Range
MyRange.Collapse wdCollapseStart
MyRange.Fields.Add Range:=MyRange, _
Type:=wdFieldEmpty, _
Text:="STYLEREF Title", _
PreserveFormatting:=True
MyRange.InsertParagraphAfter
Set MyRange = ActiveDocument.Sections(1). _
Headers(wdHeaderFooterPrimary). _
Range.Tables(1).Cell(1, 2).Range
MyRange.Collapse wdCollapseEnd
MyRange.Text = "Name: "
MyRange.Collapse wdCollapseEnd
MyRange.Fields.Add Range:=MyRange, _
Type:=wdFieldEmpty, _
Text:="Name_1", _
PreserveFormatting:=True
Set MyRange = ActiveDocument.Sections(1). _
Headers(wdHeaderFooterPrimary). _
Range.Tables(1).Cell(1, 2).Range
MyRange.Collapse wdCollapseEnd
MyRange.Text = "Date: "
MyRange.Collapse wdCollapseEnd
MyRange.Fields.Add Range:=MyRange, _
Type:=wdFieldDate, _
PreserveFormatting:=True
Set MyRange = ActiveDocument.Sections(1). _
Headers(wdHeaderFooterPrimary). _
Range.Tables(1).Cell(1, 2).Range
MyRange.Collapse wdCollapseEnd
MyRange.Text = "Page: "
MyRange.Collapse wdCollapseEnd
MyRange.Fields.Add Range:=MyRange, _
Type:=wdFieldPage, _
PreserveFormatting:=True
MyRange.InsertParagraphAfter
Set MyRange = ActiveDocument.Sections(1). _
Headers(wdHeaderFooterPrimary). _
Range.Tables(1).Cell(1, 2).Range
MyRange.Collapse wdCollapseEnd
MyRange.Text = "Num Page: "
MyRange.Collapse wdCollapseEnd
MyRange.Fields.Add Range:=MyRange, _
Type:=wdFieldNumPages, _
PreserveFormatting:=True
MyRange.InsertParagraphAfter
The error "This is not a Valid Action for End of Row" appears. It seems to be tied to the "wdCollapseEnd" command and I am unable to retain the desired appearance of the text and field properties. I've been tackling this in little bites, but I would like to have the code overwrite the existing values of the cell (Row 1,Column 2) of the table within the header of my document. Any help would be greatly appreciated.
Related
I am trying to find all of the cells with a certain text of "0.118" in column 2 of my table and do a list of commands for that row
I am also trying to take the value from column 5 of that selected text found in that row and subtract the value I put in the input box for that row.
The problem I am having is that it only changes one of my found "0.118" and not all of them in each row.
And I can't figure out how to search for the column(5) of that selected row.
Any help would be greatly appreciated.
Thank you.
Sub ConvertTo_3MM()
Dim oTable As Table
Dim stT As Long, enT As Long
Dim stS As Long, enS As Long
With Selection.Find
.Forward = True
.MatchPhrase = True
.Execute FindText:="0.118"
End With
For Each oTable In ActiveDocument.Tables
Do While Selection.Find.Execute = True
stT = oTable.Range.Start
enT = oTable.Range.End
stS = Selection.Range.Start
enS = Selection.Range.End
If stS < stT Or enS > enT Then Exit Do
Selection.Collapse wdCollapseStart
If ActiveDocument.Tables.Count >= 1 Then
With ActiveDocument.Tables(1).Cell(nRow, 2).Range
.Text = "3 MM" & vbCrLf & "-" & vbCrLf & "6 MM"
End With
End If
Selection.MoveRight Unit:=wdCell
If ActiveDocument.Tables.Count >= 1 Then
With ActiveDocument.Tables(1).Cell(nRow, 3).Range
.InsertAfter Text:=vbCrLf & "-" & vbCrLf & "SHANK"
End With
End If
Selection.MoveRight Unit:=wdCell
Selection.MoveRight Unit:=wdCell
response = InputBox("Cut Length For 3 MM")
If ActiveDocument.Tables.Count >= 1 Then
With ActiveDocument.Tables(1).Cell(nRow, 5).Range
.Text = response & vbCrLf & "-" & vbCrLf & (column(5).value - response)
End With
End If
Selection.Find.Execute Replace:=wdReplaceAll
Loop
Selection.Collapse wdCollapseEnd
Next
Application.ScreenUpdating = True
End Sub
I would be very surprised if the code in your question actually does anything as it doesn't even compile.
Your code is rather a confused mess so I'm not entirely certain that I have correctly understood what you are attempting to do, but try this:
Sub ConvertTo_3MM()
Application.ScreenUpdating = False
Dim oTable As Table
Dim response As String
For Each oTable In ActiveDocument.Tables
With oTable.Range
With .Find
.Forward = True
.MatchPhrase = True
.Text = "0.118"
.Wrap = wdFindStop
.Execute
End With
Do While .Find.Found = True
.Text = "3 MM" & vbCr & "-" & vbCr & "6 MM"
With .Rows(1)
.Cells(3).Range.InsertAfter Text:=vbCr & "-" & vbCr & "SHANK"
response = Val(InputBox("Cut Length For 3 MM"))
With .Cells(5).Range
.Text = response & vbCr & "-" & vbCr & (Val(.Text) - response)
End With
End With
.Collapse wdCollapseEnd
.Find.Execute
Loop
End With
Next
Application.ScreenUpdating = True
End Sub
Thi may not be a solution, but I do see some problems:
You do:
For Each oTable In ActiveDocument.Tables
Then you do inside that loop:
Do While Selection.Find.Execute = True
but this Find will not be limited to the table of the For Each loop.
Though harmless, inside this Do While loop you do:
If ActiveDocument.Tables.Count >= 1 Then
but of course this is true because the For Each already determined there is at least 1 table.
I suggest you lookup the documentation of Find, rethink the logic and then run it step by step in the debugger to see what the code is doing.
Try this code:
Sub ConvertTo_3MM()
Dim oTable As Table, rng As Range
Dim nRow As Long, response As String
For Each oTable In ActiveDocument.Tables
With oTable
Set rng = .Range
Do
If rng.Find.Execute("0.118") Then
If rng.Information(wdEndOfRangeColumnNumber) = 2 Then
nRow = rng.Information(wdEndOfRangeRowNumber)
.Cell(nRow, 2).Range.Text = "3 MM" & vbCrLf & "-" & vbCrLf & "6 MM"
.Cell(nRow, 3).Range.InsertAfter Text:=vbCrLf & "-" & vbCrLf & "SHANK"
response = Val(InputBox("Cut Length For 3 MM"))
.Cell(nRow, 5).Range.Text = response & _
vbCrLf & "-" & vbCrLf & (Val(.Cell(nRow, 5).Range.Text) - response)
End If
Else
Exit Do
End If
rng.Collapse wdCollapseEnd
Loop
End With
Next
Application.ScreenUpdating = True
End Sub
Before
After
I'm building my footers via code. I'm having an issue properly formatting the page counts in my Word footer when adding the fields via VBA. When the code runs the formatting always ends up as XXof XX (1of 20) instead of XX of XX (1 of 20). I have tried the following but the numbers always show the page number without a space before the word "of".
With rng
.Text = "NUMPAGES "
Set oFooterRng1 = rng.Words(1)
.Fields.Add Range:=oFooterRng1, Type:=wdFieldEmpty, Text:="NUMPAGES \* Arabic ", PreserveFormatting:=True
End With
rng.Collapse wdCollapseStart
rng.Text = " of "
rng.Collapse wdCollapseStart
With rng
.Text = "PAGE "
Set oFooterRng1 = rng.Words(1)
.Fields.Add Range:=oFooterRng1, Type:=wdFieldEmpty, Text:="PAGE \* Arabic ", PreserveFormatting:=True
End With
or this
With rng
.Text = "PAGE of NUMPAGES "
Set oFooterRng1 = rng.Words(1)
Set oFooterRng2 = rng.Words(3)
.Fields.Add Range:=oFooterRng1, Type:=wdFieldEmpty, Text:="PAGE \* Arabic ", PreserveFormatting:=True
.Fields.Add Range:=oFooterRng2, Type:=wdFieldEmpty, Text:="NUMPAGES \* Arabic ", PreserveFormatting:=True
End With
Try something based on:
Sub Demo()
Application.ScreenUpdating = False
With ActiveDocument.Sections(1).Footers(wdHeaderFooterPrimary).Range
.InsertAfter Text:="Page "
.Fields.Add Range:=.Characters.Last, Type:=wdFieldEmpty, Text:="PAGE", PreserveFormatting:=False
.InsertAfter Text:=" of "
.Fields.Add Range:=.Characters.Last, Type:=wdFieldEmpty, Text:="NUMPAGES", PreserveFormatting:=False
End With
Application.ScreenUpdating = True
End Sub
And, to do it in reverse as you're trying to achieve:
Sub Demo()
Application.ScreenUpdating = False
With ActiveDocument.Sections(1).Footers(wdHeaderFooterPrimary).Range
.Fields.Add Range:=.Characters.Last, Type:=wdFieldEmpty, Text:="NUMPAGES", PreserveFormatting:=False
.Collapse wdCollapseStart
.Text = " of "
.Collapse wdCollapseStart
.Fields.Add Range:=.Duplicate, Type:=wdFieldEmpty, Text:="PAGE", PreserveFormatting:=False
.Collapse wdCollapseStart
.Text = "Page "
End With
Application.ScreenUpdating = True
End Sub
I using a VBA code to batch find and replace highlighted text. The macro finds and replaces the words in the document. It works well with a few number of highlighted text on a small document (1-2 pages). However, when I use this macro on a large documents which has over a 100 pages, Microsoft word crashed and becomes unresponsive so I have to forced to quit.
The code is to help make it easy to redact information. I am replacing the highlight text which occur also in tables with XXXXX and highlighted black.
Does anyone have any tips to make the code more efficient?
Here is the code
Sub FindandReplaceHighlight()
Dim strFindColor As String
Dim strReplaceColor As String
Dim strText As String
Dim objDoc As Document
Dim objRange As Range
Application.ScreenUpdating = False
Set objDoc = ActiveDocument
strFindColor = InputBox("Specify a color (enter the value):", "Specify Highlight Color")
strReplaceColor = InputBox("Specify a new color (enter the value):", "New Highlight Color")
strText = InputBox("Specify a new text (enter the value):", "New Text")
With Selection
.HomeKey Unit:=wdStory
With Selection.Find
.Highlight = True
Do While .Execute
If Selection.Range.HighlightColorIndex = strFindColor Then
Set objRange = Selection.Range
objRange.HighlightColorIndex = strReplaceColor
objRange.Text = strText
objRange.Font.ColorIndex = wdBlack
Selection.Collapse wdCollapseEnd
End If
Loop
End With
End With
Application.ScreenUpdating = True
End Sub
Try:
Sub FindandReplaceHighlight()
Application.ScreenUpdating = False
Dim ClrFnd As Long, ClrRep As Long, strTxt As String
Const StrColors As String = vbCr & _
" 1 Black" & vbCr & _
" 2 Blue" & vbCr & _
" 3 Turquoise" & vbCr & _
" 4 Bright Green" & vbCr & _
" 5 Pink" & vbCr & _
" 6 Red" & vbCr & _
" 7 Yellow" & vbCr & _
" 8 White" & vbCr & _
" 9 Dark Blue" & vbCr & _
"10 Teal" & vbCr & _
"11 Green" & vbCr & _
"12 Violet" & vbCr & _
"13 Dark Red" & vbCr & _
"14 Dark Yellow" & vbCr & _
"15 Gray 50" & vbCr & _
"16 Gray 25%"
ClrFnd = InputBox("Specify the old color (enter the value):" & StrColors, "Specify Highlight Color")
ClrRep = InputBox("Specify the new color (enter the value):" & StrColors, "New Highlight Color")
strTxt = InputBox("Specify the new text (enter the value):", "New Text")
With ActiveDocument
With .Range
With .Find
.ClearFormatting
.Replacement.ClearFormatting
.Highlight = True
.Forward = True
.Wrap = wdFindStop
End With
Do While .Find.Execute
If .HighlightColorIndex = ClrFnd Then
.HighlightColorIndex = ClrRep
.Text = strTxt
.Font.ColorIndex = wdBlack
.Collapse wdCollapseEnd
End If
Loop
End With
End With
Application.ScreenUpdating = True
End Sub
I wanted a custom footer in all my documents with a hyperlinked text to a bookmark in same document. i.e. 'Top Of Document' kind of link in all the footers. I had to collect information for all over the places to achieve this much. and wanted to share here so others do not have to fight for this thing all at once.
So far from all the question & suggestions from stackoverflow and other sites, I have achieved this much-
Created a macro to create a bookmark automatically, of a selected text in document.
Bookmark will be re-created (delete and create) if its already present
Macro will add a new footer with page number and a text with delimiter (i.e. / Hit Overview).
Now I want to create this text in footer a HyperLink to the bookmark. code is simple. but i guess i am doing something wrong, tried by creating a HyperLink object. but not working. please suggest something.
Here is the macro function-
Sub InsertFootnote()
Const wdAlignPageNumberCenter = 1
Dim varNumberPages As Variant
varNumberPages = ActiveDocument.Content.Information(wdActiveEndAdjustedPageNumber)
' Delete bookmark if any with this name
If ActiveDocument.Bookmarks.Exists("HitOverviewMac") = True Then
ActiveDocument.Bookmarks("HitOverviewMac").Delete
End If
' Create a Bookmark to the selected text
With ActiveDocument.Bookmarks
.Add Range:=Selection.Range, Name:="HitOverviewMac"
.DefaultSorting = wdSortByName
.ShowHidden = False
End With
Dim mHlink As Hyperlink
Dim i As Long
For i = 1 To ActiveDocument.Sections.Count
With ActiveDocument.Sections(i)
' Remove footer
'.Footers(wdHeaderFooterPrimary).Range.Text = ""
'.Footers(wdHeaderFooterPrimary).PageNumbers.Add (wdAlignPageNumberCenter)
'.Footers(wdHeaderFooterPrimary).Range.InsertBefore "Hit Overview / Page "
.Footers(wdHeaderFooterPrimary).Range.Select
With Selection
If ActiveDocument.Bookmarks.Exists("HitOverviewMac") = True Then
.Paragraphs(1).Alignment = wdAlignParagraphCenter
.TypeText Text:="Page "
.Fields.Add Range:=Selection.Range, Type:=wdFieldEmpty, Text:= _
"PAGE ", PreserveFormatting:=True
.TypeText Text:=" of "
.Fields.Add Range:=Selection.Range, Type:=wdFieldEmpty, Text:= _
"NUMPAGES ", PreserveFormatting:=True
.EndKey Unit:=wdLine
.TypeText Text:=" ~ "
ActiveDocument.Hyperlinks.Add Anchor:=.Range, Address:="", _
SubAddress:="HitOverview", ScreenTip:="", TextToDisplay:="Hit Overview"
Else
MsgBox "Bookmark does not exists"
End If
End With
End With
Next
End Sub
Ok, Its wasn't the problem with Macro(except below), its the problem with couple of Documents I was testing with.
few mistakes that I missed - SubAddress:="BOOKMARK_NAME" AND Anchor:=Selection.Range.
So the problem occurs if any Doc already has some text in footers. and so that now I am removing footer first.
Here is the Code for everyone's reference-
Sub InsertFootnote()
Const wdAlignPageNumberCenter = 1
Dim varNumberPages As Variant
varNumberPages = ActiveDocument.Content.Information(wdActiveEndAdjustedPageNumber)
If ActiveDocument.Bookmarks.Exists("HitOverviewMac") = True Then
ActiveDocument.Bookmarks("HitOverviewMac").Delete
End If
With ActiveDocument.Bookmarks
.Add Range:=Selection.Range, Name:="HitOverviewMac"
.DefaultSorting = wdSortByName
.ShowHidden = False
End With
Dim mHlink As Hyperlink
Dim i As Long
For i = 1 To ActiveDocument.Sections.Count
With ActiveDocument.Sections(i)
.Footers(wdHeaderFooterPrimary).Range.Text = ""
.Footers(wdHeaderFooterPrimary).PageNumbers.Add (wdAlignPageNumberCenter)
.Footers(wdHeaderFooterPrimary).Range.Select
With Selection
If ActiveDocument.Bookmarks.Exists("HitOverviewMac") = True Then
.Paragraphs.Alignment = wdAlignParagraphCenter
.TypeText Text:="Page "
.Fields.Add Range:=Selection.Range, Type:=wdFieldEmpty, Text:= _
"PAGE ", PreserveFormatting:=True
.TypeText Text:=" of "
.Fields.Add Range:=Selection.Range, Type:=wdFieldEmpty, Text:= _
"NUMPAGES ", PreserveFormatting:=True
.EndKey Unit:=wdLine
.TypeText Text:=" / "
ActiveDocument.Hyperlinks.Add Anchor:=Selection.Range, Address:="", _
SubAddress:="HitOverviewMac", ScreenTip:="", TextToDisplay:="Hit Overview"
Else
MsgBox "Bookmark does not exists"
End If
End With
End With
Next
End Sub
I need to make a difficult makro.
When the makro has been activated (will happen via a button), it has to add a header and a footer to the document.
Also page1/frontpage needs a different header and footer than all the other potential pages.
So far, I have accomplished making page1/frontpage to work - somewhat.
I did this by recording a makro, where I'd enable headers and footers, write the needed data and then stop recording. Afterwards I edited the coding so it would fit a little better. Mostly it was junk-code cleanup.
It doesn't work though, if I use several pages.
How can I accomplish this setup?
I can provide you my current code, if anyone is interested:
Sub PDFtest2()
'
' PDFtest2 Macro
'
'
Dim FileName As String
Dim minPDFSti As String
Dim aryFolders
Dim i As Long
Dim version As String
Dim sFolder As String
'Skaf dokument titel
FileName = ActiveDocument.Name 'e.g document1.doc
aryFolders = Split(FileName, ".") 'split ved .doc da vi skal bruge pdf extension
FileName = aryFolders(LBound(aryFolders)) 'document1
'Lav en document-1 hvis document allerede eksistere. Putter også .pdf på som extension
If Dir(minPDFSti + FileName + ".pdf") <> "" Then
aryFolders = Split(FileName, "-")
version = aryFolders(UBound(aryFolders))
If version <> "" Then
FileName = FileName + "-" + version + "-1.pdf"
Else
FileName = FileName + "-1.pdf"
End If
Else
FileName = FileName + ".pdf"
End If
'Vores PDF sti
minPDFSti = "c:\PDF\"
If Dir(minPDFSti, vbDirectory) = "" Then
'If MsgBox("PDF Mappen eksistere ikke, lav en?", _
'vbYesNo, "PDF Mappe") = vbYes Then
aryFolders = Split(minPDFSti, "\")
sFolder = aryFolders(LBound(aryFolders))
For i = LBound(aryFolders) + 1 To UBound(aryFolders)
sFolder = sFolder & "\" & aryFolders(i)
If Dir(sFolder, vbDirectory) = "" Then MkDir sFolder
Next i
'End If
End If
If ActiveWindow.View.SplitSpecial <> wdPaneNone Then
ActiveWindow.Panes(2).Close
End If
If ActiveWindow.ActivePane.View.Type = wdNormalView Or ActiveWindow. _
ActivePane.View.Type = wdOutlineView Then
ActiveWindow.ActivePane.View.Type = wdPrintView
End If
ActiveWindow.ActivePane.View.SeekView = wdSeekCurrentPageHeader
Selection.ParagraphFormat.Alignment = wdAlignParagraphCenter
Selection.TypeText Text:="Advokatfirmaet"
Selection.TypeParagraph
Selection.TypeText Text:="Beck & Partnere"
Selection.MoveLeft Unit:=wdCharacter, Count:=15, Extend:=wdExtend
Selection.Font.Size = 12
Selection.Font.Size = 13
Selection.MoveRight Unit:=wdCharacter, Count:=1
Selection.MoveLeft Unit:=wdCharacter, Count:=16, Extend:=wdExtend
Selection.MoveRight Unit:=wdCharacter, Count:=1, Extend:=wdExtend
Selection.Font.Bold = wdToggle
Selection.MoveRight Unit:=wdCharacter, Count:=1
Selection.MoveLeft Unit:=wdCharacter, Count:=15, Extend:=wdExtend
Selection.Font.Bold = wdToggle
Selection.MoveRight Unit:=wdCharacter, Count:=1
Selection.MoveDown Unit:=wdLine, Count:=1
Selection.TypeText Text:="Advokataktieselskab"
Selection.ParagraphFormat.TabStops.Add Position:=CentimetersToPoints(4.5), _
Alignment:=wdAlignTabLeft, Leader:=wdTabLeaderSpaces
Selection.TypeText Text:=vbTab & "Damhaven 5"
Selection.ParagraphFormat.TabStops(CentimetersToPoints(7.96)).Position = _
CentimetersToPoints(7.96)
Selection.ParagraphFormat.TabStops.Add Position:=CentimetersToPoints(8.25) _
, Alignment:=wdAlignTabLeft, Leader:=wdTabLeaderSpaces
Selection.ParagraphFormat.TabStops(CentimetersToPoints(7.96)).Position = _
CentimetersToPoints(8.25)
Selection.TypeText Text:=vbTab & "Giro 193 5100"
Selection.ParagraphFormat.TabStops.Add Position:=CentimetersToPoints(12.25 _
), Alignment:=wdAlignTabLeft, Leader:=wdTabLeaderSpaces
Selection.TypeText Text:=vbTab & "Tel." & vbTab & "+45 75 72 41 00"
Selection.TypeParagraph
Selection.TypeText Text:="CVR 25 79 71 24" & vbTab & "DK-7100 Vejle" & _
vbTab
Selection.ParagraphFormat.TabStops(CentimetersToPoints(8.25)).Position = _
CentimetersToPoints(9)
Selection.ParagraphFormat.TabStops.Add Position:=CentimetersToPoints(8.25) _
, Alignment:=wdAlignTabLeft, Leader:=wdTabLeaderSpaces
Selection.TypeText Text:="www.becklaw.dk" & vbTab & "Fax" & vbTab & _
"+45 75 72 41 00"
Selection.MoveUp Unit:=wdLine, Count:=1
Selection.MoveLeft Unit:=wdCharacter, Count:=26
Selection.ParagraphFormat.TabStops.Add Position:=CentimetersToPoints(8.25) _
, Alignment:=wdAlignTabLeft, Leader:=wdTabLeaderSpaces
Selection.ParagraphFormat.TabStops(CentimetersToPoints(8.25)).Position = _
CentimetersToPoints(9)
Selection.ParagraphFormat.TabStops(CentimetersToPoints(9)).Position = _
CentimetersToPoints(8.25)
ChangeFileOpenDirectory minPDFSti 'Sikre dig at stien eksistere
ActiveDocument.ExportAsFixedFormat OutputFileName:= _
minPDFSti + FileName, ExportFormat:= _
wdExportFormatPDF, OpenAfterExport:=True, OptimizeFor:= _
wdExportOptimizeForPrint, Range:=wdExportAllDocument, From:=1, To:=1, _
Item:=wdExportDocumentContent, IncludeDocProps:=True, KeepIRM:=True, _
CreateBookmarks:=wdExportCreateNoBookmarks, DocStructureTags:=True, _
BitmapMissingFonts:=True, UseISO19005_1:=False
Selection.WholeStory
Selection.TypeBackspace
Selection.MoveUp Unit:=wdLine, Count:=1
Selection.WholeStory
Selection.TypeBackspace
ActiveWindow.ActivePane.View.SeekView = wdSeekMainDocument
End Sub
The code also saves the dokument as a PDF. But that doesn't matter.
EDIT: Actually this accomplishes an odd result!
Let us say that I have a page1, 2 & 3 filled with text.
I press the button that activates the macro.
Page 1 recieves no header nor footer, but page 2 & 3 recieves the header and footer coded above.
Try this:
Sub HeaderFooterObject()
Dim MyText As String
MyHeaderText = "Header text"
MyFooterText = "Footer text"
MyHeaderTextFirstPage = "First Page"
MyFooterTextFirstPage = "Footer text First Page"
With ActiveDocument.Sections(1)
.PageSetup.DifferentFirstPageHeaderFooter = True
.Headers(wdHeaderFooterPrimary).Range.Text = MyHeaderText
.Footers(wdHeaderFooterPrimary).Range.Text = MyFooterText
.Headers(wdHeaderFooterFirstPage).Range.Text = MyHeaderTextFirstPage
.Footers(wdHeaderFooterFirstPage).Range.Text = MyFooterTextFirstPage
End With
End Sub
This came from here and here.