Attribute VB_Name = "WPSymbolConv"
Option Explicit
Sub WPSymbolConverter()
' Version 1.31a, 20 January 2008, one character added 28 February 2010
' For use with Word 2003 or earlier; use later version for Word 2007 or later
' Described and downloadable from http://wpdos.org/wptoword.html#macroword
' To speed up this macro, please scroll down one or two screens and read
' the section headed "How to make this macro faster - with warnings!"
' If you received an error message about your language version, scroll down
' one or two screens to find "instructions for editing your language version"
'------------------------------------------- About this macro
' This macro cleans up WordPerfect files imported in Word 2002
' and Word 2003 in which typographic and other characters are
' displayed in the WP TypographicSymbols and other special fonts
' instead of as ordinary Windows characters.
' The working sections of this macro were written almost entirely
' by Helmut Weber. The code that loops through all ranges is from
' a public posting by Doug Robbins; other improvements were suggested
' by Jay Freedman; the list of replacement characters is largely by
' Klaus Linke. The macro was put together in this form, with error
' messages and non-essential code, by Edward Mendelson, e-mail:
' emendelson#at#compuserve#dot#com (replace #at# with @, #dot# with dot).
'
' To avoid seeing an error message when you copy this macro into
' the Microsoft Visual Basic editor, you must insert a form element
' in your VBA environment. Open the Visual Basic editor (Alt-F11 in Word),
' press Ctrl-R to go to the Project panel near the upper left of the editor
' window. In the Project panel, click or move up to the bold-face name
' "Normal" and click on it or highlight it. (If your default template has
' a different name from "Normal" (i.e. Normal.Dot), click on the name of
' your default template. Now, from the top-line menu, use Insert/UserForm,
' and simply close the form that appears on screen. You should not do
' anything with the form; it simply needs to exist.
'------------------------------------------- Initial error handler
On Error GoTo SomethingWrongHandler
'------------------------------------------- Declarations, etc.
Dim toggleOK As Boolean ' OK to use ToggleParens?
Dim rDcm As Range ' document range
Dim oDcm As Document ' object document
'Set oDcm = ActiveDocument ' for brevity only
'moved down because causes error if document not open
Dim tCount As Long ' total number of substiutions
Dim iCount As Long ' increment number of substitutions
Dim msgTi As String ' message box title
tCount = 0
iCount = 0
msgTi = "WP Symbol Converter"
'----------------------------------- How to make this macro faster - with warnings!
' The next line causes this macro to go more slowly than it can go, but the line is
' present in order to protect the inverted Spanish exclamation mark (¡) from being
' converted into the "(" character by the macro.
toggleOK = True
' toggleOK *must* = False IF there is any possibility that the inverted
' Spanish exclamation mark will be in your file. However, you may
' speed up the macro by replacing "False" with "True" (without quotation marks!)
' if ANY of thefollowing conditions are true about your files:
' (1) you are certain that the inverted Spanish exclamation mark (¡)
' is NOT present in any documents that you want to convert, OR
' (2) you are certain that all your documents were originally created in
' WordPerfect 6, 7, 8, 9, 10, 11, 12, or later versions and that they
' were never saved in WP 4.x or 5.x format, and never opened in any copy
' of WordPerfect 4.x or 5.x, OR
' (3) the font "WP TypographicSymbols" is not installed in your Windows system
' (in which case you probably do not need this macro anyway)
'-------------------------- Instructions for editing for your languge version
' If you received the message saying that you must edit the macro for your language
' version, here are the instructions.
'
' First, remember the language code number displayed by the error message. Then,
' in Microsoft Word, choose the "Insert" menu, then the menu item "Symbol"
' (of course, these will have different names in your language). When the Insert
' Symbol dialog is open, look name that appears to the left of the the dropdown list
' of fonts; the name will be the word "Font" in your language. A letter (generally the
' first letter) in that name may be underlined; if no letter is underlined, hold down
' the Alt key and the underline will appear. If that letter is X, you will need to
' remember this combination: %x (that is, percent-x, or whatever letter you found).
'
' Next, remember which letter is used in your langauge version with the Ctrl key in
' order to Copy text; in English, the Copy key is Ctrl-C; it may be different in your
' language. If the Copy key in your language is Y, you will need to remember this
' combination: ^y (carat-y, or whatever letter is required).
'
' Next go to the foot of this window (use Ctrl-End), where you find a list with
' some lines that look like this:
'
' 'Case 1029: skStr = "%-^-{ESC}{ESC}" ' Czech
' 'Case 1030: skStr = "%-^-{ESC}{ESC}" ' Danish
' Case 1031: skStr = "%s^c{ESC}{ESC}" ' German
' Case 1033: skStr = "%f^c{ESC}{ESC}" ' English
'
' If you find your language already listed, but with a comment mark (') at the
' left, (1) remove the comment mark, (2) replace the hyphen in %- with the correct
' letter that goes to the Font field in your version, and (3) replace the hyphen
' in ^- with the correct letter for the Copy key in your version. If you do not find
' your language already listed, construct a new line on the basis of the existing
' ones, with your language code number as the second item on the line that you
' create. Note that ESC is inside curly braces, not brackets or parentheses. Here
' is an example of a line that you might create (the real line should have no
' comment mark at the beginning of the line):
'
' Case 9999: skStr = "%x^y{ESC}{ESC}" ' Klingon
'
' Warning: Do NOT use this imaginary example! It will NOT work! You MUST follow the
' instructions and use the correct numbers and characters for your language!
'
' ------------------------- Language version test for SendKeys in other subs
Dim skStr As String
StringSendKeys skStr
If skStr = "NoMatch" Then
WrongLanguageVersion msgTi
Exit Sub
End If
'-------------------------- Application version test
Dim aVer As Single
aVer = Val(Application.Version)
Debug.Print aVer
If aVer < 9.9 Then
msgBox Prompt:="This macro is useful only in Word 2002 (Word XP) or later versions.", _
Title:=msgTi, Buttons:=vbExclamation
Exit Sub
End If
' ----------------- If no documents are open, exit
Dim noDoc As Boolean
noDoc = False
NoOpenDoc noDoc, msgTi
If noDoc = True Then
Exit Sub
End If
' ---------------- If document is empty, exit
Dim isDocEmpty As Boolean
isDocEmpty = False
EmptyDoc isDocEmpty, msgTi
If isDocEmpty = True Then
Exit Sub
End If
'-------------------- Provide an information box here if you want
' If you want to provide more information about this macro, create
' a message box as indicated below
' MsgBox Prompt:="Fill in other information about this macro.", _
' Title:=msgTi
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''
'------------------------------------ Start safety routines
' Begin safety routines, including original file backup.
' For convenience, comment out this block when testing;
' the end of the block is another line of apostrophes.
' Get file name and check if opened from disk
Dim strNameToSave As String
strNameToSave = ActiveDocument.FullName
' Test if Activedocument has been saved
If ActiveDocument.Path = "" Then
' If not previously saved
msgBox Prompt:="This macro only runs on a file that already exists on disk.", _
Title:=msgTi, Buttons:=vbExclamation
Exit Sub
End If
' Don't run if document has been changed since last saved
If ActiveDocument.Saved = False Then
msgBox Prompt:="This macro only runs on a file that has not been edited" + _
vbCrLf + "or changed after it was opened and before being saved." + vbCrLf + _
vbCrLf + "Please either close the file and reopen it, or save it" + _
vbCrLf + "(preferably under a different name, in order to protect" + _
vbCrLf + "the original version that was created in WordPerfect).", _
Title:=msgTi, Buttons:=vbExclamation
Exit Sub
End If
' Test whether we ran this macro earlier and created our backup file
' Our backup file has the original filename with the extension .wporiginal
Dim backupNametoSave As String
backupNametoSave = strNameToSave + ".wporiginal"
Dim testBkFile As String
testBkFile = Dir(backupNametoSave)
If testBkFile <> "" Then
msgBox Prompt:="This macro was apparently run on this file at an earlier time." + _
vbCrLf + vbCrLf + "A backup file already exists: " + Chr(34) + _
backupNametoSave + Chr(34) + vbCrLf + vbCrLf + _
"Rename or remove the backup if you want to run the macro on this document.", _
Title:=msgTi, Buttons:=vbExclamation
Exit Sub
End If
' Copy file on disk to backup filename
' Use different copy technique if user insists on running in Word 97
If aVer = 8 Then
' Word 97 only
WordBasic.CopyFile FileName:=strNameToSave, _
Directory:=backupNametoSave
Else
' Word 2000 and above
WordBasic.CopyFileA FileName:=strNameToSave, _
Directory:=backupNametoSave
End If
msgBox Prompt:="Your original file has been copied to this filename:" + _
vbCrLf + vbCrLf + backupNametoSave + vbCrLf + vbCrLf + _
"The backup file is in the same folder as the original.", _
Title:=msgTi, Buttons:=vbInformation
' End of safety routines that can be commented out for testing
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
' ----------------------------- Test for Microsoft's WP Converter Fonts
' Many systems do not have the Microsoft fonts that match the WP symbol
' fonts (Microsoft's "Multnational Ext", "Typographic Ext", etc.).
' If these fonts are not present, then don't search for them
Dim hasMsFnts As Boolean
hasMsFnts = False
Dim fntPth As String
Dim tstMsFnts As String
fntPth = Environ("windir") & "\fonts\multiext.ttf"
tstMsFnts = Dir(fntPth)
If tstMsFnts <> "" Then hasMsFnts = True
' ----------------------------- Get ready for memory errors
On Error GoTo CrashHandler
' ----------------------------- Check view type, turn off rewriting
Application.ScreenUpdating = False
' but Insert Symbol dialog appears anyway
Dim docVwType As Integer
docVwType = ActiveWindow.View.Type()
' Set to Normal view to avoid errors when closing panes
ActiveWindow.View.Type = 1
'-------------------------------- Actual macro actions begin here
Set oDcm = ActiveDocument ' set here to avoid blank doc problem
ResetSearch
MakeHFValid ' Fix the skipped blank Header/Footer problem
' ------------------------------------------------- toggle
For Each rDcm In oDcm.StoryRanges
If toggleOK = True Then TogglePars rDcm
While Not (rDcm.NextStoryRange Is Nothing)
Set rDcm = rDcm.NextStoryRange
If toggleOK = True Then TogglePars rDcm
Wend
Next rDcm
' ---------------------------------------- Replace the symbols
For Each rDcm In oDcm.StoryRanges
WPTypoSymSearch rDcm, iCount
oDcm.UndoClear
tCount = tCount + iCount
OtherWPFontsSearch rDcm, iCount
oDcm.UndoClear
tCount = tCount + iCount
If hasMsFnts = True Then
MsftWPConvFontsSearch rDcm, iCount
oDcm.UndoClear
tCount = tCount + iCount
End If
While Not (rDcm.NextStoryRange Is Nothing)
Set rDcm = rDcm.NextStoryRange
WPTypoSymSearch rDcm, iCount
oDcm.UndoClear
tCount = tCount + iCount
OtherWPFontsSearch rDcm, iCount
oDcm.UndoClear
tCount = tCount + iCount
If hasMsFnts = True Then
MsftWPConvFontsSearch rDcm, iCount
oDcm.UndoClear
tCount = tCount + iCount
End If
Wend
Next rDcm
' --------------------------------------------------- toggle
For Each rDcm In oDcm.StoryRanges
If toggleOK = True Then TogglePars rDcm
While Not (rDcm.NextStoryRange Is Nothing)
Set rDcm = rDcm.NextStoryRange
If toggleOK = True Then TogglePars rDcm
Wend
Next rDcm
' ----------------------------------------------------------
ClosePanes
' ----------------------------------------- Restore original view type
ActiveWindow.View.Type = docVwType
Application.ScreenUpdating = True
' ----------------------------------------- Return to start of document
Selection.HomeKey Unit:=wdStory
' -------------------- Different message if we did or did not make substitutions
If tCount = 0 Then
msgBox Prompt:="The macro found no symbols that it knows how to convert." + _
vbCrLf + vbCrLf + "Your document has not been modified." + vbCrLf + _
vbCrLf + "To find any remaining symbols, run the macro named" + _
vbCrLf + Chr(34) + "FindUnconvertedWPSymbols" + Chr(34) + ".", _
Title:=msgTi, Buttons:=vbInformation
Exit Sub
End If
Dim strCount As String
strCount = CStr(tCount)
msgBox Prompt:=strCount + " WordPerfect symbols were converted." + vbCrLf + _
vbCrLf + "If these results are not what you wanted," + _
vbCrLf + "close the document without saving it." + vbCrLf + _
vbCrLf + "To find any remaining symbols, run the" + _
vbCrLf + Chr(34) + "FindUnconvertedWPSymbols" + Chr(34) + " macro.", _
Title:=msgTi, Buttons:=vbInformation
Exit Sub
SomethingWrongHandler:
msgBox Prompt:="I cannot guess what has gone wrong here, because this is" + vbCrLf + _
"a part of the macro code that should run without problems." + vbCrLf + _
vbCrLf + "You probably should close your document without saving," + vbCrLf + _
"although I doubt any harm has been done to the file." + vbCrLf + _
vbCrLf + "Please tell me what happened when the problem occurred." + _
vbCrLf + "My address can be found inside the macro code.", _
Title:=msgTi, Buttons:=vbCritical
Exit Sub
CrashHandler:
msgBox Prompt:="An error has occurred, probably in Windows' memory handling." + vbCrLf + _
vbCrLf + "Your document is in an unknown state. Close the document" + _
vbCrLf + "without saving it, and use the backed-up original version." + vbCrLf + _
vbCrLf + "This kind of error tends to leave Windows unstable, and you may" + _
vbCrLf + "need to restart Windows before this macro will run successfully.", _
Title:=msgTi, Buttons:=vbCritical
End Sub
Private Sub WPTypoSymSearch(rDcm As Range, iCount As Long)
Dim oDlg As Dialog ' object dialog
Dim oChr As Object ' object character
Dim sFnt As String ' font name
Dim iFnt As Long ' character number
Dim sChr As String ' replacement character
Dim iLng As Integer ' application language
Dim oDat As DataObject ' object for Clipboard access
iCount = 0
Set oDat = New DataObject
iFnt = 9999999 ' to avoid entering wrong character
iLng = Application.Language
' ------------------------- Get string for SendKeys
Dim skStr As String
StringSendKeys skStr
For Each oChr In rDcm.Characters
If Asc(oChr) = 40 Then
oChr.Select
' iFnt = 9999999
Set oDlg = Dialogs(wdDialogInsertSymbol)
SendKeys skStr
oDlg.Display
iFnt = oDlg.charnum
oDat.GetFromClipboard
sFnt = oDat.GetText
' changes for WP TypographicSymbols font only
' fill in or uncomment more characters later
If sFnt = "WP TypographicSymbols" Then
Select Case iFnt
Case &H21: sChr = ChrW(&H25CF) ' filled round bullet (medium)
Case &H22: sChr = ChrW(&H25CB) ' circle (medium)
Case &H23: sChr = ChrW(&H25A0) ' filled square bullet (medium)
Case &H24: sChr = ChrW(&H2022) ' filled round bullet (small)
' Case &H25: sChr = ChrW(&H2A) ' star
Case &H26: sChr = ChrW(&HB6) ' Paragraph sign
Case &H27: sChr = ChrW(&HA7) ' Section sign
Case &H28: sChr = ChrW(&HA1) ' Spanish exclamation mark
Case &H29: sChr = ChrW(&HBF) ' Spanish question mark
Case &H2A: sChr = ChrW(&HAB) ' left pointing guillemet
Case &H2B: sChr = ChrW(&HBB) ' right pointing guillemet
' Case &H2C6: sChr = ChrW(&H20AA) ' New Shequel sign (Israel)
Case &H2C: sChr = ChrW(&HA3) ' Pound sign
Case &H2D: sChr = ChrW(&HA5) ' Yen sign
Case &H2E: sChr = ChrW(&H20A7) ' Peseta sign
Case &H2F: sChr = ChrW(&H192) ' Florin sign (Dutch)
Case &H30: sChr = ChrW(&HAA) ' feminine ordinal indicator (Spanish)
Case &H31: sChr = ChrW(&HBA) ' masculine ordinal indicator (Spanish)
Case &H32: sChr = ChrW(&HBD) ' 1/2
Case &H33: sChr = ChrW(&HBC) ' 1/4
Case &H34: sChr = ChrW(&HA2) ' Cent sign
' Case &H35: sChr = ChrW(&HB2) ' superscript 2
' Case &H36: sChr = ChrW(&H207F) ' superscript n
Case &H37: sChr = ChrW(&HAE) ' Registered sign
Case &H38: sChr = ChrW(&HA9) ' Copyright sign
Case &H39: sChr = ChrW(&HA4) ' Currency sign
Case &H3A: sChr = ChrW(&HBE) ' 3/4
' Case &H3B: sChr = ChrW(&HB3) ' superscript 3
Case &H3C: sChr = ChrW(&H201B) ' single opening quote
Case &H3D: sChr = ChrW(&H2019) ' single high comma quote
Case &H3E: sChr = ChrW(&H2018) ' single high turned comma quote
Case &H3F: sChr = ChrW(&H201C) ' double high turned comma quote
' ??? above is same as &H41 below, because unturned quote is not available
Case &H40: sChr = ChrW(&H201D) ' double high comma quote
Case &H41: sChr = ChrW(&H201C) ' double high turned comma quote
Case &H42: sChr = ChrW(&H2013) ' En dash
Case &H43: sChr = ChrW(&H2014) ' Em dash
Case &H44: sChr = ChrW(&H2039) ' Left pointing single guillemet
Case &H45: sChr = ChrW(&H203A) ' Right pointing single guillemet
Case &H48: sChr = ChrW(&H2020) ' Dagger
Case &H49: sChr = ChrW(&H2021) ' Double Dagger
Case &H4A: sChr = ChrW(&H2122) ' Trademark sign
Case &H4D: sChr = ChrW(&H25CF) ' filled round bullet (large)
Case &H4E: sChr = ChrW(&HB0) ' circle (small)
Case &H4F: sChr = ChrW(&H2580) ' Large filled square bullet (large)
Case &H50: sChr = ChrW(&H25A0) ' filled square bullet (small)
Case &H51: sChr = ChrW(&H25A1) ' empty square bullet (medium)
Case &H52: sChr = ChrW(&H25A1) ' empty square bullet (small)
Case &H53: sChr = ChrW(&H2013) ' En dash
' Case &H57: sChr = ChrW(&HFB01) ' Ligature fi
' Case &H58: sChr = ChrW(&HFB02) ' Ligature fl
' Case &H59: sChr = ChrW(&H2026) ' Ellipsis = ...
' Case &H5A: sChr = ChrW(&H24) ' Dollar sign
Case &H5B: sChr = ChrW(&H20A3) ' Franc sign
Case &H5E: sChr = ChrW(&H20A4) ' Lira sign
Case &H5F: sChr = ChrW(&H201A) ' low single comma quote
Case &H60: sChr = ChrW(&H201E) ' low double comma quote
' Case &H61: sChr = ChrW(&H2153) ' 1/3
' Case &H62: sChr = ChrW(&H2154) ' 2/3
' Case &H63: sChr = ChrW(&H215B) ' 1/8
' Case &H64: sChr = ChrW(&H215C) ' 3/8
' Case &H65: sChr = ChrW(&H215D) ' 5/8
' Case &H66: sChr = ChrW(&H215E) ' 7/8
Case &H69: sChr = ChrW(&H20AC) ' Euro sign
' Case &H6A: sChr = ChrW(&H2105) ' Care of
' Case &H6C: sChr = ChrW(&H2030) ' Per thousand
' Case &H6D: sChr = ChrW(&H2116) ' Numero sign
' Case &H6E: sChr = ChrW(&H2013) ' En dash
' Case &H6F: sChr = ChrW(&HB9) ' superscript 1
Case Else
iFnt = 9999999 ' nothing found that matches our list
End Select
If iFnt <> 9999999 Then
Selection.TypeText Text:=sChr
iCount = iCount + 1
End If
End If
End If
Next oChr
End Sub
Private Sub OtherWPFontsSearch(rDcm As Range, iCount As Long)
' This whole section added as workaround for failure to work with MultiExt
Dim oDlg As Dialog ' object dialog
Dim oChr As Object ' object character
Dim sFnt As String ' font name
Dim iFnt As Long ' character number
Dim sChr As String ' replacement character
Dim iLng As Integer ' application language
Dim oDat As DataObject ' object for Clipboard access
iCount = 0
Set oDat = New DataObject
iFnt = 9999999
iLng = Application.Language
' ------------------------- Get string for SendKeys
Dim skStr As String
StringSendKeys skStr
For Each oChr In rDcm.Characters
If Asc(oChr) = 40 Then
oChr.Select
' iFnt = 9999999
Set oDlg = Dialogs(wdDialogInsertSymbol)
SendKeys skStr
oDlg.Display
iFnt = Dialogs(wdDialogInsertSymbol).charnum 'oDlg fails here
oDat.GetFromClipboard
sFnt = oDat.GetText
' insert changes for other WP MathA characters here
If sFnt = "WP MathA" Then
Select Case iFnt
Case -4063: sChr = ChrW(&H2D) 'minus
Case -4062: sChr = ChrW(&HB1) 'plus or minus
Case -4061: sChr = ChrW(&H2264) 'less than or equal to
Case -4060: sChr = ChrW(&H2265) 'more than or equal to
Case -4029: sChr = ChrW(&H2022) 'bullet
Case Else
iFnt = 9999999
End Select
If iFnt <> 9999999 Then
Selection.TypeText Text:=sChr
iCount = iCount + 1
End If
End If
' insert changes for other WP MultinationalA Roman characters here
If sFnt = "WP MultinationalA Roman" Then
Select Case iFnt
Case -3924: sChr = ChrW(&H132) ' IJ digraph
Case -3963: sChr = ChrW(&H10D) ' c caron (hacek)
Case -3965: sChr = ChrW(&H107) ' c acute
Case -3855: sChr = ChrW(&H17E) ' z caron (hacek)
Case -3856: sChr = ChrW(&H17D) ' Z caron (hacek)
Case -3964: sChr = ChrW(&H10D) ' C caron (hacek)
Case -3966: sChr = ChrW(&H106) ' C acute
Case -3984: sChr = ChrW(&H111) ' d cross bar
Case -3899: sChr = ChrW(&H151) ' o double acute
Case -3853: sChr = ChrW(&H17C) ' z dot above
Case -3887: sChr = ChrW(&H15B) ' s acute
Case -3909: sChr = ChrW(&H142) ' l stroke
Case -3915: sChr = ChrW(&H13E) ' l apostrophe beside
Case -3949: sChr = ChrW(&H119) ' e ogonek
Case -3967: sChr = ChrW(&H105) ' a ogonek
Case -3891: sChr = ChrW(&H159) ' r caron (hacek)
Case -3955: sChr = ChrW(&H11B) ' e caron (hacek)
Case -3957: sChr = ChrW(&H10F) ' d apostrophe beside
Case Else
iFnt = 9999999
End Select
If iFnt <> 9999999 Then
Selection.TypeText Text:=sChr
iCount = iCount + 1
End If
End If
' insert changes for other WP IconicSymbosA characters here
If sFnt = "WP IconicSymbolsA" Then
Select Case iFnt
Case -4059: sChr = ChrW(&H2642) ' male sign
Case -4058: sChr = ChrW(&H2640) ' female sign
Case -4036: sChr = ChrW(&H266F) ' sharp
Case -4035: sChr = ChrW(&H266D) ' flat
Case -4034: sChr = ChrW(&H266E) ' natural ' ?NOT IN WORD XP???
Case -3894: sChr = ChrW(&H2663) ' club suit
Case -3893: sChr = ChrW(&H2666) ' diamond suit
Case -3892: sChr = ChrW(&H2665) ' heart suit
Case -3891: sChr = ChrW(&H2660) ' spade suit
Case Else
iFnt = 9999999
End Select
If iFnt <> 9999999 Then
Selection.TypeText Text:=sChr
iCount = iCount + 1
End If
End If
' insert other "WP" fonts here; use this procedure ONLY for WP fonts
End If
Next oChr
End Sub
Private Sub MsftWPConvFontsSearch(rDcm As Range, iCount As Long)
' Use this procedure ONLY for the six fonts installed by the Microsoft
' Converter Pack - Multnational Ext, Typographic Ext, Greek Symbols,
' Math Ext, etc. These are not on all systems, and the macro runs this
' procedure only if they are present. Use the previous procedure
' for fonts with "WP" in their names ("WP Multinational Ext", etc.)
Dim oDlg As Dialog ' object dialog
Dim oChr As Object ' object character
Dim sFnt As String ' font name
Dim iFnt As Long ' character number
Dim sChr As String ' replacement character
Dim iLng As Integer ' application language
Dim oDat As DataObject ' object for Clipboard access
iCount = 0
Set oDat = New DataObject
iFnt = 9999999
iLng = Application.Language
' ------------------------- Get string for SendKeys
Dim skStr As String
StringSendKeys skStr
For Each oChr In rDcm.Characters
If Asc(oChr) = 40 Then
oChr.Select
' iFnt = 9999999
Set oDlg = Dialogs(wdDialogInsertSymbol)
SendKeys skStr
oDlg.Display
iFnt = Dialogs(wdDialogInsertSymbol).charnum 'oDlg fails here
oDat.GetFromClipboard
sFnt = oDat.GetText
' changes for Multinational Ext font only
' fill in or uncomment more characters later
If sFnt = "Multinational Ext" Then
Select Case iFnt
Case -3951: sChr = Chr$(156) 'oe digraph
Case -3956: sChr = Chr$(140) 'OE digraph
Case -3986: sChr = ChrW(&H133) 'ij
Case -3987: sChr = ChrW(&H132) 'IJ
Case -4056: sChr = ChrW(&HA8) ' diaresis
Case Else
iFnt = 9999999
End Select
If iFnt <> 9999999 Then
Selection.TypeText Text:=sChr
iCount = iCount + 1
End If
End If
' insert changes for other fonts and Typographic ext here
If sFnt = "Typographic Ext" Then
Select Case iFnt
Case -4052: sChr = ChrW(&H2014) 'Em dash
Case -4053: sChr = ChrW(&H2013) 'En dash
Case Else
iFnt = 9999999
End Select
If iFnt <> 9999999 Then
Selection.TypeText Text:=sChr
iCount = iCount + 1
End If
End If
' insert other fonts here
End If
Next oChr
End Sub
Private Sub TogglePars(rLoc As Range)
Dim rDpl As Range
Set rDpl = rLoc.Duplicate ' that's it
With rDpl.Find
.Text = ChrW(&H28)
If .Execute Then
.Replacement.Text = Chr(5)
.Execute Replace:=wdReplaceAll
Exit Sub
Else
.Text = Chr(5)
If .Execute Then
.Replacement.Text = ChrW(&H28)
.Execute Replace:=wdReplaceAll
End If
End If
End With
End Sub
Private Sub ResetSearch()
With Selection.Find
.ClearFormatting
.Replacement.ClearFormatting
.Text = ""
.Replacement.Text = ""
.Forward = True
.Wrap = wdFindContinue
.Format = False
.MatchCase = False
.MatchWholeWord = False
.MatchWildcards = False
.MatchSoundsLike = False
.MatchAllWordForms = False
.Execute
End With
End Sub
Private Sub ClosePanes()
' if selection in a pane outside main document window, close it
If Selection.Information(wdInHeaderFooter) = True Then
ActiveWindow.View.Type = wdNormalView
End If
If Selection.Information(wdInHeaderFooter) = True Then
ActiveWindow.ActivePane.Close
End If
If Selection.Information(wdInFootnoteEndnotePane) = True Then
ActiveWindow.ActivePane.Close
End If
If Selection.Information(wdInCommentPane) = True Then
ActiveWindow.ActivePane.Close
End If
End Sub
Private Sub MakeHFValid()
' Fix empty header and footer problem, by Peter Hewett at
' http://word.mvps.org/FAQs/Customization/ReplaceAnywhere.htm
Dim lngJunk As Long
' It does not matter whether we access the Headers or Footers property.
' The critical part is accessing the stories range object
lngJunk = ActiveDocument.Sections(1).Headers(1).Range.StoryType
End Sub
Private Sub WrongLanguageVersion(msgTi As String)
Dim sLng As String ' string version of language code number
sLng = CStr(Application.Language)
msgBox Prompt:="This macro must to be edited for your language version of Word." + _
vbCrLf + vbCrLf + "Instructions for editing may be found in the macro code." + _
vbCrLf + vbCrLf + "Write down your language code number: " + sLng, _
Title:=msgTi, Buttons:=vbExclamation
End Sub
Public Sub FindUnconvertedWPSymbols()
' ----------------------- Language version test required for SendKeys
' If you received an error message, press Ctrl-Home to find the instructions
' near the top of this window.
Dim skStr As String
StringSendKeys skStr
Dim msgTi As String
msgTi = "Find Unconverted WP Symbols"
'msgBox (skStr)
If skStr = "NoMatch" Then
WrongLanguageVersion (msgTi)
Exit Sub
End If
' ----------------- If no documents are open, exit
Dim noDoc As Boolean
noDoc = False
NoOpenDoc noDoc, msgTi
If noDoc = True Then
Exit Sub
End If
Dim docVwType As Integer
docVwType = ActiveWindow.View.Type()
' Set to Normal view to avoid errors when closing panes
ActiveWindow.View.Type = 1
ClosePanes
On Error GoTo CrashFindHandler
Dim rDcm As Range ' document range
Dim oDcm As Document ' object document
Set oDcm = ActiveDocument ' for brevitiy only
Dim oDlg As Dialog ' object dialog
Dim oChr As Object ' object character
Dim sFnt As String ' font name
Dim iFnt As Long ' character number
Dim sChr As String ' replacement character
'Dim iLng As Integer ' application language
Dim oDat As DataObject ' object for Clipboard access
Dim uCount As Long
uCount = 0
Set oDlg = Dialogs(wdDialogInsertSymbol)
Set oDat = New DataObject
iFnt = 9999999 ' to avoid entering wrong character
For Each rDcm In oDcm.StoryRanges
oDcm.UndoClear
For Each oChr In rDcm.Characters
If Asc(oChr) = 40 Then
oChr.Select
SendKeys skStr
oDlg.Display
iFnt = Dialogs(wdDialogInsertSymbol).charnum
oDat.GetFromClipboard
sFnt = oDat.GetText
If sFnt <> "(normal text)" Then
Debug.Print sFnt, iFnt
uCount = uCount + 1
Dim msgPr As String
'msgTi As String
Dim msgBt As Integer, msgRs As Integer
msgPr = sFnt & " " & iFnt & _
vbCr & vbCr & "Choose Yes to continue."
msgBt = vbYesNo + vbDefaultButton1
msgTi = "Font and Symbol"
msgRs = msgBox(msgPr, msgBt, msgTi)
Select Case msgRs
Case vbYes
' nothing
Case vbNo
GoTo wantsOut
Case vbCancel
Exit Sub
End Select
End If
End If
Next oChr
While Not (rDcm.NextStoryRange Is Nothing)
Set rDcm = rDcm.NextStoryRange
For Each oChr In rDcm.Characters
If Asc(oChr) = 40 Then
oChr.Select
Set oDlg = Dialogs(wdDialogInsertSymbol)
SendKeys skStr
oDlg.Display
iFnt = Dialogs(wdDialogInsertSymbol).charnum
oDat.GetFromClipboard
sFnt = oDat.GetText
If sFnt <> "(normal text)" Then
Debug.Print sFnt, iFnt
uCount = uCount + 1
msgRs = msgBox(msgPr, msgBt, msgTi)
Select Case msgRs
Case vbYes
' nothing
Case vbNo
GoTo wantsOut
Case vbCancel
Exit Sub
End Select
End If
End If
Next oChr
Wend
Next rDcm
oDcm.UndoClear
ClosePanes
Application.ActiveWindow.View.Type = docVwType
Selection.HomeKey Unit:=wdStory
If uCount = 0 Then
msgBox Prompt:="No unconverted symbols were found.", _
Title:="Find Unconverted WP Symbols", _
Buttons:=vbInformation
Exit Sub
End If
wantsOut: ' skip to here if user says No at any point
Dim uString As String
uString = CStr(uCount)
msgBox Prompt:=uString + " unconverted symbols found." + vbCrLf + _
vbCrLf + "For a listing, press OK, then Alt-F11, then Ctrl-G.", _
Title:="Find Unconverted WP Symbols", _
Buttons:=vbInformation
Exit Sub
CrashFindHandler:
msgBox Prompt:="An error has occurred, probably in Windows' memory handling." + vbCrLf + _
vbCrLf + "This kind of error tends to leave Windows unstable, and you may" + _
vbCrLf + "need to restart Windows before this macro will run successfully.", _
Title:="WP Symbol Converter", _
Buttons:=vbCritical
End Sub
Sub SingleCharacterFontAndSymbol()
' ------------------------ Get language string for SendKeys
' If you received an error message, press Ctrl-Home to find the instructions
' near the top of this window.
Dim msgTi As String ' message box title
Dim skStr As String
StringSendKeys skStr
'msgBox (skStr)
If skStr = "NoMatch" Then
WrongLanguageVersion msgTi
Exit Sub
End If
' ----------------- If no documents are open, exit
Dim noDoc As Boolean
noDoc = False
NoOpenDoc noDoc, msgTi
If noDoc = True Then
Exit Sub
End If
' ---------------- If document is empty, exit
Dim isDocEmpty As Boolean
Dim eDoc As Boolean
eDoc = False
EmptyDoc isDocEmpty, msgTi
If isDocEmpty = True Then
Exit Sub
End If
' ---------------------- Select only one character, please
If Len(Selection.Text) <> 1 Then
msgBox Prompt:="Please select only one character.", _
Title:="Font and Symbol", _
Buttons:=vbExclamation
ActiveWindow.Selection.Collapse Direction:=wdCollapseStart
Exit Sub
End If
' --------------------- If selection is insertion point, extend one character
If Selection.Start = Selection.End Then
Selection.MoveRight Unit:=wdCharacter, Count:=1, Extend:=wdExtend
End If
Dim dlg As Object
Set dlg = Dialogs(wdDialogInsertSymbol)
Dim sFnt As String ' font name
Dim iFnt As Long ' character number
Dim oDat As DataObject
Set oDat = New DataObject
Dim msgPr As String
'Dim msgTi As String
msgTi = "Font and Symbol"
SendKeys skStr
dlg.Display
iFnt = Dialogs(wdDialogInsertSymbol).charnum
If Abs(iFnt) < 32 Then
Dim iCode As String
iCode = CStr(iFnt)
Select Case iFnt
Case 9: msgPr = "Symbol 9 is the Tab character."
Case 11: msgPr = "Symbol 11 is a line break."
Case 12: msgPr = "Symbol 12 is a page break."
Case 13: msgPr = "Symbol 13 represents a carriage return."
Case 14: msgPr = "Symbol 14 is a column break."
Case 30: msgPr = "Symbol 30 is a nonbreaking hyphen."
Case 31: msgPr = "Symbol 31 is a optional hyphen."
Case Else
msgPr = "Symbol number " + iCode + " is one of Word's" _
+ " internal codes or an unprintable character."
End Select
msgBox Prompt:=msgPr, Title:=msgTi
Exit Sub
End If
oDat.GetFromClipboard
sFnt = oDat.GetText
msgPr = sFnt & " " & iFnt
msgBox Prompt:=msgPr, Title:=msgTi
'Debug.Print sFnt, iFnt
ActiveWindow.Selection.Collapse Direction:=wdCollapseEnd
End Sub
Private Function EmptyDoc(isDocEmpty As Boolean, msgTi As String)
Dim rDcm As Range ' document range
Dim oDcm As Document ' object document
Set oDcm = ActiveDocument ' for brevity only
isDocEmpty = True
For Each rDcm In oDcm.StoryRanges
' Check for text. If length of current story is more than 1
' then text or multiple blank lines exist
If Len(rDcm.Text) > 1 Then
isDocEmpty = False
End If
' Check for Objects. If there are no objects within
' the current story range, an error occurs.
On Error Resume Next
If rDcm.ShapeRange.Count > 0 Then
If Err = 0 Then
isDocEmpty = False
Else
On Error GoTo 0
End If
End If
If isDocEmpty = True Then
msgBox Prompt:="This macro will not run on a blank document.", _
Title:="WP Symbol Converter", _
Buttons:=vbExclamation
Exit Function
End If
Next
'msgBox (isDocEmpty)
End Function
Private Function NoOpenDoc(noDoc As Boolean, msgTi As String)
noDoc = False
If Documents.Count = 0 Then
noDoc = True
msgBox Prompt:="This macro will only run if a document is open.", _
Title:=msgTi, Buttons:=vbExclamation
Exit Function
End If
End Function
Private Sub StringSendKeys(skStr As String)
Dim iLng As Integer ' application language
iLng = Application.Language
Select Case iLng
'Case 1029: skStr = "%-^-{ESC}{ESC}" ' Czech
'Case 1030: skStr = "%-^-{ESC}{ESC}" ' Danish
Case 1031: skStr = "%s^c{ESC}{ESC}" ' German
Case 1033: skStr = "%f^c{ESC}{ESC}" ' English
'Case 1035: skStr = "%-^-{ESC}{ESC}" ' Finnish
Case 1036: skStr = "%p^c{ESC}{ESC}" ' French
'Case 1038: skStr = "%-^-{ESC}{ESC}" ' Hungarian
'Case 1040: skStr = "%-^-{ESC}{ESC}" ' Italian
Case 1043: skStr = "%l^c{ESC}{ESC}" ' Dutch
'Case 1044: skStr = "%-^-{ESC}{ESC}" ' Norwegian
'Case 1045: skStr = "%-^-{ESC}{ESC}" ' Polish
'Case 1053: skStr = "%-^-{ESC}{ESC}" ' Swedish
'Case 1055: skStr = "%-^-{ESC}{ESC}" ' Turkish
Case 2070: skStr = "%f^c{ESC}{ESC}" ' Portuguese
'Case 3082: skStr = "%-^-{ESC}{ESC}" ' Spanish
Case Else: skStr = "NoMatch" ' string to compare
End Select
'msgBox (skStr)
End Sub