Attribute VB_Name = "WPSymbolConverter" Option Explicit #If VBA7 Then Private Declare PtrSafe Sub Sleep Lib "kernel32" (ByVal ms As LongPtr) #Else Private Declare Sub Sleep Lib "kernel32" (ByVal ms as Long) #End If Sub WPSymbolConverter() ' version 1.41 3 August 2023 - adds support for 64bit Word ' If these macros crash with an error message, scroll down one or two ' screens and read the section headed "If these macros crash with an ' error message" ' 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, ' Word 2003, or Word 2007 in which typographic and other characters ' are displayed in the WP TypographicSymbols font 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: ' em36#at#columbia#dot#edu (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 iSlpInt As Integer ' sleep interval Dim msgTi As String ' message box title Dim iWarnOff As Boolean ' When 1, turn off warning messages when debugging Dim tLimit As Long ' number of substitutions to perform on each run Dim iSafeMode As Boolean ' When 1, perform substiutions in batches tCount = 0 iCount = 0 iWarnOff = True iSafeMode = False msgTi = "WP Symbol Converter" '----------------- If these macros crash with an error message ----------------- ' If these macros fail with an error message saying that an error has occurrred, ' probably in Word's memory management, then one of two solutions may help: ' ---------------- 1. Limit the number of substitutions per run ---------------- ' To prevent crashes, the macro can perform a limited number of substitutions, ' then stop, so you can run it again. Set iSafeMode to True to enable this feature. ' You can increase the number of substitutions in the tLimit variable below ' until the macro starts to crash when run, then lower the number. iSafeMode = False tLimit = 50 '----------------- 2. Change the pause interval between substitutions ----------- ' A simpler method that sometimes works is to change the "sleep" interval between ' substitutions. To make this change, change the number in the following line ' line to 150; if the macro continues to crash, raise the number to 175, and, if ' necessary, continue to increase the number until the macro runs successfully iSlpInt = 125 ' Very important: Search for other strings in this "project" that read "iSlpInt = " and ' change the numbers there also '----------------- How to make this macro faster - with warnings! -------------- ' The next line causes this macro to run more slowly than it can, but the line is ' present in order to protect the inverted Spanish exclamation mark (¡) from being ' converted by the macro into the "(" character. toggleOK = False ' 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. ' When the block is commented out, the iWarnOff variable ' continues to = True and some further messages are not displayed iWarnOff = False ' 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 iSafeMode = False Then 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 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 If iSafeMode = False Then 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 End If ' Copy file on disk to backup filename If iSafeMode = False Then ' 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 If ' End of safety routines that can be commented out for testing ''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''' '--------------------- Display Symbol dialogue once to avoid errors later If iWarnOff = False Then MsgBox Prompt:="The Symbol dialog will now open." + _ vbCrLf + vbCrLf + _ "After it opens, press the Enter key only ONE TIME to close it." + _ vbCrLf + vbCrLf + _ "The Symbol dialog may appear again. Do NOT press Enter again " + _ "unless there is no activity on screen for more than one minute." + _ vbCrLf + vbCrLf + _ "The macro may take a very long time to run." + _ "To stop it, press Ctrl+Break and click on End.", _ Title:=msgTi, Buttons:=vbInformation End If Dim oDlg As Dialog ' object dialog Set oDlg = Dialogs(wdDialogInsertSymbol) oDlg.Display '' Explain how to interrupt this macro 'If iWarnOff = False Then ' MsgBox Prompt:="This macro may take a very long to run." + _ ' vbCrLf + vbCrLf + _ ' "To stop it, press Ctrl+Break and click on End.", _ ' Title:=msgTi, Buttons:=vbInformation 'End If ' ----------------------------- 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, tCount, tLimit, iSafeMode oDcm.UndoClear tCount = tCount + iCount '''' added for Safe version If iSafeMode = True Then If tCount >= tLimit Then LimitOut tCount, docVwType Exit Sub End If End If '''' Sleep iSlpInt OtherWPFontsSearch rDcm, iCount, tCount, tLimit, iSafeMode oDcm.UndoClear tCount = tCount + iCount If hasMsFnts = True Then Sleep iSlpInt MsftWPConvFontsSearch rDcm, iCount, tCount, tLimit, iSafeMode oDcm.UndoClear tCount = tCount + iCount '''' added for Safe version If iSafeMode = True Then If tCount >= tLimit Then LimitOut tCount, docVwType Exit Sub End If End If '''' End If While Not (rDcm.NextStoryRange Is Nothing) Set rDcm = rDcm.NextStoryRange Sleep iSlpInt WPTypoSymSearch rDcm, iCount, tCount, tLimit, iSafeMode oDcm.UndoClear tCount = tCount + iCount '''' added for Safe version If iSafeMode = True Then If tCount >= tLimit Then LimitOut tCount, docVwType Exit Sub End If End If '''' Sleep iSlpInt OtherWPFontsSearch rDcm, iCount, tCount, tLimit, iSafeMode oDcm.UndoClear tCount = tCount + iCount '''' added for Safe version If iSafeMode = True Then If tCount >= tLimit Then LimitOut tCount, docVwType Exit Sub End If End If '''' If hasMsFnts = True Then Sleep iSlpInt MsftWPConvFontsSearch rDcm, iCount, tCount, tLimit, iSafeMode oDcm.UndoClear tCount = tCount + iCount '''' added for Safe version If iSafeMode = True Then If tCount >= tLimit Then LimitOut tCount, docVwType Exit Sub End If End If '''' 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, tCount As Long, tLimit As Long, iSafeMode As Boolean) 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 iSlpInt As Integer ' sleep interval 'Dim mCnt As Integer ' modulo iCount and round number iCount = 0 Set oDat = New DataObject iFnt = 9999999 ' to avoid entering wrong character iSlpInt = 125 iLng = Application.Language ' ------------------------- Get string for SendKeys Dim skStr As String StringSendKeys skStr For Each oChr In rDcm.Characters 'If iCount <> 0 Then ' mCnt = iCount Mod 50 ' If mCnt = 0 Then Sleep 50 'End If '''' added for Safe version If iSafeMode = True Then If (tCount + iCount) >= tLimit Then Exit Sub End If End If '''' If Asc(oChr) = 40 Then oChr.Select ' iFnt = 9999999 Set oDlg = Dialogs(wdDialogInsertSymbol) Sleep iSlpInt If iCount = 0 Then Sleep 500 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, tCount As Long, tLimit As Long, iSafeMode As Boolean) ' 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 Dim iSlpInt As Integer ' sleep interval iCount = 0 Set oDat = New DataObject iFnt = 9999999 iSlpInt = 125 iLng = Application.Language ' ------------------------- Get string for SendKeys Dim skStr As String StringSendKeys skStr Sleep iSlpInt For Each oChr In rDcm.Characters '''' added for Safe version If iSafeMode = True Then If (tCount + iCount) >= tLimit Then Exit Sub End If End If '''' If Asc(oChr) = 40 Then oChr.Select ' iFnt = 9999999 Set oDlg = Dialogs(wdDialogInsertSymbol) Sleep iSlpInt If iCount = 0 Then Sleep 500 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 -3907: sChr = ChrW(&H144) ' n acute 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, tCount As Long, tLimit As Long, iSafeMode As Boolean) ' 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 '''' added for Safe version If iSafeMode = True Then If (tCount + iCount) >= tLimit Then Exit Sub End If End If '''' If Asc(oChr) = 40 Then oChr.Select ' iFnt = 9999999 Set oDlg = Dialogs(wdDialogInsertSymbol) Sleep iSlpInt If iCount = 0 Then Sleep 500 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 LimitOut(tCount As Long, docVwType As Integer) ClosePanes ActiveWindow.View.Type = docVwType Application.ScreenUpdating = True Dim strCount As String strCount = CStr(tCount) MsgBox Prompt:="The macro has made " + strCount + " substitutions." + _ vbCrLf + vbCrLf + "It has not converted all the symbols in the file." + _ vbCrLf + vbCrLf + "You must run the macro again to make further substitutions!", _ Title:="Follow these instructions", Buttons:=vbExclamation 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 iSlpInt As Integer ' sleep interval Dim uCount As Long uCount = 0 Set oDlg = Dialogs(wdDialogInsertSymbol) Set oDat = New DataObject iFnt = 9999999 ' to avoid entering wrong character iSlpInt = 125 '--------------------- Display Symbol dialogue once to avoid errors later 'If iWarnOff = False Then MsgBox Prompt:="The Symbol dialog will now open." + _ vbCrLf + vbCrLf + _ "After it opens, press the Enter key only ONE TIME to close it." + _ vbCrLf + vbCrLf + _ "The Symbol dialog may appear again. Do NOT press Enter again " + _ "unless there is no activity on screen for more than one minute." + _ vbCrLf + vbCrLf + _ "The macro may take a very long time to run." + _ "To stop it, press Ctrl+Break and click on End.", _ Title:=msgTi, Buttons:=vbInformation 'End If oDlg.Display For Each rDcm In oDcm.StoryRanges oDcm.UndoClear Sleep iSlpInt For Each oChr In rDcm.Characters If Asc(oChr) = 40 Then oChr.Select SendKeys skStr oDlg.Display Sleep iSlpInt iFnt = Dialogs(wdDialogInsertSymbol).charnum oDat.GetFromClipboard sFnt = oDat.GetText If sFnt <> "(normal text)" Then 'If InStr(1, sFnt, "(") <> 1 Then 'possible alternative for non-English Word Debug.Print sFnt, iFnt uCount = uCount + 1 Dim msgPr As String 'Dim 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 Sleep iSlpInt For Each oChr In rDcm.Characters If Asc(oChr) = 40 Then oChr.Select Set oDlg = Dialogs(wdDialogInsertSymbol) Sleep iSlpInt SendKeys skStr oDlg.Display iFnt = Dialogs(wdDialogInsertSymbol).charnum oDat.GetFromClipboard sFnt = oDat.GetText If sFnt <> "(normal text)" Then 'If InStr(1, sFnt, "(") <> 1 Then ' Possible alternative for non-English Word 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