In my docs I use either Arial or Courier New (for code) and sometimes both in the same paragraph. As I share my docs with other people, they tend to use other fonts as well but it is important to keep it aligned, that;s why I am trying to create a macro that will turn all non-Courier New text into Arial and into the correct font size (11).
I face 2 problems with what I have achieved so far:
In paragraphs with mixed fonts it tends to change the whole paragraph (including the code) to Arial, while i need it to change only the non-code text
It changes the font size not only in the body text but in the headings as well.
I think I'm using incorrectly the objects of Word (I'm used in working in Excel) but I can't find anywhere online any clues. Can anyone help me please?
Sub CorrectFont()
Dim p As paragraph
Set p = ActiveDocument.Paragraphs(1)
Application.Visible = False
Application.ScreenUpdating = False
Do
If p.Range.Font.Name <> "Courier New" Then
p.Range.Font.Name = "Arial"
p.Range.Font.Size = 11
End If
Set p = p.Next
Loop Until p Is Nothing
Application.ScreenUpdating = True
Application.Visible = True
End Sub
You can check each individual word, like so:
' Replaces non-Arial fonts with Arial.
' Exception: Courier New is not replaced.
Sub AlignFont()
Dim wd As Range
' Check each word, one at a time.
For Each wd In ActiveDocument.Words
If Not (wd.Font.Name = "Arial" Or wd.Font.Name = "Courier New") Then
wd.Font.Name = "Arial"
End If
Next
End Sub
Thanks to #destination-data 's inputs I reached a final form of the code. I present it here for anyone that might be interested.
Thank you again!
Sub AlignFont()
Dim wd As Range
Application.Visible = False
Application.ScreenUpdating = False
' Check each word, one at a time.
For Each wd In ActiveDocument.Words
'On objects like Contents it may create an error and crash
On Error Resume Next
If wd.Font.Name <> "Courier New" And wd.Style = "Normal" Then
wd.Font.Name = "Arial"
End If
'To avoid any header that may have a "Normal" style
If wd.Font.Bold = False Then
wd.Font.Size = 11
End If
Next
Application.ScreenUpdating = True
Application.Visible = True
End Sub
Related
I would like to find/replace all inserted check box symbols with checkbox content controls. The symbol's font is Wingdings (either 111 or 168). Below is the code I started with, but I hit a wall when I realized that Word find doesn't recognize the symbol. I appreciate any help or guidance. Thank you.
Sub ReplaceUnicode168()
Dim objContentControl As ContentControl
With ActiveDocument
Set objContentControl = ActiveDocument.ContentControls.Add(wdContentControlCheckBox)
objContentControl.Cut
With Selection.Find
.ClearFormatting
.Replacement.ClearFormatting
.Forward = True
.Wrap = wdFindContinue
.MatchCase = False
.MatchWholeWord = True
.MatchWildcards = False
.Text = Chr(168)
.Replacement.Text = "^c"
.Execute Replace:=wdReplaceAll
End With
End With
End Sub
I suggest that you try to find/replace these two particular characters using
.Text = ChrW(61551)
for the "111" WingDings Character and
.Text = ChrW(61608)
for the "168" WingDings character.
Be aware that the way Word encodes these characters is not very helpful. As far as Find/Replace is concerned, you have to use these Unicode Private Use Area encodings.
If you actually select the character and use VBA to discover its code using e.g.
Debug.Print AscW(Selection)
the answer is always 40 (and the Font of the character will probably be the same as the Surrounding font) Pretty useless. In older versions of Word you used to be able to look for the 40 character and find these characters, but I don't think that's possible now. But if you select the character and use
Sub SymInfo()
With Dialogs(wdDialogInsertSymbol)
' You won't see .Font and .CharNum listed under the
' properties of a Word.Dialog - some older Dialogs add
' per-Dialog properties at runtime.
Debug.Print .Font
Debug.Print .CharNum
End With
End Sub
Then you get the font name (Wingdings in this case) and the private use area character number, except it's expressed as a negative number (-3928 for Wingdings 168). The character to use in the Find/Replace is 65536-3928 = 61608.
Alternatively, you can find the private use area code by selecting the character, getting its WordOpenXML code, then finding the XML element that gives the code (and the font). Ideally use MSXML to look for the element but the following gives the general idea.
Sub getSymElement
Dim finish As Long
Dim start As Long
Dim x As String
x = Selection.WordOpenXML
start = Instr(1,x,"<w:sym")
' Should check for start = 0 (not found) here.
finish = Instr(start,x,">")
Debug.Print Mid(x,start, finish + 1 - start)
and for the 168 character you should see something like
<w:sym w:font="Wingdings" w:char="F0A8"/>
(Hex F0A8 is 61608)
There may be a problem where Word could potentially map more than one font/code to the same unicode private use area codepoint. There is some further code by Dave Rado here but I do not think you will need it for this particular problem.
After some follow-up, the following seems to work reasonably well here:
Sub replaceWingdingsWithCCs()
Dim cc As Word.ContentControl
Dim charcode As Variant
Dim ccchecked As Variant
Dim i As Integer
Dim r As Word.Range
' Make sure the selection point is not in the way
' (If the selection contains one of the characters you are trying to
' replace, Word will raise an error about the selection being in a
' plain text content control.
' If the first item in the document is not a CC,
' it's enouugh to do this:
ActiveDocument.Select
Selection.Collapse WdCollapseDirection.wdCollapseStart
' Put the character codes you need to look for here. Maybe you have some checked boxes too?
charcode = Array(61551, 61608)
' FOr each code, say whether you want a checked box (True) or an unchecked one.
ccchecked = Array(False, False)
For i = LBound(charcode) To UBound(charcode)
Set r = ActiveDocument.Range
With r.Find
.ClearFormatting
With .Replacement
.ClearFormatting
.Text = ""
End With
.Forward = True
.Wrap = wdFindStop
.MatchCase = False
.MatchWholeWord = True
.MatchWildcards = False
.Text = ChrW(charcode(i))
Do While .Execute(Replace:=True)
Set cc = r.ContentControls.Add(WdContentControlType.wdContentControlCheckBox)
cc.Checked = ccchecked(i)
r.End = r.Document.Range.End
r.Start = cc.Range.End + 1
Set cc = Nothing
Loop
End With
Next
Set r = Nothing
End Sub
I am trying to make a macro for word.
I have many word docs with 2 pages or more and they have same headers, footers
I am trying to make a macro which will add an additional blank page to the doc but should not carry any header/footer and should not affect the previous pages. So a new blank page with basically nothing.
Selection.EndKey Unit:=wdStory
Selection.InsertBreak Type:=wdSectionBreakNextPage
Selection.InsertNewPage
Selection.Sections(1).Headers(wdHeaderFooterPrimary).LinkToPrevious = False
Selection.Sections(1).Headers(wdHeaderFooterPrimary).Range.Delete
Selection.Sections(1).Footers(wdHeaderFooterPrimary).LinkToPrevious = False
Selection.Sections(1).Footers(wdHeaderFooterPrimary).Range.Delete
So far this macro gives me an additional page with header/footer followed by a blank page.
Any thoughts/ideas?
The code in the question is on the right track with using the Section object, LinkToPrevious and Range.Delete. What's generating the additional page is
Selection.InsertNewPage
The line Selection.InsertBreak Type:=wdSectionBreakNextPage already creates a new page.
FWIW, the code I'd use would be the same in principle, but would work with Range instead of the Selection object. Working with a Range is generally faster and there's minimal screen flicker. It also tends to be more accurate, and it's easier to determine what the code is affecting. I'm providing it for information purposes :-)
Sub NewPageSectionNoHF()
Dim doc As Word.Document
Dim rng As Word.Range
Dim sec As Word.Section
Dim hf As Word.HeaderFooter
Set doc = ActiveDocument
Set rng = doc.content
rng.Collapse wdCollapseEnd
rng.InsertBreak Word.WdBreakType.wdSectionBreakNextPage
Set sec = rng.Sections(1)
'First page
Set hf = sec.Headers(wdHeaderFooterFirstPage)
If hf.exists Then
hf.LinkToPrevious = False
hf.Range.Delete
End If
Set hf = sec.Footers(wdHeaderFooterFirstPage)
If hf.exists Then
hf.LinkToPrevious = False
hf.Range.Delete
End If
'Other pages
Set hf = sec.Headers(wdHeaderFooterPrimary)
hf.LinkToPrevious = False
hf.Range.Delete
Set hf = sec.Footers(wdHeaderFooterPrimary)
hf.LinkToPrevious = False
hf.Range.Delete
End Sub
I have created a template (one of a series of many similar templates) that will be distributed to multiple users to be used to create transcripts (of audio and digital files). The transcript includes a number of styles that will be used exclusively to format the text.
The template includes a series of macros that temporarily changes the font colors of each of the custom styles in order to aid in a quick proofing of the format, and then another macro to change them all back to the black/auto font color.
As long as there is no direct formatting of font colors within any of the custom styles, this process works swimmingly. However, I am contemplating the possibility that some users might opt to select all the text and use the direct formatting method to restore the temp-colored fonts to black. If they do this, it renders all of the color-centric macros (change to a color, change back to black) useless.
This could be very problematic because the transcripts produced by these users will ultimately be submitted to a subcontractor, who may wish to employ the color-centric macros herself for additional proofing before submitting the final transcript to her client. But they will no longer work if the user has applied direct formatting of font colors.
I was able to remove the direct-formatting font color, both manually and via a macro, by using the "clear formatting" option, then reapplying the style. But that is not a practical solution for this conundrum because any given paragraph might contain other attributes such as bold, underlining, or italicized text, which is lost when the "clear formatting" option is applied. I contemplated applying character styles to those attributes, but there is no way I can guarantee that a user will use them, so there is still a risk of losing the attributes when trying to deal with the potential font color issue.
I have conducted exhaustive experiments in Word and searched through the help files as well as extensively on Google, and I cannot find any information that facilitates removing ONLY the direct formatting relative to font colors while leaving other direct formatting attributes intact so that I can employ the macros to change the font colors within the styles.
Am I missing the forest for the trees and going about this all wrong? Or is there one little element lacking in my macro code that would address this problem?
I have copied the two main color-centric macros below. There are actually 8 additional macros that are part of this same category, because I'm also giving the user the option to change the font color in individual styles as well as the QUESTION and ANSWER style together (while not changing any other styles). But they are just identical snippets of the code shown below, paired down to deal with individual styles.
Thanks in advance for any help!
Change all the styles to a different color:
Sub STYLES_AllColors()
With ActiveDocument.Styles("#CENTERED (DS)")
.Font.ColorIndex = wdGray50
End With
With ActiveDocument.Styles("#FLUSH LEFT (DS)")
.Font.ColorIndex = wdDarkYellow
End With
With ActiveDocument.Styles("#PARENTHETICAL")
.Font.ColorIndex = wdViolet
End With
With ActiveDocument.Styles("#QUESTION (looped)")
.Font.ColorIndex = wdRed
End With
With ActiveDocument.Styles("#ANSWER (looped)")
.Font.ColorIndex = wdBlue
End With
With ActiveDocument.Styles("#QA2 (continuing paragraph)")
.Font.ColorIndex = wdTurquoise
End With
With ActiveDocument.Styles("#QA (plain format)")
.Font.ColorIndex = wdDarkRed
End With
End Sub
Change all the styles back to black/auto:
Sub STYLES_AllBlack()
With ActiveDocument.Styles("#CENTERED (DS)")
.Font.Color = wdColorAutomatic
End With
With ActiveDocument.Styles("#FLUSH LEFT (DS)")
.Font.Color = wdColorAutomatic
End With
With ActiveDocument.Styles("#PARENTHETICAL")
.Font.Color = wdColorAutomatic
End With
With ActiveDocument.Styles("#QUESTION (looped)")
.Font.Color = wdColorAutomatic
End With
With ActiveDocument.Styles("#ANSWER (looped)")
.Font.Color = wdColorAutomatic
End With
With ActiveDocument.Styles("#QA2 (continuing paragraph)")
.Font.Color = wdColorAutomatic
End With
With ActiveDocument.Styles("#QA (plain format)")
.Font.Color = wdColorAutomatic
End With
End Sub
I may have found the answer, or at least a suitable workaround for now.
After more experimenting, it seems that even if direct formatting (of font colors) has been applied to the text, the macro-generated font changes will work if I use the find/replace method to search for the individual styles and change the font, rather than applying the font changes directly to the style (within the macro), as I was doing. That results in a lot of extra formatting styles, but I can provide the users with instructions and tools to prevent and/or eliminate that clutter on the Formatting Pane.
So unless someone comes along with a more elegant solution, that's what I'll go with for now. Here is a snippet of the code for an individual style. I will have to expand it to cover all of the styles, and create a companion macro to remove all the colors.
Selection.Find.ClearFormatting
Selection.Find.Style = ActiveDocument.Styles("#QUESTION (looped)")
Selection.Find.Replacement.ClearFormatting
Selection.Find.Replacement.Style = ActiveDocument.Styles( _
"#QUESTION (looped)")
With Selection.Find.Replacement.Font
.Color = wdColorRed
End With
With Selection.Find
.Text = ""
.Replacement.Text = ""
.Forward = True
.Wrap = wdFindContinue
End With
Selection.Find.Execute Replace:=wdReplaceAll
I have a similar problem when I use EndNote to manage a bibliography. It remakes the style every update. I run a macro that calls several others to put in links and optional spaces. I think that the subroutine I run to cleanup the EndNote Bibliography paragraph style and paragraph instances may provide a view to the scheme that I use.
I have included that code below, it also will cut down on the explosion of Direct Styles.
I first make sure that the style itself is what I want. Then I go to each instance and set it to the same. Now, these are paragraphs, the character style is similar. If you are still watching this question, let me know, and I will write up the character style code. It can use a subroutine that just runs through an array of styles and colors.
Private Sub EndNoteStyleFixup(d As Document, r As Range)
'
' EndNoteBibliographyStyleFix Macro
'
'
Dim ENStyle As Style
Dim p As Paragraph
Dim pCnt As Long
Set ENStyle = Nothing
On Error Resume Next
Set ENStyle = d.Styles("EndNote Bibliography")
On Error GoTo 0
If ENStyle Is Nothing Then
'done
Else
pCnt = 0
With ENStyle
.Font.name = "Times New Roman"
.Font.Size = 10.5
With .ParagraphFormat
.LeftIndent = InchesToPoints(0.25)
.RightIndent = InchesToPoints(0)
.SpaceBefore = 0
.SpaceBeforeAuto = False
.SpaceAfter = 2
.SpaceAfterAuto = False
.LineSpacingRule = wdLineSpaceSingle
.Alignment = wdAlignParagraphLeft
.WidowControl = True
.KeepWithNext = False
.KeepTogether = False
.PageBreakBefore = False
.Hyphenation = True
.FirstLineIndent = InchesToPoints(-0.25)
.OutlineLevel = wdOutlineLevelBodyText
.CharacterUnitLeftIndent = 0
.CharacterUnitRightIndent = 0
.CharacterUnitFirstLineIndent = 0
.LineUnitBefore = 0
.LineUnitAfter = 0
.MirrorIndents = False
.TextboxTightWrap = wdTightNone
doEndNoteTabs .TabStops
End With
.NoSpaceBetweenParagraphsOfSameStyle = False
.AutomaticallyUpdate = False
.BaseStyle = "Normal"
.NextParagraphStyle = "EndNote Bibliography"
End With
For Each p In r.Paragraphs
If ENStyle = p.Style Then
p.Range.Select
With p.Range
.Font.name = "Times New Roman"
.Font.Size = 10.5
With .ParagraphFormat
.LeftIndent = InchesToPoints(0.25)
.RightIndent = InchesToPoints(0)
.SpaceBefore = 0
.SpaceBeforeAuto = False
.SpaceAfter = 2
.SpaceAfterAuto = False
.LineSpacingRule = wdLineSpaceSingle
.Alignment = wdAlignParagraphLeft
.WidowControl = True
.KeepWithNext = False
.KeepTogether = False
.PageBreakBefore = False
.Hyphenation = True
.FirstLineIndent = InchesToPoints(-0.25)
.OutlineLevel = wdOutlineLevelBodyText
.CharacterUnitLeftIndent = 0
.CharacterUnitRightIndent = 0
.CharacterUnitFirstLineIndent = 0
.LineUnitBefore = 0
.LineUnitAfter = 0
.MirrorIndents = False
.TextboxTightWrap = wdTightNone
doEndNoteTabs .TabStops
End With
End With
p.Style = ENStyle
End If
Next p
End If
End Sub
I am executing a style search in Microsoft Word using a VBA Macro.
My goal is to perform certain actions once for every style found in the document.
The macro works correctly on documents that have at least two paragraphs, but the macro does not alert the style correctly in a document that has exactly one paragraph in it. It seems strange that when I enter a new paragraph mark, the styles are found, even though I did not add any new text or styles to the document, just an extra blank paragraph mark. Does anyone know what is wrong with my macro and how I can fix this? Thanks for taking a look.
Sub AlertAllStylesInDoc()
Dim Ind As Integer
Dim numberOfDocumentStyles As Integer
Dim styl As String
Dim StyleFound As Boolean
numberOfDocumentStyles = ActiveDocument.styles.count
For Ind = 1 To numberOfDocumentStyles
styl = ActiveDocument.styles(Ind).NameLocal
With ActiveDocument.Content.Find
.ClearFormatting
.text = ""
.Forward = True
.Format = True
.Style = styl
Do
StyleFound = .Execute
If StyleFound = True Then
' actual code does more than alert, but keeping it simple here'
MsgBox styl
GoTo NextStyle
Else
Exit Do
End If
Loop
End With
NextStyle:
Next
End Sub
I don't understand why ActiveDocument.Content is not working, but replacing it with ActiveDocument.Range(0,0) appears to resolve the issue (tested in Word 2016).
With ActiveDocument.Range(0, 0).Find
I am looking for a macro for word documents that will find every style in a document, and change it from whatever it is (centered, justified, right-align) to left-align.
I don't want to change the text (except as a by-product), but the style itself so everything updates.
Thanks Remou, I tried working with it, and this seems to work:
Sub ChangeStyles()
Dim oSource As Document
Set oSource = ActiveDocument
For i = 1 To oSource.Styles.Count
' must check the style type as character style gives an error
If oSource.Styles(i).Type = wdStyleTypeParagraph Then
With ActiveDocument.Styles(i).ParagraphFormat
.Alignment = wdAlignParagraphLeft
End With
Else
End If
Next i
End Sub