For most of the documents I work with, I need to highlight instances of Asian font (such as SimSun, MS Mincho).
I put together the the code below - it works well but it doesn't highlight Asian font characters within non-Asian words (such as the apostrophe in "it's").
Sub HighlightAsian2019()
Dim aWord
For Each aWord In ActiveDocument.Words
If aWord.Font.Name = "SimSun" Then
aWord.FormattedText.HighlightColorIndex = wdTurquoise
End If
Next aWord
For Each aWord In ActiveDocument.Words
If aWord.Font.Name = "MS Mincho" Then
aWord.FormattedText.HighlightColorIndex = wdTurquoise
End If
Next aWord
End Sub
Can anyone help me improve the code so that ALL instances of SimSun and MS Mincho in the text are highlighted?
Any help will be greatly appreciated!
Use this Loop:
Sub HighlightAsian2019()
With ActiveDocument.Range
For i = 1 To .Characters.Count
If .Characters(i).Font.Name = "SimSun" Then
.Characters(i).FormattedText.HighlightColorIndex = wdTurquoise
End If
Next
End With
End Sub
You can use the .Characters property of Range to access the alphabets. Add another If condition for other fonts to check
Since I don't have that particular font, I tested with other fonts, may try with modifying the font names.
Sub test()
Dim Rng As Range
Set Rng = ThisDocument.Content
With Rng.Find
.ClearFormatting
.Text = ""
.Font.Name = "Kruti Dev 040 Wide"
Do While .Execute
Rng.FormattedText.HighlightColorIndex = wdTurquoise
Loop
End With
End Sub
Related
I have several Word-Files containing old-style non-clickable UTF8-character checkboxes () and I want to replace them with real, clickable Checkboxes. They should be unchecked for and checked for another specified UTF8-character (which I do not know the number of right now).
I tried search and replace and copying from macros I've found online. I'm not a word user and this is a one-time-task, so I sadly do not have the time to learn VBA well enough to write such a thing as a macro.
I've found this online, but in the Macros-Window, I cannot even copy to "string to be searched".
For Each myStoryRange In ActiveDocument.StoryRanges
With myStoryRange.Find
.Text = "string to be searched"
.Replacement.Text = "string to be replaced"
.Wrap = wdFindContinue
.ClearFormatting
.Replacement.ClearFormatting
.Replacement.Highlight = False
.Execute Replace:=wdReplaceAll
End With
Next myStoryRange
For Searching UTF=8 Character you have to search Unicodes like
U+2610 decimal ☐ Unchecked Checkbox
U+2611 decimal ☑ Checked Checkbox
U+2612 decimal ☒ Crossed Checkbox
Other like Unicode characters may also be explored for exactly what is it in your case. I tested with U+2610 decimal ☐ Unchecked Checkbox.
For replacement with FormField type of ComboBox I successfully used the code below
Sub TestFormFieldCB()
Dim Rng As Range, cb As FormField
ActiveDocument.Content.Select
With Selection.Find
.Text = ChrW(9744)
Do While .Execute
Set Rng = Selection.Range
ht = Rng.Font.SizeBi
Rng.Delete
Set cb = Rng.FormFields.Add(Rng, wdFieldFormCheckBox)
cb.CheckBox.Size = ht
Loop
End With
'ActiveDocument.Protect wdAllowOnlyFormFields
End Sub
The disadvantage of this type ComboBox is document is to be protected for the ComboBox to be clickable.
As Second option I tried with ActiveX Type ComboBox. It is easilyclickable even in unprotected mode but difficult to align and size with the text in the line. Also Somehow i could not use the same find Loop as in the above code and had to work around with some other way.
The final tested code is
Sub testActiveXCB()
Dim Rng As Range, cb As InlineShape, Fnd As Boolean
ActiveDocument.Content.Select
With Selection.Find
.Text = ChrW(9744)
.Execute
Do While Selection.Find.Found
Set Rng = Selection.Range
ht = Rng.Font.SizeBi
Rng.Delete
Set cb = Rng.InlineShapes.AddOLEControl(ClassType:="Forms.CheckBox.1")
Debug.Print cb.OLEFormat.Object.Name & "-" & cb.Height
cb.Width = cb.Height
cb.Width = ht
cb.OLEFormat.Object.Caption = ""
cb.OLEFormat.Object.PicturePosition = 2
'Use next Line when replacing Checked Unicode Char mat be U+2611 or U+2612
'cb.OLEFormat.Object.Value = True
ActiveDocument.Content.Select
Selection.Find.Execute
Loop
End With
End Sub
(All tests are carried out in Word 2007 only)
I request more answers and eager to learn from Word VBA experts regarding
Why the ActiveX Combo Box could not be inserted with the simple Find loop used in case of FormField type Combo Box?
How to effectively align Active X Combo Box with the text Line?
I need to create a macros which removes whitespaces and indent before all paragraphs in the active MS Word document. I've tried following:
For Each p In ActiveDocument.Paragraphs
p.Range.Text = Trim(p.range.Text)
Next p
which sets macros into eternal loop. If I try to assign string literal to the paragraphs, vba always creates only 1 paragraph:
For Each p In ActiveDocument.Paragraphs
p.Range.Text = "test"
Next p
I think I have a general misconception about paragraph object. I would appreciate any enlightment on the subject.
The reason the code in the question is looping is because replacing one paragraph with the processed (trimmed) text is changing the paragraphs collection. So the code will continually process the same paragraph at some point.
This is normal behavior with objects that are getting deleted and recreated "behind the scenes". The way to work around it is to loop the collection from the end to the front:
For i = ActiveDocument.Paragraphs.Count To 1 Step -1
Set p = ActiveDocument.Paragraphs(i)
p.Range.Text = Trim(p.Range.Text)
Next
That said, if the paragraphs in the document contain any formatting this will be lost. String processing does not retain formatting.
An alternative would be to check the first character of each paragraph for the kinds of characters you consider to be "white space". If present, extend the range until no more of these characters are detected, and delete. That will leave the formatting intact. (Since this does not change the entire paragraph a "normal" loop works.)
Sub TestTrimParas()
Dim p As Word.Paragraph
Dim i As Long
Dim rng As Word.Range
For Each p In ActiveDocument.Paragraphs
Set rng = p.Range.Characters.First
'Test for a space or TAB character
If rng.Text = " " Or rng.Text = Chr(9) Then
i = rng.MoveEndWhile(" " + Chr(9))
Debug.Print i
rng.Delete
End If
Next p
End Sub
You could, of course, do this in a fraction of the time without a loop, using nothing fancier than Find/Replace. For example:
Find = ^p^w
Replace = ^p
and
Find = ^w^p
Replace = ^p
As a macro this becomes:
Sub Demo()
Application.ScreenUpdating = False
With ActiveDocument.Range
.InsertBefore vbCr
With .Find
.ClearFormatting
.Replacement.ClearFormatting
.Forward = True
.Wrap = wdFindContinue
.Format = False
.MatchWildcards = False
.Text = "^p^w"
.Replacement.Text = "^p"
.Execute Replace:=wdReplaceAll
.Text = "^w^p"
.Execute Replace:=wdReplaceAll
End With
.Characters.First.Text = vbNullString
End With
Application.ScreenUpdating = True
End Sub
Note also that trimming text the way you're doing is liable to destroy all intra-paragraph formatting, cross-reference fields, and the like; it also won't change indents. Indents can be removed by selecting the entire document and changing the paragraph format; better still, modify the underlying Styles (assuming they've been used correctly).
Entering "eternal" loop is a bit unpleasant. Only Chuck Norris can exit one. Anyway, try to make a check before trimming and it will not enter:
Sub TestMe()
Dim p As Paragraph
For Each p In ThisDocument.Paragraphs
If p.Range <> Trim(p.Range) Then p.Range = Trim(p.Range)
Next p
End Sub
As has been said by #Cindy Meister, I need to prevent endless creation of another paragraphs by trimming them. I bear in mind that paragraph range contains at least 1 character, so processing range - 1 character would be safe. Following has worked for me
Sub ProcessParagraphs()
Set docContent = ActiveDocument.Content
' replace TAB symbols throughout the document to single space (trim does not remove TAB)
docContent.Find.Execute FindText:=vbTab, ReplaceWith:=" ", Replace:=wdReplaceAll
For Each p In ActiveDocument.Paragraphs
' delete empty paragraph (delete operation is safe, we cannot enter enternal loop here)
If Len(p.range.Text) = 1 Then
p.range.Delete
' remove whitespaces
Else
Set thisRg = p.range
' shrink range by 1 character
thisRg.MoveEnd wdCharacter, -1
thisRg.Text = Trim(thisRg.Text)
End If
p.LeftIndent = 0
p.FirstLineIndent = 0
p.Reset
p.range.Font.Reset
Next
With Selection
.ClearFormatting
End With
End Sub
I saw a number of solutions here are what worked for me. Note I turn off track changes and then revert back to original document tracking status.
I hope this helps some.
Option Explicit
Public Function TrimParagraphSpaces()
Dim TrackChangeStatus: TrackChangeStatus = ActiveDocument.TrackRevisions
ActiveDocument.TrackRevisions = False
Dim oPara As Paragraph
For Each oPara In ActiveDocument.StoryRanges(wdMainTextStory).Paragraphs
Dim oRange As Range: Set oRange = oPara.Range
Dim endRange, startRange As Range
Set startRange = oRange.Characters.First
Do While (startRange = Space(1))
startRange.Delete 'Remove last space in each paragraphs
Set startRange = oRange.Characters.First
Loop
Set endRange = oRange
' NOTE: for end range must select the before last characted. endRange.characters.Last returns the chr(13) return
endRange.SetRange Start:=oRange.End - 2, End:=oRange.End - 1
Do While (endRange = Space(1))
'endRange.Delete 'NOTE delete somehow does not work for the last paragraph
endRange.Text = "" 'Remove last space in each paragraphs
Set endRange = oPara.Range
endRange.SetRange Start:=oRange.End - 1, End:=oRange.End
Loop
Next
ActiveDocument.TrackRevisions = TrackChangeStatus
End Function
I´m new to VBA and have to write a little Makro for work.
This Makro will be used to search for a Special set of symbols inside a Word Document.
So far I found a way to search for a string and mark it.
Yet it only functions with normal chars. The question is how to include symbols into the search.
My code so far is:
With Selection.Find
.ClearFormatting
.Text = "String"
.Execute Forward:=True
End With
The symbol-string needed to be found inside the document is: [•]
Thank You for Your Suggestions
Something as easy as this works for me:
Public Sub Testme()
With Selection.Find
.ClearFormatting
.Text = "•"
.Execute Forward:=True
End With
End Sub
If this is the bullet format and not a simple dot in a text, then you may use something like this to select the bulleted paragraph:
Sub FindBullet()
Dim rngTarget As Word.Range
Dim oPara As Word.Paragraph
Set rngTarget = Selection.Range
With rngTarget
Call .Collapse(wdCollapseEnd)
.End = ActiveDocument.Range.End
For Each oPara In .Paragraphs
If oPara.Range.ListFormat.ListType = _
WdListType.wdListBullet Then
oPara.Range.Select
Exit For
End If
Next
End With
End Sub
Source here.
In Word it's easy to use vba to apply a highlight to more than one string, word, sentence etc after the user of the document has Ctrl-selected a bunch of them.
However, when I Ctrl-select a few words and run the following statement, only the last of my selected words is changed.
Is there a way to apply wdtitleword to more than one selected word?
Thanks.
sub a()
Selection.Range.Case = wdTitleWord
end sub
Please try this:
Sub changeNonContigCase()
' Find the non-contig selection
If Selection.Font.Shading.BackgroundPatternColor = wdColorAutomatic Then
Selection.Font.Shading.BackgroundPatternColor = whtcolor
End If
' Find and process each range with .Font.Shading.BackgroundPatternColor = WhtColor
ActiveDocument.Range.Select
Selection.Collapse wdCollapseStart
With Selection.Find
.Font.Shading.BackgroundPatternColor = whtcolor
.Forward = True
.Wrap = wdFindContinue
Do While .Execute
' Do what you need
Selection.Range.Case = wdTitleWord
' Reset shading as you go
Selection.Font.Shading.BackgroundPatternColor = wdColorAutomatic
' Setup to find the next selection
Selection.Collapse wdCollapseEnd
Loop
End With
End Sub
This works, but is indirect. I don't think there is a more direct way to achieve this. You can modify to avoid resetting existing formatting that you need to preserve. Until now I didn't even know that it was possible to select a non-contiguous range in MS Word, pity it is not easier to work with in VBA.
I'm trying to find all instances of key words in a MS Word document and change their style. The key words are stored within an array and I want to change the style of the particular word only. Ideally this would happen as I type but that is not crucial.
Attempt 1 - Based on recording a macro and changing the search term
Sub Woohoo()
Dim mykeywords
mykeywords= Array("word1","word2","word3")
For myword= LBound(mykeywords) To UBound(mykeywords)
Selection.Find.ClearFormatting
Selection.Find.Replacement.ClearFormatting
Selection.Find.Replacement.Style = ActiveDocument.Styles("NewStyle")
With Selection.Find
.Text = mykeywords(myword)
.Replacement.Text = mykeywords(myword)
.Forward = True
.Wrap = wdFindContinue
.Format = True
.MatchCase = False
.MatchWholeWord = True
.MatchWildcards = False
.MatchSoundsLike = False
.MatchAllWordForms = False
End With
Selection.Find.Execute Replace:=wdReplaceAll
Next
End Sub
This changes the style of the entire paragraph where the words are in.
Attempt 2 - Based on this question here How can I replace a Microsoft Word character style within a range/selection in VBA?:
Sub FnR2()
Dim rng As Range
Dim mykeywords
mykeywords = Array("word1","word2","word3")
For nKey = LBound(mykeywords) To UBound(mykeywords)
For Each rng In ActiveDocument.Words
If IsInArray(rng, mykeywords(nKey)) Then
rng.Style = ActiveDocument.Styles("NewStyle")
End If
Next
Next
End Sub
This finds words that are in single lines but skips the words that are within a paragraph for some reason, e.g. it finds
Some text
word1
more text
but not
Some text before word1 means that the code above doesn't change the format
Word1 also isn't changed in this instance
Attempt 3 - AutoCorrect; not actually tried:
As an alternative I was thinking to use AutoCorrect. However I have more than 100 keywords and have no idea how to add this to the AutoCorrect list automatically (I'm fairly VBA illiterate). The other problem I would see with this approach is that I believe that AutoCorrect is global, whereas I need this only to work for a specific document.
I believe the reason why your macro isn't finding the words is due to the presence of leading or trailing blank spaces. Providing that you have already defined the style "NewStyle" changing your if statement in SubFnR2 from
If IsInArray(rng, mykeywords(nKey)) Then
to
If mykeywords(nkey) = LCase(Trim(rng.Text)) Then
Should solve the issue. By the way if you want to keep the style of the word depending on whether it is upper or lower case then remove the LCase part.
Edit:
I have included the sub with the modification below. I have tested it on the examples you gave (cut and pasted into word) and it changed the style for both instances word1.
Sub FnR3()
Dim rng As Range
Dim mykeywords
mykeywords = Array("word1", "word2", "word3")
Dim nkey As Integer
For nkey = LBound(mykeywords) To UBound(mykeywords)
For Each rng In ActiveDocument.Words
If mykeywords(nkey) = LCase(Trim(rng.Text)) Then
rng.Style = ActiveDocument.Styles("NewStyle")
End If
Next rng
Next nkey
End Sub
Ok, your document behaves has you described, I'm not quite sure why. I checked selecting the range and just the word was selected, but then the whole paragraph was formatted. I have modified the code to modify the selection, shown below. This did just change the word.
Sub FnR4()
Dim rng As Range
Dim mykeywords
mykeywords = Array("word1", "word2", "word3")
Dim nkey As Integer
For nkey = LBound(mykeywords) To UBound(mykeywords)
For Each rng In ActiveDocument.Words
Selection.Collapse
rng.Select
If mykeywords(nkey) = LCase(Trim(rng.Text)) Then
Selection.Style = ActiveDocument.Styles("NewStyle")
End If
Next rng
Next nkey
End Sub