Find any Arial and replace it with Times New Roman

[Chris Joyce]

I've been trying to work out how to replace the font format of one font only
,

in short I'm trying to Find any Arial and replace it with Times New Roman

With DocRange.Find
.ClearFormatting
.Replacement.ClearFormatting
.Format = True
.Font.Name = "Arial"
.Replacement.Font.Name = "Times New Roman"
.Text = ""
.Replacement.Text = ""
.Forward = True
.Wrap = wdFindContinue
.Execute Replace:=wdReplaceAll
End With

But it dose not seem to work :-(


I'm also trying to figure out how to change any 'winding' where the text is
'n/a' and change the font to Times New Roman .


Chris

 

[Jean-Guy Marcil]

Bonjour,

Dans son message, < Chris Joyce > écrivait :
In this message, < Chris Joyce > wrote:

|| I've been trying to work out how to replace the font format of one font
only
|| ,
||
|| in short I'm trying to Find any Arial and replace it with Times New Roman
||
|| With DocRange.Find
|| .ClearFormatting
|| .Replacement.ClearFormatting
|| .Format = True
|| .Font.Name = "Arial"
|| .Replacement.Font.Name = "Times New Roman"
|| .Text = ""
|| .Replacement.Text = ""
|| .Forward = True
|| .Wrap = wdFindContinue
|| .Execute Replace:=wdReplaceAll
|| End With
||
|| But it dose not seem to work :-(

How is it not working?
You are not giving us much to go on!

Just to be sure, I pasted your code in a document that had some Arial text,
and it worked. (Word XP)

--
Salut!
_______________________________________
Jean-Guy Marcil - Word MVP
(e-mail address removed)
Word MVP site: http://www.word.mvps.org

 

[Chris Joyce]

It just dose not work , no error, no resault

I have the code being called by the autoopen() Macro.

I tried doing a manual find/replace via

<CTRL-H> Format/Font , It fails as well ( but only on some of the document
!


The other one that fials is the 'Wingdins' to 'Times New Roman' where the
text is 'N/A'


Thanks for your help

Chris




http://www.chrisjoyce.id.au/Staff_Review.zip

 

[Chris Joyce]

This is the code in full


Chris


Private Sub Collect_Reports_Click()
'
'_______________________________________
'
' Set some Varables to use

Dim rstClass_T As ADODB.Recordset
Dim strSQLclass As String
Dim CounterClass

Dim rstStudent_T As ADODB.Recordset
Dim strSQLstudent As String
Dim CounterStudent

Dim strCnn As String
Dim varBookmark As Variant
Dim strCommand As String
Dim lngMove As Long

Dim wdApp As Word.Application
Dim FindMe As String
Dim FindMeIn As String
Dim DocRange As Range
Dim PageNum As Long
Dim PageRge As Range
'
'_______________________________________
' Open student recordset to work with

Set wdApp = New Word.Application
wdApp.Visible = False

strSQLstudent = "SELECT Class_T.Student FROM Class_T "
strSQLstudent = strSQLstudent & "GROUP BY Class_T.Student "
strSQLstudent = strSQLstudent & "ORDER BY Class_T.Student "

Set rstStudent_T = New ADODB.Recordset
rstStudent_T.CursorType = adOpenStatic
rstStudent_T.CursorLocation = adUseClient
rstStudent_T.Open strSQLstudent, CurrentProject.Connection, , , adCmdText

' Go to first record
rstStudent_T.MoveFirst

' Use a counter to keep track of where we are in the recordset
CounterStudent = 0

'_______________________________________
' Start of loop to create many student review doc's

While CounterStudent < (rstStudent_T.RecordCount)
CounterStudent = CounterStudent + 1

'_______________________________________
' What student
FindMe = rstStudent_T!Student

' ***************
' cover.doc contains a few pages that cover review systems
' need to add dynamic select of cover documents based on system
' ***************
wdApp.Documents.Open FileName:=CurrentProject.Path & "\" & "cover.doc",
ReadOnly:=True

'_______________________________________
' Open class recordset to work with

strSQLclass = "SELECT Class_T.Student, Class_T.Class "
strSQLclass = strSQLclass & "FROM Class_T where Class_T.Student = '" &
FindMe & "' "
strSQLclass = strSQLclass & "ORDER BY Class_T.Porder, Class_T.Class "

Set rstClass_T = New ADODB.Recordset
rstClass_T.CursorType = adOpenStatic
rstClass_T.CursorLocation = adUseClient
rstClass_T.Open strSQLclass, CurrentProject.Connection, , , adCmdText

' Go to first record
rstClass_T.MoveFirst

' Use a counter to keep track of where we are in the recordset
CounterClass = 0

'_______________________________________
' Start of loop to open and search many review doc's

While CounterClass < (rstClass_T.RecordCount)
CounterClass = CounterClass + 1

'_______________________________________
' What class
FindMeIn = rstClass_T!Class

'_______________________________________
' What class add start of loop to open and search many review doc's
' ***************
' need to add a test to see if doc is real , to stop errors
' ***************
wdApp.Documents.Open FileName:=CurrentProject.Path & "\" & FindMeIn &
".doc", ReadOnly:=True
wdApp.Documents(1).Activate

' ***************
' need to add a test to see if doc is already unprotected
' ***************
wdApp.Documents(1).Unprotect

'_______________________________________
' Get the students from the review class document and
' add there resaults into a student review document

Set DocRange = wdApp.ActiveDocument.Range

PageNum = 0

With DocRange.Find
.Text = FindMe
.Forward = True
.Wrap = wdFindStop
.Format = False
.MatchCase = False
.MatchWholeWord = False
.MatchWildcards = False
.MatchSoundsLike = False
.MatchAllWordForms = False

Do While .Execute
DocRange.Select
'This is to make sure that we do not copy the same
'page many times if the searched text is found more
'than once on the same page
With Selection
If Not PageNum = DocRange.Information(wdActiveEndPageNumber)
Then
PageNum = DocRange.Information(wdActiveEndPageNumber)

Set PageRge = DocRange.Bookmarks("\Page").Range
PageRge.Copy

With wdApp.Documents(2).Range
.Collapse wdCollapseEnd
.Paste
' .InsertBreak wdSectionBreakNextPage 'or wdPageBreak
End With

End If
End With
Loop
End With

' ***************
' should add a test to find out if a student resaults are missing from a
review document ?
' ***************

' Close src Document
wdApp.Documents(1).Close (False)

'_______________________________________
' Next record
varBookmark = rstClass_T.Bookmark
rstClass_T.Move 1
Wend
rstClass_T.Close
'_______________________________________
' End of loop to open and search many review doc's

'_______________________________________
' Do the page setup for the Report

wdApp.Documents(1).Activate

'_______________________________________
' Do the page print setup
Set DocRange = wdApp.ActiveDocument.Range
With DocRange.PageSetup
.LineNumbering.Active = False
.Orientation = wdOrientPortrait
.TopMargin = CentimetersToPoints(0.5)
.BottomMargin = CentimetersToPoints(0.5)
.LeftMargin = CentimetersToPoints(2)
.RightMargin = CentimetersToPoints(1.81)
.Gutter = CentimetersToPoints(0)
.HeaderDistance = CentimetersToPoints(1.25)
.FooterDistance = CentimetersToPoints(1.25)
.PageWidth = CentimetersToPoints(21)
.PageHeight = CentimetersToPoints(29.7)
.FirstPageTray = wdPrinterDefaultBin
.OtherPagesTray = wdPrinterDefaultBin
.OddAndEvenPagesHeaderFooter = False
.DifferentFirstPageHeaderFooter = False
.VerticalAlignment = wdAlignVerticalTop
.SuppressEndnotes = False
.MirrorMargins = False
.TwoPagesOnOne = False
.BookFoldPrinting = False
.BookFoldRevPrinting = False
.BookFoldPrintingSheets = 1
.GutterPos = wdGutterPosLeft
End With

'_______________________________________
' Find any Arial and replace it with Times New Roman
' ***************
' this dose not work at the moment
' ***************
Set DocRange = wdApp.ActiveDocument.Range

With DocRange.Find
.ClearFormatting
.Replacement.ClearFormatting
.Format = True
.Font.Name = "Arial"
.Replacement.Font.Name = "Times New Roman"
.Text = ""
.Replacement.Text = ""
.Forward = True
.Wrap = wdFindContinue
.MatchCase = False
.MatchWholeWord = False
.MatchWildcards = False
.MatchSoundsLike = False
.MatchAllWordForms = False
End With
wdApp.Selection.Find.Execute Replace:=wdReplaceAll

'_______________________________________
' Find any N/A winddings and replace it with Times New Roman
' they are all part of the form
' ***************
' this dose not work at the moment
' ***************

Set DocRange = wdApp.ActiveDocument.Range
With DocRange.Find
.Font.Name = "Wingdings"
.Replacement.Font.Name = "Times New Roman"
.Text = "N/A"
.Replacement.Text = "N/A"
.Forward = True
.Wrap = wdFindContinue
.Format = True
.MatchCase = False
.MatchWholeWord = True
.MatchWildcards = False
.MatchSoundsLike = False
.MatchAllWordForms = False
End With
wdApp.Selection.Find.Execute Replace:=wdReplaceAll


'_______________________________________
' Print The Report if needed

If Me.PrintChk.Value = -1 Then
wdApp.Application.PrintOut FileName:="", Range:=wdPrintAllDocument,
Item:= _
wdPrintDocumentContent, Copies:=1, Pages:="",
PageType:=wdPrintAllPages, _
ManualDuplexPrint:=False, Collate:=True, Background:=True,
PrintToFile:= _
False, PrintZoomColumn:=0, PrintZoomRow:=0, PrintZoomPaperWidth:=0,
_
PrintZoomPaperHeight:=0
End If

'_______________________________________
' Save then close
wdApp.Documents(1).SaveAs (CurrentProject.Path & "\output\" & FindMe)
wdApp.Documents(1).Close

'_______________________________________
' Open the full student report and set AllowOnlyReading protection
' ***************
' work out how to save with AllowOnlyReading protection
' ***************
wdApp.Documents.Open FileName:=CurrentProject.Path & "\output\" & FindMe &
".doc"
wdApp.Documents(1).Activate
' wdApp.Documents(1).ProtectionType = wdAllowOnlyReading
wdApp.Documents(1).Save
wdApp.Documents(1).Close

varBookmark = rstStudent_T.Bookmark
rstStudent_T.Move 1
Wend
rstStudent_T.Close

wdApp.Quit
'_______________________________________

MsgBox ("Done")

End Sub

 

[Jean-Guy Marcil]

Bonjour,

Dans son message, < Chris Joyce > écrivait :
In this message, < Chris Joyce > wrote:

See inline comments.

|| wdApp.Documents(1).Activate
||

Here you activate the first document of the Word instance you created at the
top of the code...

|| '_______________________________________
|| ' Do the page print setup

.... and you assign the whole document range to a range object called
DocRange

|| Set DocRange = wdApp.ActiveDocument.Range
|| With DocRange.PageSetup
|| .LineNumbering.Active = False
|| .Orientation = wdOrientPortrait
|| .TopMargin = CentimetersToPoints(0.5)
|| .BottomMargin = CentimetersToPoints(0.5)
|| .LeftMargin = CentimetersToPoints(2)
|| .RightMargin = CentimetersToPoints(1.81)
|| .Gutter = CentimetersToPoints(0)
|| .HeaderDistance = CentimetersToPoints(1.25)
|| .FooterDistance = CentimetersToPoints(1.25)
|| .PageWidth = CentimetersToPoints(21)
|| .PageHeight = CentimetersToPoints(29.7)
|| .FirstPageTray = wdPrinterDefaultBin
|| .OtherPagesTray = wdPrinterDefaultBin
|| .OddAndEvenPagesHeaderFooter = False
|| .DifferentFirstPageHeaderFooter = False
|| .VerticalAlignment = wdAlignVerticalTop
|| .SuppressEndnotes = False
|| .MirrorMargins = False
|| .TwoPagesOnOne = False
|| .BookFoldPrinting = False
|| .BookFoldRevPrinting = False
|| .BookFoldPrintingSheets = 1
|| .GutterPos = wdGutterPosLeft
|| End With
||
|| '_______________________________________
|| ' Find any Arial and replace it with Times New Roman
|| ' ***************
|| ' this dose not work at the moment
|| ' ***************

Why do you reset DocRange to exactly the same thig as above?

|| Set DocRange = wdApp.ActiveDocument.Range

You initialize a find with DocRange...

||
|| With DocRange.Find
|| .ClearFormatting
|| .Replacement.ClearFormatting
|| .Format = True
|| .Font.Name = "Arial"
|| .Replacement.Font.Name = "Times New Roman"
|| .Text = ""
|| .Replacement.Text = ""
|| .Forward = True
|| .Wrap = wdFindContinue
|| .MatchCase = False
|| .MatchWholeWord = False
|| .MatchWildcards = False
|| .MatchSoundsLike = False
|| .MatchAllWordForms = False
|| End With
|| wdApp.Selection.Find.Execute Replace:=wdReplaceAll

....but do the .Execute on wdApp ???
Never tried that! This might be the problem!
This code is different from the one you posted initially (thew one that
worked on my machine).
Which one are you really using? This one or the one posted before?

Try with
.Execute Replace:=wdReplaceAll
just before the
EndWith
above, and of course remove the
wdApp.Selection.Find.Execute Replace:=wdReplaceAll
line.

Same comments for your Windings replace below as the comments written above.

||
|| '_______________________________________
|| ' Find any N/A winddings and replace it with Times New Roman
|| ' they are all part of the form
|| ' ***************
|| ' this dose not work at the moment
|| ' ***************
||
|| Set DocRange = wdApp.ActiveDocument.Range
|| With DocRange.Find
|| .Font.Name = "Wingdings"
|| .Replacement.Font.Name = "Times New Roman"
|| .Text = "N/A"
|| .Replacement.Text = "N/A"
|| .Forward = True
|| .Wrap = wdFindContinue
|| .Format = True
|| .MatchCase = False
|| .MatchWholeWord = True
|| .MatchWildcards = False
|| .MatchSoundsLike = False
|| .MatchAllWordForms = False
|| End With
|| wdApp.Selection.Find.Execute Replace:=wdReplaceAll
||
||

Here, just to make your code more efficient, remove all the wdApp from the
beginning of each line, put a
With wdApp
before
.Documents.Open FileName:=CurrentProject.Path & "\output\" & FindMe &
".doc"
(Where the wdApp has been removed) and add a
End With
after
.Quit
(Where the wdApp has been removed).
Don't forget to make sure that each line between the "With wdApp" and "End
With" starts with a "." (dot).

||
|| '_______________________________________
|| ' Save then close
|| wdApp.Documents(1).SaveAs (CurrentProject.Path & "\output\" & FindMe)
|| wdApp.Documents(1).Close
||
|| '_______________________________________
|| ' Open the full student report and set AllowOnlyReading protection
|| ' ***************
|| ' work out how to save with AllowOnlyReading protection
|| ' ***************
|| wdApp.Documents.Open FileName:=CurrentProject.Path & "\output\" & FindMe
&
|| ".doc"
|| wdApp.Documents(1).Activate
|| ' wdApp.Documents(1).ProtectionType = wdAllowOnlyReading
|| wdApp.Documents(1).Save
|| wdApp.Documents(1).Close
||
|| varBookmark = rstStudent_T.Bookmark
|| rstStudent_T.Move 1
|| Wend
|| rstStudent_T.Close
||
|| wdApp.Quit
|| '_______________________________________
||
|| MsgBox ("Done")
||
|| End Sub

--
Salut!
_______________________________________
Jean-Guy Marcil - Word MVP
(e-mail address removed)
Word MVP site: http://www.word.mvps.org

 

[Klaus Linke]

Hi Chris,

If the font is Wingdings, but Word says "Arial" if you select the
character, Word won't allow you to change it to another font.
This happens if you insert symbols from a "decorative" font from the
"Insert > Symbol" dialog.

You should be able to find them when you look for "Wingdings" after you
have run the macro below.

But since the codes behind characters from decorative fonts are pretty
arbitrary, it probably won't make sense to simply change the font to Times
New Roman; you'd need to replace the different symbols with corresponding
Unicode symbols in TNR that look more or less the same (if such are
available).

Regards,
Klaus



Sub SymbolsUnprotect2()
'
Dim SelFont, SelCharNum

Selection.Collapse (wdCollapseStart)
Selection.Find.ClearFormatting
With Selection.Find
.Text = "[" & ChrW(61472) & "-" & ChrW(61695) & "]"
.Replacement.Text = ""
.Forward = True
.Wrap = wdFindContinue
.Format = False
.MatchCase = False
.MatchWholeWord = False
.MatchAllWordForms = False
.MatchSoundsLike = False
.MatchWildcards = True
End With
While Selection.Find.Execute
With Dialogs(wdDialogInsertSymbol)
SelFont = .Font
SelCharNum = .CharNum
End With

Selection.Font.Name = SelFont
Selection.TypeText Text:=ChrW(SelCharNum)

' replace the last 2 lines with the following to
' protect symbols from decorative fonts:
' Selection.InsertSymbol _
' Font:=SelFont, _
' CharacterNumber:=SelCharNum, _
' Unicode:=True

Wend
End Sub