Solved: Replace formatted chars with real chars (VBA help needed)

[Paul_Hossler]

Not a good title I know:doh:

I recently got a really good font that has true small caps, super/sub scripts, ligatures, etc. up in the unicode high numbers

Word will (AFAIK) not make use of the true character (e.g. U2070 for a superscript zero), but will format a regular zero smaller and position it higher. Same for subscripts, small caps, etc.

Normally for 'routine' stuff a formatted superscript 0 is good 'nuff. But ... sometimes I need to do something that really has to look stunning (or as good as I can make it with Word).

I could enter 2070 + Alt-x and that works, but gets tedious because I'd need to look up a lot of the codes each time, slows done the production, and mostly I'm lazy -- I'd like to get it set up once time, and not have to do it a lot.

Occurs to me that I could do everything in regular Word formatting, and then run a 'Replace' macro at end. Something like ...

Replace all '0' with format = superscript with U2070
.....
Replace all '9' with format = superscript with U2079


Same for small caps, special symbols, ligatures, etc.


If some kind hearted Word VBA guru(s) could get me started, it's help.

A brute force approach would be OK, since this wouldn't get run until the end, and the Unicode characters often do not follow any logical pattern.

Thanks !!!!:beerchug:

Paul

[Oorang]

There might be a more painless way of doing this. I just use a character I never use for anything else (personally I use the tilda, but just about anything works.) Then you can safely use the ctrl-h feature.

[Paul_Hossler]

Aaron -- Thanks, but I was thinking that I could work within Word's existing Sub/Superscript, Small Caps, etc. features until the end, and run the 'Replace' macro to replace the formatted text with the Unicode character appropriate to that format --

1. Replace all '0's formated = superscript with U2070
2. Replace all '1's formated = superscript with U2071
3. Replace all '2's formated = superscript with U2072
etc.
etc.

123. Replace all 'A' with format = small caps with Uxxxx
124. Replace all 'B' with format = small caps with Uxxxx
etc.

Bit brute force i know, but there doesn't seem to be any correlation between the ASCII and the Unicode. This would be a "once at the end" so I could live with it.

Making matters worse, is the fact that different fonts/typefaces have the superscript-0 in different slots. :banghead:

[lucas]

Hi Paul,
Since this is a word document I was wondering if there might be other text in the document that might be affected by this unless you target more specifically...like a selection. If the letter a is found in a word somewhere in the document for example it would be changed also...

[lucas]

This will insert your character and toggle alt-x for you:
Sub Macro1()
Selection.TypeText Text:="2070"
Selection.ToggleCharacterCode
End Sub

[fumei]

Indeed. The numbers (super or sub) should not be an serious issue, but the letters....

First of all, what, exactly. would be the logic? Only existing capital letters? Only words at the beginning of a sentence?

Even for the numbers there is still brute force in that you would have to check every single character in the document.

What is it?
It is a 9.
Is it superscript?
Yes? - change it
No?
Is it subscript?
Yes? - change it
No?
Go on to the next character.

Talk about brute force. Can you tighten the logic to not do it character by character?

[Paul_Hossler]

lucas - thanks, but the problem is not inserting a single char, but taking a doc with a lot of sub/superscripts, small caps, etc. and doing a global.

I had envisioned a macro that runs a bunch of .Replace's.

[Paul_Hossler]

Thanks all -- here's some more info to see if it better conveys what I think I'd like to do. Using XP-SP2, and Office 2003

This is as far as I got in my test

Macro1 made some text into Small Caps
Macro2 (my problem) does a F&R selecting the letter A in small caps, but I can't get the unicode value in as a replacement

If I can get this small test working, then I can extend the concept to the other Word-formatted characters that I would like to replace with their unicode character (which looks better)

I might have to do all 26 letters and the numbers one at a time, and then the sub and super scripts, and then the ligatures, and then .... you get the idea:( . Have to start it before i go to bed:rotlaugh:




Sub Macro1()
With Selection.Font
.Name = "Adobe Garamond Pro"
.Size = 11
.SmallCaps = True
End With
End Sub
Sub Macro2()
Selection.Find.ClearFormatting
Selection.Find.Replacement.ClearFormatting
With Selection.Find
.Text = "A"
.Font.SmallCaps = True 'only A's in small caps
.Replacement.Text = "F761" 'needs to be the Unicode value
.Forward = True
.Wrap = wdFindContinue
.Format = True
.MatchCase = False
.MatchWholeWord = False
.MatchWildcards = False
.MatchSoundsLike = False
.MatchAllWordForms = False
End With
Selection.Find.Execute Replace:=wdReplaceAll
End Sub



I am open to suggestions if there's a better way someone can suggest. Maybe searching for text insmall caps, and then swapping out the chars one at a time???

Paul

[fumei]

Perhaps something like:Dim r As Range
Set r = ActiveDocument.Range
With r.Find
.Text = "A "
.Font.SmallCaps = True
Do While .Execute(Forward:=True) = True
r.Select
Selection.Text = "00A9"
Selection.ToggleCharacterCode
r.Collapse Direction:=wdCollapseEnd
Loop
End WithThis toggles to the copyright character (Unicode 00A9). Unfortunately .ToggleCharacter only works for Selection, so you actually have to select the found Range.

Why would they not let you ToggleCharacter on a range??? Odd, that.

Also, strange I have no recollection of this before, but "A " is also changing "a ".

I would have thought that .Text = "A " is literal.

Anyway, this may point you to a possible avenue.

[Paul_Hossler]

Fumei -I'd call that major progress:cloud9:

Still very brute force, but workable ... very workable. Haven't tried it on anything like a long document yet.

I assume that the regular <--> Unicode conversion done with .ToggleCharacterCode is equivalent the the Alt-x KB command to do the sme thing, and Alt-x only does a single hex char comversion.

1. I added .MatchCase and now it's only replacing LC a's in SmCaps
2. Also added a .Font.SmallCaps = False after the Unicode char goes in

This is the prototype. Still not nearly as elegant as I'd like.

I tried being clever with looping since the SmCap and the regular letters are sequential, but couldn't get the Hex part to work right:banghead:

Can you or anyone see and effeciencies that I can make??? :think:

Many thanks again



Sub MakeSmallCaps()
Dim i As Long, iStart As Long
Application.ScreenUpdating = False

' Small Caps
' "f721" "exclamsmall"
' "f73f" "questionsmall"
' "f726" "ampersandsmall"
' "f761" "Asmall"
' "f762" "Bsmall"
' "f763" "Csmall"
' "f764" "Dsmall"
' "f765" "Esmall"
' "f766" "Fsmall"
' "f767" "Gsmall"
' "f768" "Hsmall"
' "f769" "Ismall"
' "f76a" "Jsmall"
' "f76b" "Ksmall"
' "f76c" "Lsmall"
' "f76d" "Msmall"
' "f76e" "Nsmall"
' "f76f" "Osmall"
' "f770" "Psmall"
' "f771" "Qsmall"
' "f772" "Rsmall"
' "f773" "Ssmall"
' "f774" "Tsmall"
' "f775" "Usmall"
' "f776" "Vsmall"
' "f777" "Wsmall"
' "f778" "Xsmall"
' "f779" "Ysmall"
' "f77a" "Zsmall"

Call pvtSmallCaps("a", "F761")
Call pvtSmallCaps("b", "F762")
Call pvtSmallCaps("c", "F763")
Call pvtSmallCaps("d", "F764")

Call pvtSmallCaps("z", "F77A")
End Sub

Private Sub pvtSmallCaps(StandardChar As String, UniChar As String)
Dim r As Range

Set r = ActiveDocument.Range

With r.Find

.MatchCase = True
.Text = StandardChar
.Font.SmallCaps = True

Do While .Execute(Forward:=True) = True
r.Select
Selection.Text = UniChar
Selection.ToggleCharacterCode
Selection.Font.SmallCaps = False
r.Collapse Direction:=wdCollapseEnd
Loop

End With

End Sub

[TonyJollans]

What about something like this:

With ActiveDocument.Content.Find
.ClearFormatting
.Replacement.ClearFormatting
.Font.SmallCaps = True
.Replacement.Font.SmallCaps = False
.Forward = True
.Wrap = wdFindStop
.Format = True
.MatchCase = False
.MatchWholeWord = False
.MatchKashida = False
.MatchDiacritics = False
.MatchAlefHamza = False
.MatchControl = False
.MatchAllWordForms = False
.MatchSoundsLike = False
.MatchWildcards = False
For ascii = 32 To 127
.Execute FindText:=Chr(ascii), ReplaceWith:=ChrW(ascii + 63264), Replace:=wdReplaceAll
Next
End With



Don't know if it's exactly right as I don't have the special fonts but maybe worth trying.

[Paul_Hossler]

Really coming together now :cloud9:

1. I incorporporated the ChrW in .Replace, and that got rid of having to .ToggleCharCode one selection at a time

2. Decided to forego the looping (for now), since the mappings always have the hex unicode value associalted with the glyph.

3. Got lazy and incorported the Hex-to-decimal in VBA, instead of converting in advance. Since each font would likely have a different mapping, didn't want to have to to that a lot.

Appreaciate all your help, and I'll mark this one 'Solved' in a while. Who knows, some one else may have a good idea for me !!!


Thanks again

Paul


This is subset of the current version if you're interested.


Option Explicit
Sub GaramondProUnicode()
If MsgBox("Are you ready to replace the formated characters with Unicode equivalents?", _
vbQuestion + vbYesNo + vbDefaultButton2, "GaramondProUnicode") = vbNo Then Exit Sub
Application.ScreenUpdating = False

'----------------------------------- Small Caps
Call pvtSmallCaps("a", "F761")
Call pvtSmallCaps("b", "F762")
Call pvtSmallCaps("c", "F763")

Call pvtSmallCaps("!", "F721")
Call pvtSmallCaps("?", "F73F")
Call pvtSmallCaps("&", "F726")


'----------------------------------- Superscripts
Call pvtSuperScript("(", "207D")
Call pvtSuperScript(")", "207E")

Call pvtSuperScript("a", "F6E9")
Call pvtSuperScript("b", "F6EA")

Call pvtSuperScript("0", "2070")
Call pvtSuperScript("1", "00B9")

'----------------------------------- Subscripts
Call pvtSubScript("(", "208D")
Call pvtSubScript(")", "208E")

Call pvtSubScript("0", "2080")
Call pvtSubScript("1", "2081")

'----------------------------------- Ligatures
Call pvtChars("ffi", "FB03") ' need this first to avoid ff changed before ffi
Call pvtChars("ffl", "FB04")
Call pvtChars("ffj", "E088")

Call pvtChars("ff", "FB00")
Call pvtChars("fi", "FB01")
Call pvtChars("fl", "FB02")
Call pvtChars("fj", "E089")
Call pvtChars("Th", "E053")


'----------------------------------- Fractions
Call pvtChars("1/4 ", "00BC")
Call pvtChars("1/2 ", "00BD")
Call pvtChars("3/4 ", "00BE")
Call pvtChars("1/3 ", "2153")
Call pvtChars("2/3 ", "2154")
End Sub

'---------------------------------------------------------------
Private Sub pvtChars(StandardChar As String, UniChar As String)

Application.StatusBar = "Replacing single character(s) " & StandardChar & " with Unicode value " & UniChar

With ActiveDocument.Content.Find
.ClearFormatting
.Replacement.ClearFormatting
.Forward = True
.Wrap = wdFindStop
.Format = True
.MatchCase = True
.MatchWholeWord = False
.MatchKashida = False
.MatchDiacritics = False
.MatchAlefHamza = False
.MatchControl = False
.MatchAllWordForms = False
.MatchSoundsLike = False
.MatchWildcards = False
.Execute FindText:=StandardChar, ReplaceWith:=ChrW(Hex2Long(UniChar)), Replace:=wdReplaceAll
End With

Application.StatusBar = ""

End Sub

'---------------------------------------------------------------
Private Sub pvtSmallCaps(StandardChar As String, UniChar As String)

Application.StatusBar = "Replacing Small Cap " & StandardChar & " with Unicode value " & UniChar

With ActiveDocument.Content.Find
.ClearFormatting
.Replacement.ClearFormatting
.Font.SmallCaps = True
.Replacement.Font.SmallCaps = False
.Forward = True
.Wrap = wdFindStop
.Format = True
.MatchCase = False
.MatchWholeWord = False
.MatchKashida = False
.MatchDiacritics = False
.MatchAlefHamza = False
.MatchControl = False
.MatchAllWordForms = False
.MatchSoundsLike = False
.MatchWildcards = False
.Execute FindText:=StandardChar, ReplaceWith:=ChrW(Hex2Long(UniChar)), Replace:=wdReplaceAll
End With

Application.StatusBar = ""

End Sub

'---------------------------------------------------------------
Private Sub pvtSuperScript(StandardChar As String, UniChar As String)
Application.StatusBar = "Replacing Superscripts " & StandardChar & " with Unicode value " & UniChar

With ActiveDocument.Content.Find
.ClearFormatting
.Replacement.ClearFormatting
.Font.Superscript = True
.Replacement.Font.Superscript = False
.Forward = True
.Wrap = wdFindStop
.Format = True
.MatchCase = False
.MatchWholeWord = False
.MatchKashida = False
.MatchDiacritics = False
.MatchAlefHamza = False
.MatchControl = False
.MatchAllWordForms = False
.MatchSoundsLike = False
.MatchWildcards = False
.Execute FindText:=StandardChar, ReplaceWith:=ChrW(Hex2Long(UniChar)), Replace:=wdReplaceAll
End With

Application.StatusBar = ""

End Sub

'---------------------------------------------------------------
Private Sub pvtSubScript(StandardChar As String, UniChar As String)

Application.StatusBar = "Replacing Subscripts " & StandardChar & " with Unicode value " & UniChar

With ActiveDocument.Content.Find
.ClearFormatting
.Replacement.ClearFormatting
.Font.Subscript = True
.Replacement.Font.Subscript = False
.Forward = True
.Wrap = wdFindStop
.Format = True
.MatchCase = False
.MatchWholeWord = False
.MatchKashida = False
.MatchDiacritics = False
.MatchAlefHamza = False
.MatchControl = False
.MatchAllWordForms = False
.MatchSoundsLike = False
.MatchWildcards = False
.Execute FindText:=StandardChar, ReplaceWith:=ChrW(Hex2Long(UniChar)), Replace:=wdReplaceAll
End With

Application.StatusBar = ""


End Sub
'======================================================================
Function Hex2Long(Hex As String) As Long
Dim sHex As String

sHex = Right("0000" & Hex, 4)

Hex2Long = _
pvtHexTolong(Mid(sHex, 1, 1)) * 4096 + _
pvtHexTolong(Mid(sHex, 2, 1)) * 256 + _
pvtHexTolong(Mid(sHex, 3, 1)) * 16 + _
pvtHexTolong(Mid(sHex, 4, 1))

End Function


Private Function pvtHexTolong(Hex As String) As Long

Select Case Hex
Case "0": pvtHexTolong = 0
Case "1": pvtHexTolong = 1
Case "2": pvtHexTolong = 2
Case "3": pvtHexTolong = 3
Case "4": pvtHexTolong = 4
Case "5": pvtHexTolong = 5
Case "6": pvtHexTolong = 6
Case "7": pvtHexTolong = 7
Case "8": pvtHexTolong = 8
Case "9": pvtHexTolong = 9
Case "A", "a": pvtHexTolong = 10
Case "B", "b": pvtHexTolong = 11
Case "C", "c": pvtHexTolong = 12
Case "D", "d": pvtHexTolong = 13
Case "E", "e": pvtHexTolong = 14
Case "F", "f": pvtHexTolong = 15
Case Else
pvtHexTolong = -1
End Select
End Function