Attribute VB_Name = "Unicode_Analyse" ' Modul "Unicode_Analyse" ' Dipl.-Ing. H. Chris Gast, Berlin (c) 2010, Stand 9. April 2012. ' http://www.siebener-kurier.de/chris-aufsaetze/Word-Erweiterung-Unicode-Makros.pdf ' http://www.siebener-kurier.de/chris-aufsaetze/Unicode_Analyse.txt Option Explicit ' erzeugt Fehlermeldung, wenn beim Programmieren Dim-Befehle vergessen wurden. ' ' Die folgende Funktions-Deklaration muss vor dem ersten Makro des Moduls eingefügt werden: Private Declare Function MessageBoxW Lib "user32.dll" (ByVal hWnd As Long, _ ByVal lpText As Long, ByVal lpCaption As Long, ByVal uType As Long) As Long ' ******************************************************************************** Private Function EnglischName(z1 As String) As String ' Makro erstellt von Dipl.-Ing. Hanna-Chris Gast am 20. Juli 2010, Stand 3. November 2010. ' Diese Funktion sucht aus der bereits downgeloadeten und geöffneten Unicode-Liste ' http://unicode.org/Public/UNIDATA/UnicodeData.txt den englischen ' Zeichennamen heraus. Dim rng1, Rng2, y1 ' ActiveDocument.Range(0, 0).Select ' Selection.Find.ClearFormatting With Selection.Find .Text = "^p" & z1 & ";" .Replacement.Text = "" .Forward = True .Wrap = wdFindContinue .Format = False .MatchCase = False .MatchWholeWord = False .MatchWildcards = False .MatchSoundsLike = False .MatchAllWordForms = False End With Selection.Find.Execute ' If Selection.Find.Found = True Then ' Zeile ist gefunden, jetzt Resultat einlesen: Selection.Collapse Direction:=wdCollapseEnd Set rng1 = Selection.Range ' bis zum nächsten Semikolon suchen Selection.Find.ClearFormatting With Selection.Find .Text = ";" .Replacement.Text = "" .Forward = True .Wrap = wdFindContinue .Format = False .MatchCase = False .MatchWholeWord = False .MatchWildcards = False .MatchSoundsLike = False .MatchAllWordForms = False End With Selection.Find.Execute Set Rng2 = Selection.Range Rng2.SetRange Start:=rng1.Start, End:=Rng2.End - 1 Rng2.Select ' Gefundene Erklärung einlesen: EnglischName = "der" & Chr(160) & "genormte" & Chr(160) & "englische" _ & Chr(160) & "Zeichenname" & Chr(160) & "ist:" & Chr(160) & Selection Else y1 = Val("&H" & z1 & "&") Select Case y1 Case Val(&H3400&) To Val(&H4DBF&) EnglischName = "das" & Chr(160) & "Zeichen gehört zu ""CJK Ideograph Extension A""," _ & Chr(11) & "siehe http://www.unicode.org/charts/PDF/U3400.pdf" Case Val(&H4E00&) To Val(&H9FCB&) EnglischName = "das" & Chr(160) & "Zeichen ist ein ""CJK-Ideograph""," & Chr(11) _ & "siehe http://www.unicode.org/charts/PDF/U4E00.pdf" Case Val(&HAC00&) To Val(&HD7AF&) EnglischName = "das" & Chr(160) & "Zeichen ist eine ""Hangul Syllable"", " & Chr(11) _ & "siehe http://www.unicode.org/charts/PDF/UAC00.pdf" Case 57344 To 63743 EnglischName = "das" & Chr(160) & "Zeichen ist nicht genormt und gehört zur " _ & """Privat-Use-Area""" Case Val(&H20000) To Val(&H2A6DF & "&") EnglischName = "das" & Chr(160) & "Zeichen gehört zu ""CJK Ideograph Extension B""," _ & Chr(11) & "siehe http://www.unicode.org/charts/PDF/U20000.pdf" Case Val(&H2A700) To Val(&H2B734 & "&") EnglischName = "das" & Chr(160) & "Zeichen gehört zu ""CJK Ideograph Extension C""," _ & Chr(11) & "siehe http://www.unicode.org/charts/PDF/U2A700.pdf" Case Else EnglischName = "das" & Chr(160) & "Zeichen ist nicht in der " _ & "Unicode-Liste enthalten" End Select End If End Function ' ************************************************************** Private Function Symbolname(z1 As String) As String ' Makro erstellt am 30. August 2010 von Dipl.-Ing. Hanna-Chris Gast, Stand 12. März 2011. ' Diese Funktion gibt die (englischen) Unicode-Namen und entsprechende Unicodes an, ' wenn der (niedrige) hexadezimale Symbol-Code eingegeben wird ' Quellen "http://unicode.org/Public/MAPPINGS/VENDORS/APPLE/SYMBOL.TXT" und andere ' Ein paar Fehler habe ich hierbei beseitigt, zum Beispiel: Kleines Phi und Phi-Symbol ' waren vertauscht, und in einigen Fällen habe ich Ergänzungen vorgenommen. ' Select Case z1 Case Is = "20" Symbolname = "NO-BREAK SPACE (hex. 00A0)" Case Is = "21" Symbolname = "EXCLAMATION MARK (hex. 0021)" Case Is = "22" Symbolname = "FOR ALL (hex. 2200)" Case Is = "23" Symbolname = "NUMBER SIGN (hex. 0023)" Case Is = "24" Symbolname = "THERE EXISTS (hex. 2203)" Case Is = "25" Symbolname = "PERCENT SIGN (hex. 0025)" Case Is = "26" Symbolname = "AMPERSAND (hex. 0026)" Case Is = "27" Symbolname = "CONTAINS AS MEMBER (hex. 220B)" Case Is = "28" Symbolname = "LEFT PARENTHESIS (hex. 0028)" Case Is = "29" Symbolname = "RIGHT PARENTHESIS (hex. 0029)" Case Is = "2A" Symbolname = "ASTERISK OPERATOR (hex. 2217)" Case Is = "2B" Symbolname = "PLUS SIGN (hex. 002B)" Case Is = "2C" Symbolname = "COMMA (hex. 002C)" Case Is = "2D" Symbolname = "MINUS SIGN (hex. 2212)" Case Is = "2E" Symbolname = "FULL STOP (hex. 002E)" Case Is = "2F" Symbolname = "SOLIDUS (hex. 002F)" Case Is = "30" Symbolname = "DIGIT ZERO (hex. 0030)" Case Is = "31" Symbolname = "DIGIT ONE (hex. 0031)" Case Is = "32" Symbolname = "DIGIT TWO (hex. 0032)" Case Is = "33" Symbolname = "DIGIT THREE (hex. 0033)" Case Is = "34" Symbolname = "DIGIT FOUR (hex. 0034)" Case Is = "35" Symbolname = "DIGIT FIVE (hex. 0035)" Case Is = "36" Symbolname = "DIGIT SIX (hex. 0036)" Case Is = "37" Symbolname = "DIGIT SEVEN (hex. 0037)" Case Is = "38" Symbolname = "DIGIT EIGHT (hex. 0038)" Case Is = "39" Symbolname = "DIGIT NINE (hex. 0039)" Case Is = "3A" Symbolname = "COLON (hex. 003A)" Case Is = "3B" Symbolname = "SEMICOLON (hex. 003B)" Case Is = "3C" Symbolname = "LESS-THAN SIGN (hex. 003C)" Case Is = "3D" Symbolname = "EQUALS SIGN (hex. 003D)" Case Is = "3E" Symbolname = "GREATER-THAN SIGN (hex. 003E)" Case Is = "3F" Symbolname = "QUESTION MARK (hex. 003F)" Case Is = "40" Symbolname = "APPROXIMATELY EQUAL TO (hex. 2245)" Case Is = "41" Symbolname = "GREEK CAPITAL LETTER ALPHA (hex. 0391)" Case Is = "42" Symbolname = "GREEK CAPITAL LETTER BETA (hex. 0392)" Case Is = "43" Symbolname = "GREEK CAPITAL LETTER CHI (hex. 03A7)" Case Is = "44" Symbolname = "INCREMENT (hex. 2206)" _ & vbCrLf & " oder GREEK CAPITAL LETTER DELTA (hex. 0394)" Case Is = "45" Symbolname = "GREEK CAPITAL LETTER EPSILON (hex. 0395)" Case Is = "46" Symbolname = "GREEK CAPITAL LETTER PHI (hex. 03A6)" Case Is = "47" Symbolname = "GREEK CAPITAL LETTER GAMMA (hex. 0393)" Case Is = "48" Symbolname = "GREEK CAPITAL LETTER ETA (hex. 0397)" Case Is = "49" Symbolname = "GREEK CAPITAL LETTER IOTA (hex. 0399)" Case Is = "4A" Symbolname = "GREEK THETA SYMBOL (hex. 03D1)" Case Is = "4B" Symbolname = "GREEK CAPITAL LETTER KAPPA (hex. 039A)" Case Is = "4C" Symbolname = "GREEK CAPITAL LETTER LAMDA (hex. 039B)" Case Is = "4D" Symbolname = "GREEK CAPITAL LETTER MU (hex. 039C)" Case Is = "4E" Symbolname = "GREEK CAPITAL LETTER NU (hex. 039D)" Case Is = "4F" Symbolname = "GREEK CAPITAL LETTER OMICRON (hex. 039F)" Case Is = "50" Symbolname = "GREEK CAPITAL LETTER PI (hex. 03A0)" Case Is = "51" Symbolname = "GREEK CAPITAL LETTER THETA (hex. 0398)" Case Is = "52" Symbolname = "GREEK CAPITAL LETTER RHO (hex. 03A1)" Case Is = "53" Symbolname = "GREEK CAPITAL LETTER SIGMA (hex. 03A3)" Case Is = "54" Symbolname = "GREEK CAPITAL LETTER TAU (hex. 03A4)" Case Is = "55" Symbolname = "GREEK CAPITAL LETTER UPSILON (hex. 03A5)" Case Is = "56" Symbolname = "GREEK SMALL LETTER FINAL SIGMA (hex. 03C2)" Case Is = "57" Symbolname = "OHM SIGN (hex. 2126)" _ & vbCrLf & " oder GREEK CAPITAL LETTER OMEGA (hex. 03A9)" Case Is = "58" Symbolname = "GREEK CAPITAL LETTER XI (hex. 039E)" Case Is = "59" Symbolname = "GREEK CAPITAL LETTER PSI (hex. 03A8)" Case Is = "5A" Symbolname = "GREEK CAPITAL LETTER ZETA (hex. 0396)" Case Is = "5B" Symbolname = "LEFT SQUARE BRACKET (hex. 005B)" Case Is = "5C" Symbolname = "THEREFORE (hex. 2234)" Case Is = "5D" Symbolname = "RIGHT SQUARE BRACKET (hex. 005D)" Case Is = "5E" Symbolname = "UP TACK (hex. 22A5)" Case Is = "5F" Symbolname = "LOW LINE (hex. 005F)" Case Is = "60" Symbolname = vbCrLf _ & " (kein Unicode-Zeichen für RADICAL EXTENDER vorhanden)," _ & vbCrLf _ & " Ersatz-Vorschlag: MACRON (hex. 00AF) oder COMBINING OVERLINE (hex. 0305)" Case Is = "61" Symbolname = "GREEK SMALL LETTER ALPHA (hex. 03B1)" Case Is = "62" Symbolname = "GREEK SMALL LETTER BETA (hex. 03B2)" Case Is = "63" Symbolname = "GREEK SMALL LETTER CHI (hex. 03C7)" Case Is = "64" Symbolname = "GREEK SMALL LETTER DELTA (hex. 03B4)" Case Is = "65" Symbolname = "GREEK SMALL LETTER EPSILON (hex. 03B5)" Case Is = "66" Symbolname = "GREEK PHI SYMBOL (hex. 03D5)" ' (gegenüber Originallisten korrigiert) Case Is = "67" Symbolname = "GREEK SMALL LETTER GAMMA (hex. 03B3)" Case Is = "68" Symbolname = "GREEK SMALL LETTER ETA (hex. 03B7)" Case Is = "69" Symbolname = "GREEK SMALL LETTER IOTA (hex. 03B9)" Case Is = "6A" Symbolname = "GREEK SMALL LETTER PHI (hex. 03C6)" ' (gegenüber Originallisten korrigiert) Case Is = "6B" Symbolname = "GREEK SMALL LETTER KAPPA (hex. 03BA)" Case Is = "6C" Symbolname = "GREEK SMALL LETTER LAMDA (hex. 03BB)" Case Is = "6D" Symbolname = "MICRO SIGN (hex. 00B5)" _ & vbCrLf & " oder GREEK SMALL LETTER MU (hex. 03BC)" Case Is = "6E" Symbolname = "GREEK SMALL LETTER NU (hex. 03BD)" Case Is = "6F" Symbolname = "GREEK SMALL LETTER OMICRON (hex. 03BF)" Case Is = "70" Symbolname = "GREEK SMALL LETTER PI (hex. 03C0)" Case Is = "71" Symbolname = "GREEK SMALL LETTER THETA (hex. 03B8)" Case Is = "72" Symbolname = "GREEK SMALL LETTER RHO (hex. 03C1)" Case Is = "73" Symbolname = "GREEK SMALL LETTER SIGMA (hex. 03C3)" Case Is = "74" Symbolname = "GREEK SMALL LETTER TAU (hex. 03C4)" Case Is = "75" Symbolname = "GREEK SMALL LETTER UPSILON (hex. 03C5)" Case Is = "76" Symbolname = "GREEK PI SYMBOL (hex. 03D6)" Case Is = "77" Symbolname = "GREEK SMALL LETTER OMEGA (hex. 03C9)" Case Is = "78" Symbolname = "GREEK SMALL LETTER XI (hex. 03BE)" Case Is = "79" Symbolname = "GREEK SMALL LETTER PSI (hex. 03C8)" Case Is = "7A" Symbolname = "GREEK SMALL LETTER ZETA (hex. 03B6)" Case Is = "7B" Symbolname = "LEFT CURLY BRACKET (hex. 007B)" Case Is = "7C" Symbolname = "VERTICAL LINE (hex. 007C)" Case Is = "7D" Symbolname = "RIGHT CURLY BRACKET (hex. 007D)" Case Is = "7E" Symbolname = "TILDE OPERATOR (hex. 223C)" Case Is = "A0" Symbolname = "EURO SIGN (bzw. nicht definiert)(hex. 20AC)" Case Is = "A1" Symbolname = "GREEK UPSILON WITH HOOK SYMBOL (hex. 03D2)" Case Is = "A2" Symbolname = "PRIME (hex. 2032)" Case Is = "A3" Symbolname = "LESS-THAN OR EQUAL TO (hex. 2264)" Case Is = "A4" Symbolname = "FRACTION SLASH (hex. 2044)" Case Is = "A5" Symbolname = "INFINITY (hex. 221E)" Case Is = "A6" Symbolname = "LATIN SMALL LETTER F WITH HOOK (hex. 0192)" Case Is = "A7" Symbolname = "BLACK CLUB SUIT (hex. 2663)" Case Is = "A8" Symbolname = "BLACK DIAMOND SUIT (hex. 2666)" Case Is = "A9" Symbolname = "BLACK HEART SUIT (hex. 2665)" Case Is = "AA" Symbolname = "BLACK SPADE SUIT (hex. 2660)" Case Is = "AB" Symbolname = "LEFT RIGHT ARROW (hex. 2194)" Case Is = "AC" Symbolname = "LEFTWARDS ARROW (hex. 2190)" Case Is = "AD" Symbolname = "UPWARDS ARROW (hex. 2191)" Case Is = "AE" Symbolname = "RIGHTWARDS ARROW (hex. 2192)" Case Is = "AF" Symbolname = "DOWNWARDS ARROW (hex. 2193)" Case Is = "B0" Symbolname = "DEGREE SIGN (hex. 00B0)" Case Is = "B1" Symbolname = "PLUS-MINUS SIGN (hex. 00B1)" Case Is = "B2" Symbolname = "DOUBLE PRIME (hex. 2033)" Case Is = "B3" Symbolname = "GREATER-THAN OR EQUAL TO (hex. 2265)" Case Is = "B4" Symbolname = "MULTIPLICATION SIGN (hex. 00D7)" Case Is = "B5" Symbolname = "PROPORTIONAL TO (hex. 221D)" Case Is = "B6" Symbolname = "PARTIAL DIFFERENTIAL (hex. 2202)" Case Is = "B7" Symbolname = "BULLET (hex. 2022)" Case Is = "B8" Symbolname = "DIVISION SIGN (hex. 00F7)" Case Is = "B9" Symbolname = "NOT EQUAL TO (hex. 2260)" Case Is = "BA" Symbolname = "IDENTICAL TO (hex. 2261)" Case Is = "BB" Symbolname = "ALMOST EQUAL TO (hex. 2248)" Case Is = "BC" Symbolname = "HORIZONTAL ELLIPSIS (hex. 2026)" Case Is = "BD" Symbolname = "VERTICAL LINE EXTENSION (for arrows) (hex. 23D0)" _ & vbCrLf & " möglicher Ersatz: Senkrechter Strich (hex. 007C)" Case Is = "BE" Symbolname = "HORIZONTAL ARROW EXTENDER (hex. 23AF)," _ & vbCrLf & " möglicher Ersatz: Geviertstrich (hex. 2014, EM DASH)" Case Is = "BF" Symbolname = "DOWNWARDS ARROW WITH CORNER LEFTWARDS (hex. 21B5)" Case Is = "C0" Symbolname = "ALEF SYMBOL (hex. 2135)" Case Is = "C1" Symbolname = "BLACK-LETTER CAPITAL I (hex. 2111)" Case Is = "C2" Symbolname = "BLACK-LETTER CAPITAL R (hex. 211C)" Case Is = "C3" Symbolname = "SCRIPT CAPITAL P (hex. 2118)" Case Is = "C4" Symbolname = "CIRCLED TIMES (hex. 2297)" Case Is = "C5" Symbolname = "CIRCLED PLUS (hex. 2295)" Case Is = "C6" Symbolname = "EMPTY SET (hex. 2205)," _ & vbCrLf & " meistens aber ""Durchmesser"" (hex. 2300)" Case Is = "C7" Symbolname = "INTERSECTION (hex. 2229)" Case Is = "C8" Symbolname = "UNION (hex. 222A)" Case Is = "C9" Symbolname = "SUPERSET OF (hex. 2283)" Case Is = "CA" Symbolname = "SUPERSET OF OR EQUAL TO (hex. 2287)" Case Is = "CB" Symbolname = "NOT A SUBSET OF (hex. 2284)" Case Is = "CC" Symbolname = "SUBSET OF (hex. 2282)" Case Is = "CD" Symbolname = "SUBSET OF OR EQUAL TO (hex. 2286)" Case Is = "CE" Symbolname = "ELEMENT OF (hex. 2208)" Case Is = "CF" Symbolname = "NOT AN ELEMENT OF (hex. 2209)" Case Is = "D0" Symbolname = "ANGLE (hex. 2220)" Case Is = "D1" Symbolname = "NABLA (hex. 2207)" Case Is = "D2" Symbolname = "REGISTERED SIGN (hex. 00AE) mit Serifen" Case Is = "D3" Symbolname = "COPYRIGHT SIGN (hex. 00A9) mit Serifen" Case Is = "D4" Symbolname = "TRADE MARK SIGN (hex. 2122) mit Serifen" Case Is = "D5" Symbolname = "N-ARY PRODUCT (hex. 220F)" Case Is = "D6" Symbolname = "SQUARE ROOT (hex. 221A)" Case Is = "D7" Symbolname = "DOT OPERATOR (hex. 22C5)" Case Is = "D8" Symbolname = "NOT SIGN (hex. 00AC)" Case Is = "D9" Symbolname = "LOGICAL AND (hex. 2227)" Case Is = "DA" Symbolname = "LOGICAL OR (hex. 2228)" Case Is = "DB" Symbolname = "LEFT RIGHT DOUBLE ARROW (hex. 21D4)" Case Is = "DC" Symbolname = "LEFTWARDS DOUBLE ARROW (hex. 21D0)" Case Is = "DD" Symbolname = "UPWARDS DOUBLE ARROW (hex. 21D1)" Case Is = "DE" Symbolname = "RIGHTWARDS DOUBLE ARROW (hex. 21D2)" Case Is = "DF" Symbolname = "DOWNWARDS DOUBLE ARROW (hex. 21D3)" Case Is = "E0" Symbolname = "LOZENGE (hex. 25CA)" Case Is = "E1" Symbolname = "LEFT-POINTING ANGLE BRACKET (hex. 2329)" Case Is = "E2" Symbolname = "REGISTERED SIGN, (hex. 00AE) Sans Serif" Case Is = "E3" Symbolname = "COPYRIGHT SIGN, (hex. 00A9) Sans Serif" Case Is = "E4" Symbolname = "TRADE MARK SIGN, (hex. 2122) Sans Serif" Case Is = "E5" Symbolname = "N-ARY SUMMATION (hex. 2211)" Case Is = "E6" Symbolname = "LEFT PARENTHESIS UPPER HOOK (hex. 239B)" Case Is = "E7" Symbolname = "LEFT PARENTHESIS EXTENSION (hex. 239C)" Case Is = "E8" Symbolname = "LEFT PARENTHESIS LOWER HOOK (hex. 239D)" Case Is = "E9" Symbolname = "LEFT SQUARE BRACKET UPPER CORNER (hex. 23A1)" Case Is = "EA" Symbolname = "LEFT SQUARE BRACKET EXTENSION (hex. 23A2)" Case Is = "EB" Symbolname = "LEFT SQUARE BRACKET LOWER CORNER (hex. 23A3)" Case Is = "EC" Symbolname = "LEFT CURLY BRACKET UPPER HOOK (hex. 23A7)" Case Is = "ED" Symbolname = "LEFT CURLY BRACKET MIDDLE PIECE (hex. 23A8)" Case Is = "EE" Symbolname = "LEFT CURLY BRACKET LOWER HOOK (hex. 23A9)" Case Is = "EF" Symbolname = "CURLY BRACKET EXTENSION (hex. 23AA)" Case Is = "F0" Symbolname = "(nicht definiert, bzw. Apple-Logo)" Case Is = "F1" Symbolname = "RIGHT-POINTING ANGLE BRACKET (hex. 232A)" Case Is = "F2" Symbolname = "INTEGRAL (hex. 222B)" Case Is = "F3" Symbolname = "TOP HALF INTEGRAL (hex. 2320)" Case Is = "F4" Symbolname = "INTEGRAL EXTENSION (hex. 23AE)" Case Is = "F5" Symbolname = "BOTTOM HALF INTEGRAL (hex. 2321)" Case Is = "F6" Symbolname = "RIGHT PARENTHESIS UPPER HOOK (hex. 239E)" Case Is = "F7" Symbolname = "RIGHT PARENTHESIS EXTENSION (hex. 239F)" Case Is = "F8" Symbolname = "RIGHT PARENTHESIS LOWER HOOK (hex. 23A0)" Case Is = "F9" Symbolname = "RIGHT SQUARE BRACKET UPPER CORNER (hex. 23A4)" Case Is = "FA" Symbolname = "RIGHT SQUARE BRACKET EXTENSION (hex. 23A5)" Case Is = "FB" Symbolname = "RIGHT SQUARE BRACKET LOWER CORNER (hex. 23A6)" Case Is = "FC" Symbolname = "RIGHT CURLY BRACKET UPPER HOOK (hex. 23AB)" Case Is = "FD" Symbolname = "RIGHT CURLY BRACKET MIDDLE PIECE (hex. 23AC)" Case Is = "FE" Symbolname = "RIGHT CURLY BRACKET LOWER HOOK (hex. 23AD)" Case Else Symbolname = "(kein Symbol-Zeichen festgelegt!)" End Select End Function ' *************************************************************** Private Function Wingdingsname(z1 As String) As String ' Erstellt von Dipl.-Ing. Hanna-Chris Gast, 5. März 2011, Stand 12. Oktober 2011. ' Diese Funktion gibt englische Zeichenerklärung und ggf. entsprechende Unicodes an, ' wenn der (niedrige) hexadezimale Symbol-Code eingegeben wird ' Quelle: http://www.alanwood.net/demos/wingdings.html. ' Select Case z1 Case Is = "20" Wingdingsname = "SPACE (Unicode = hex. 0020)" Case Is = "20" Wingdingsname = "SPACE (Unicode = hex. 0020)" Case Is = "21" Wingdingsname = "PENCIL (Unicode = hex. 270F)" Case Is = "22" Wingdingsname = "BLACK SCISSORS (Unicode = hex. 2702)" Case Is = "23" Wingdingsname = "UPPER BLADE SCISSORS (Unicode = hex. 2701)" Case Is = "24" Wingdingsname = "EYEGLASSES (Unicode = hex. 1F453)" Case Is = "25" Wingdingsname = "BELL (Unicode = hex. 1F514)" Case Is = "26" Wingdingsname = "OPEN BOOK (Unicode = hex. 1F4D6)" Case Is = "27" Wingdingsname = " (CANDLE) (kein Unicode)" Case Is = "28" Wingdingsname = "BLACK TELEPHONE (Unicode = hex. 260E)" Case Is = "29" Wingdingsname = "TELEPHONE LOCATION SIGN (Unicode = hex. 2706)" Case Is = "2A" Wingdingsname = "ENVELOPE (Unicode = hex. 2709)" Case Is = "2B" Wingdingsname = "ENVELOPE WITH ADDRESS AND STAMP (kein Unicode)" Case Is = "2C" Wingdingsname = "CLOSED MAILBOX WITH LOWERED FLAG (Unicode = hex. 1F4EA)" Case Is = "2D" Wingdingsname = "CLOSED MAILBOX WITH RAISED FLAG (Unicode = hex. 1F4EB)" Case Is = "2E" Wingdingsname = "OPEN MAILBOX WITH RAISED FLAG (Unicode = hex. 1F4EC)" Case Is = "2F" Wingdingsname = "OPEN MAILBOX WITH LOWERED FLAG (Unicode = hex. 1F4ED)" Case Is = "30" Wingdingsname = "FILE FOLDER (Unicode = hex. 1F4C1)" Case Is = "31" Wingdingsname = "OPEN FILE FOLDER (Unicode = hex. 1F4C2)" Case Is = "32" Wingdingsname = "PAGE FACING UP (Unicode = hex. 1F4C4)" Case Is = "33" Wingdingsname = "PRINTED PAGE (kein Unicode)" Case Is = "34" Wingdingsname = "STACK OF PRINTED PAGES (kein Unicode)" Case Is = "35" Wingdingsname = "FILING CABINET (kein Unicode)" Case Is = "36" Wingdingsname = "HOURGLASS (Unicode = hex. 231B)" Case Is = "37" Wingdingsname = "KEYBOARD (Unicode = hex. 2328)" Case Is = "38" Wingdingsname = "MOUSE (kein Unicode)" Case Is = "39" Wingdingsname = "TRACKBALL (kein Unicode)" Case Is = "3A" Wingdingsname = "PERSONAL COMPUTER (Unicode = hex. 1F4BB)" Case Is = "3B" Wingdingsname = "HARD DISK (kein Unicode)" Case Is = "3C" Wingdingsname = "FLOPPY DISK (Unicode = hex. 1F4BE)" Case Is = "3D" Wingdingsname = "FLOPPY DISK (kein Unicode)" Case Is = "3E" Wingdingsname = "TAPE DRIVE (Unicode = hex. 2707)" Case Is = "3F" Wingdingsname = "WRITING HAND (Unicode = hex. 270D)" Case Is = "40" Wingdingsname = "WRITING LEFT HAND (kein Unicode)" Case Is = "41" Wingdingsname = "VICTORY HAND (Unicode = hex. 270C)" Case Is = "42" Wingdingsname = "OK HAND SIGN (Unicode = hex. 1F44C)" Case Is = "43" Wingdingsname = "THUMBS UP SIGN (Unicode = hex. 1F44D)" Case Is = "44" Wingdingsname = "THUMBS DOWN SIGN (Unicode = hex. 1F44E)" Case Is = "45" Wingdingsname = "WHITE LEFT POINTING INDEX (Unicode = hex. 261C)" Case Is = "46" Wingdingsname = "WHITE RIGHT POINTING INDEX (Unicode = hex. 261E)" Case Is = "47" Wingdingsname = "WHITE UP POINTING INDEX (Unicode = hex. 261D)" Case Is = "48" Wingdingsname = "WHITE DOWN POINTING INDEX (Unicode = hex. 261F)" Case Is = "49" Wingdingsname = "OPEN HAND (kein Unicode)" Case Is = "4A" Wingdingsname = "WHITE SMILING FACE (Unicode = hex. 263A)" Case Is = "4B" Wingdingsname = "NEUTRAL FACE (Unicode = hex. 1F610)" Case Is = "4C" Wingdingsname = "WHITE FROWNING FACE (Unicode = hex. 2639)" Case Is = "4D" Wingdingsname = "BOMB (Unicode = hex. 1F4A3)" Case Is = "4E" Wingdingsname = "SKULL AND CROSSBONES (Unicode = hex. 2620)" Case Is = "4F" Wingdingsname = "WHITE FLAG (Unicode = hex. 2690)" Case Is = "50" Wingdingsname = "PENNANT ON POLE (kein Unicode)" Case Is = "51" Wingdingsname = "AIRPLANE (Unicode = hex. 2708)" Case Is = "52" Wingdingsname = "WHITE SUN WITH RAYS (Unicode = hex. 263C)" Case Is = "53" Wingdingsname = "DROPLET (Unicode = hex. 1F4A7)" Case Is = "54" Wingdingsname = "SNOWFLAKE (Unicode = hex. 2744)" Case Is = "55" Wingdingsname = "WHITE LATIN CROSS (kein Unicode)" Case Is = "56" Wingdingsname = "SHADOWED WHITE LATIN CROSS (Unicode = hex. 271E)" Case Is = "57" Wingdingsname = "CELTIC CROSS (kein Unicode)" Case Is = "58" Wingdingsname = "MALTESE CROSS (Unicode = hex. 2720)" Case Is = "59" Wingdingsname = "STAR OF DAVID (Unicode = hex. 2721)" Case Is = "5A" Wingdingsname = "STAR AND CRESCENT (Unicode = hex. 262A)" Case Is = "5B" Wingdingsname = "YIN YANG (Unicode = hex. 262F)" Case Is = "5C" Wingdingsname = "DEVANAGARI OM (Unicode = hex. 0950)" Case Is = "5D" Wingdingsname = "WHEEL OF DHARMA (Unicode = hex. 2638)" Case Is = "5E" Wingdingsname = "ARIES (Unicode = hex. 2648)" Case Is = "5F" Wingdingsname = "TAURUS (Unicode = hex. 2649)" Case Is = "60" Wingdingsname = "GEMINI (Unicode = hex. 264A)" Case Is = "61" Wingdingsname = "CANCER (Unicode = hex. 264B)" Case Is = "62" Wingdingsname = "LEO (Unicode = hex. 264C)" Case Is = "63" Wingdingsname = "VIRGO (Unicode = hex. 264D)" Case Is = "64" Wingdingsname = "LIBRA (Unicode = hex. 264E)" Case Is = "65" Wingdingsname = "SCORPIO (Unicode = hex. 264F)" Case Is = "66" Wingdingsname = "SAGITTARIUS (Unicode = hex. 2650)" Case Is = "67" Wingdingsname = "CAPRICORN (Unicode = hex. 2651)" Case Is = "68" Wingdingsname = "AQUARIUS (Unicode = hex. 2652)" Case Is = "69" Wingdingsname = "PISCES (Unicode = hex. 2653)" Case Is = "6A" Wingdingsname = "AMPERSAND (lower Case) (Unicode = hex. 0026)" Case Is = "6B" Wingdingsname = "AMPERSAND (ITALIC) (Unicode = hex. 0026)" Case Is = "6C" Wingdingsname = "BLACK CIRCLE (Unicode = hex. 25CF)" Case Is = "6D" Wingdingsname = "SHADOWED WHITE CIRCLE (Unicode = hex. 274D)" Case Is = "6E" Wingdingsname = "BLACK SQUARE (Unicode = hex. 25A0)" Case Is = "6F" Wingdingsname = "WHITE SQUARE (Unicode = hex. 25A1)" Case Is = "70" Wingdingsname = "BOLD WHITE SQUARE (kein Unicode)" Case Is = "71" Wingdingsname = "LOWER RIGHT SHADOWED WHITE SQUARE (Unicode = hex. 2751)" Case Is = "72" Wingdingsname = "UPPER RIGHT SHADOWED WHITE SQUARE (Unicode = hex. 2752)" Case Is = "73" Wingdingsname = "BLACK MEDIUM LOZENGE (Unicode = hex. 2B27)" Case Is = "74" Wingdingsname = "BLACK LOZENGE (Unicode = hex. 29EB)" Case Is = "75" Wingdingsname = "BLACK DIAMOND (Unicode = hex. 25C6)" Case Is = "76" Wingdingsname = "BLACK DIAMOND MINUS WHITE X (Unicode = hex. 2756)" Case Is = "77" Wingdingsname = "BLACK MEDIUM DIAMOND (Unicode = hex. 2B25)" Case Is = "78" Wingdingsname = "X IN A RECTANGLE BOX (Unicode = hex. 2327)" Case Is = "79" Wingdingsname = "APL FUNCTIONAL SYMBOL QUAD UP CARET (Unicode = hex. 2353)" Case Is = "7A" Wingdingsname = "PLACE OF INTEREST SIGN (Unicode = hex. 2318)" Case Is = "7B" Wingdingsname = "WHITE FLORETTE (Unicode = hex. 2740)" Case Is = "7C" Wingdingsname = "BLACK FLORETTE (Unicode = hex. 273F)" Case Is = "7D" Wingdingsname = "HEAVY DOUBLE TURNED COMMA QUOTATION MARK " _ & "ORNAMENT (Unicode = hex. 275D)" Case Is = "7E" Wingdingsname = "HEAVY DOUBLE COMMA QUOTATION MARK ORNAMENT " _ & "(Unicode = hex. 275E)" Case Is = "7F" Wingdingsname = "(WHITE VERTICAL RECTANGLE) (Unicode = hex. 25AF)" Case Is = "80" Wingdingsname = "CIRCLED DIGIT ZERO (Unicode = hex. 24EA)" Case Is = "81" Wingdingsname = "CIRCLED DIGIT ONE (Unicode = hex. 2460)" Case Is = "82" Wingdingsname = "CIRCLED DIGIT TWO (Unicode = hex. 2461)" Case Is = "83" Wingdingsname = "CIRCLED DIGIT THREE (Unicode = hex. 2462)" Case Is = "84" Wingdingsname = "CIRCLED DIGIT FOUR (Unicode = hex. 2463)" Case Is = "85" Wingdingsname = "CIRCLED DIGIT FIVE (Unicode = hex. 2464)" Case Is = "86" Wingdingsname = "CIRCLED DIGIT SIX (Unicode = hex. 2465)" Case Is = "87" Wingdingsname = "CIRCLED DIGIT SEVEN (Unicode = hex. 2466)" Case Is = "88" Wingdingsname = "CIRCLED DIGIT EIGHT (Unicode = hex. 2467)" Case Is = "89" Wingdingsname = "CIRCLED DIGIT NINE (Unicode = hex. 2468)" Case Is = "8A" Wingdingsname = "CIRCLED NUMBER TEN (Unicode = hex. 2469)" Case Is = "8B" Wingdingsname = "NEGATIVE CIRCLED DIGIT ZERO (Unicode = hex. 24FF)" Case Is = "8C" Wingdingsname = "DINGBAT NEGATIVE CIRCLED DIGIT ONE (Unicode = hex. 2776)" Case Is = "8D" Wingdingsname = "DINGBAT NEGATIVE CIRCLED DIGIT TWO (Unicode = hex. 2777)" Case Is = "8E" Wingdingsname = "DINGBAT NEGATIVE CIRCLED DIGIT THREE (Unicode = hex. 2778)" Case Is = "8F" Wingdingsname = "DINGBAT NEGATIVE CIRCLED DIGIT FOUR (Unicode = hex. 2779)" Case Is = "90" Wingdingsname = "DINGBAT NEGATIVE CIRCLED DIGIT FIVE (Unicode = hex. 277A)" Case Is = "91" Wingdingsname = "DINGBAT NEGATIVE CIRCLED DIGIT SIX (Unicode = hex. 277B)" Case Is = "92" Wingdingsname = "DINGBAT NEGATIVE CIRCLED DIGIT SEVEN (Unicode = hex. 277C)" Case Is = "93" Wingdingsname = "DINGBAT NEGATIVE CIRCLED DIGIT EIGHT (Unicode = hex. 277D)" Case Is = "94" Wingdingsname = "DINGBAT NEGATIVE CIRCLED DIGIT NINE (Unicode = hex. 277E)" Case Is = "95" Wingdingsname = "DINGBAT NEGATIVE CIRCLED NUMBER TEN (Unicode = hex. 277F)" Case Is = "96" Wingdingsname = "BUD AND LEAF NORTH EAST (kein Unicode)" Case Is = "97" Wingdingsname = "BUD AND LEAF NORTH WEST (kein Unicode)" Case Is = "98" Wingdingsname = "BUD AND LEAF SOUTH WEST (kein Unicode)" Case Is = "99" Wingdingsname = "BUD AND LEAF SOUTH EAST (kein Unicode)" Case Is = "9A" Wingdingsname = "BOLD VINE LEAF NORTH EAST (kein Unicode)" Case Is = "9B" Wingdingsname = "BOLD VINE LEAF NORTH WEST (kein Unicode)" Case Is = "9C" Wingdingsname = "BOLD VINE LEAF SOUTH WEST (kein Unicode)" Case Is = "9D" Wingdingsname = "BOLD VINE LEAF SOUTH EAST (kein Unicode)" Case Is = "9E" Wingdingsname = "MIDDLE DOT (Unicode = hex. 00B7)" Case Is = "9F" Wingdingsname = "BULLET (Unicode = hex. 2022)" Case Is = "A0" Wingdingsname = "BLACK SMALL SQUARE (Unicode = hex. 25AA)" Case Is = "A1" Wingdingsname = "WHITE CIRCLE (Unicode = hex. 25CB)" Case Is = "A2" Wingdingsname = "BOLD WHITE CIRCLE (kein Unicode)" Case Is = "A3" Wingdingsname = "EXTRA BOLD WHITE CIRCLE (kein Unicode)" Case Is = "A4" Wingdingsname = "FISHEYE (Unicode = hex. 25C9)" Case Is = "A5" Wingdingsname = "BULLSEYE (Unicode = hex. 25CE)" Case Is = "A6" Wingdingsname = "ähnlich SHADOWED WHITE CIRCLE (Unicode = hex. 274D)" Case Is = "A7" Wingdingsname = "BLACK SMALL SQUARE 7 (Unicode = hex. 25AA)" Case Is = "A8" Wingdingsname = "WHITE MEDIUM SQUARE (Unicode = hex. 25FB)" Case Is = "A9" Wingdingsname = "BLACK THREE POINTED STAR (kein Unicode)" Case Is = "AA" Wingdingsname = "BLACK FOUR POINTED STAR (Unicode = hex. 2726)" Case Is = "AB" Wingdingsname = "BLACK STAR (Unicode = hex. 2605)" Case Is = "AC" Wingdingsname = "SIX POINTED BLACK STAR (Unicode = hex. 2736)" Case Is = "AD" Wingdingsname = "EIGHT POINTED BLACK STAR (Unicode = hex. 2734)" Case Is = "AE" Wingdingsname = "TWELVE POINTED BLACK STAR (Unicode = hex. 2739)" Case Is = "AF" Wingdingsname = "EIGHT POINTED PINWHEEL STAR (Unicode = hex. 2735)" Case Is = "B0" Wingdingsname = "SQUARE REGISTER MARK (kein Unicode)" Case Is = "B1" Wingdingsname = "POSITION INDICATOR (Unicode = hex. 2316)" Case Is = "B2" Wingdingsname = "WHITE CONCAVE-SIDED DIAMOND (Unicode = hex. 27E1)" Case Is = "B3" Wingdingsname = "SQUARE LOZENGE (Unicode = hex. 2311)" Case Is = "B4" Wingdingsname = "QUESTION MARK IN WHITE DIAMOND (kein Unicode)" Case Is = "B5" Wingdingsname = "CIRCLED WHITE STAR (Unicode = hex. 272A)" Case Is = "B6" Wingdingsname = "SHADOWED WHITE STAR (Unicode = hex. 2730)" Case Is = "B7" Wingdingsname = "CLOCK FACE ONE O CLOCK (Unicode = hex. 1F550)" Case Is = "B8" Wingdingsname = "CLOCK FACE TWO O CLOCK (Unicode = hex. 1F551)" Case Is = "B9" Wingdingsname = "CLOCK FACE THREE O CLOCK (Unicode = hex. 1F552)" Case Is = "BA" Wingdingsname = "CLOCK FACE FOUR O CLOCK (Unicode = hex. 1F553)" Case Is = "BB" Wingdingsname = "CLOCK FACE FIVE O CLOCK (Unicode = hex. 1F554)" Case Is = "BC" Wingdingsname = "CLOCK FACE SIX O CLOCK (Unicode = hex. 1F555)" Case Is = "BD" Wingdingsname = "CLOCK FACE SEVEN O CLOCK (Unicode = hex. 1F556)" Case Is = "BE" Wingdingsname = "CLOCK FACE EIGHT O CLOCK (Unicode = hex. 1F557)" Case Is = "BF" Wingdingsname = "CLOCK FACE NINE O CLOCK (Unicode = hex. 1F558)" Case Is = "C0" Wingdingsname = "CLOCK FACE TEN O CLOCK (Unicode = hex. 1F559)" Case Is = "C1" Wingdingsname = "CLOCK FACE ELEVEN O CLOCK (Unicode = hex. 1F55A)" Case Is = "C2" Wingdingsname = "CLOCK FACE TWELVE O CLOCK (Unicode = hex. 1F55B)" Case Is = "C3" Wingdingsname = "(WHITE ARROW POINTING DOWNWARDS THEN CURVING " _ & "LEFTWARDS (kein Unicode)" Case Is = "C4" Wingdingsname = "WHITE ARROW POINTING DOWNWARDS THEN CURVING " _ & "RIGHTWARDS (kein Unicode)" Case Is = "C5" Wingdingsname = "WHITE ARROW POINTING UPWARDS THEN CURVING " _ & "LEFTWARDS (kein Unicode)" Case Is = "C6" Wingdingsname = "WHITE ARROW POINTING UPWARDS THEN CURVING " _ & "RIGHTWARDS (kein Unicode)" Case Is = "C7" Wingdingsname = "WHITE ARROW POINTING LEFTWARDS THEN CURVING " _ & "UPWARDS (kein Unicode)" Case Is = "C8" Wingdingsname = "WHITE ARROW POINTING RIGHTWARDS THEN CURVING " _ & "UPWARDS (kein Unicode)" Case Is = "C9" Wingdingsname = "WHITE ARROW POINTING LEFTWARDS THEN CURVING " _ & "DOWNWARDS (kein Unicode)" Case Is = "CA" Wingdingsname = "WHITE ARROW POINTING RIGHTWARDS THEN CURVING " _ & "DOWNWARDS (kein Unicode)" Case Is = "CB" Wingdingsname = "QUILT SQUARE 2 (kein Unicode)" Case Is = "CC" Wingdingsname = "BLACK QUILT SQUARE 2 (kein Unicode)" Case Is = "CD" Wingdingsname = "LEAF COUNTERCLOCKWISE SOUTH WEST (kein Unicode)" Case Is = "CE" Wingdingsname = "LEAF COUNTERCLOCKWISE NORTH WEST (kein Unicode)" Case Is = "CF" Wingdingsname = "LEAF COUNTERCLOCKWISE SOUTH EAST (kein Unicode)" Case Is = "D0" Wingdingsname = "LEAF COUNTERCLOCKWISE NORTH EAST (kein Unicode)" Case Is = "D1" Wingdingsname = "LEAF NORTH WEST (kein Unicode)" Case Is = "D2" Wingdingsname = "LEAF SOUTH WEST (kein Unicode)" Case Is = "D3" Wingdingsname = "LEAF NORTH EAST (kein Unicode)" Case Is = "D4" Wingdingsname = "LEAF SOUTH EAST (kein Unicode)" Case Is = "D5" Wingdingsname = "ERASE TO THE LEFT (Unicode = hex. 232B)" Case Is = "D6" Wingdingsname = "ERASE TO THE RIGHT (Unicode = hex. 2326)" Case Is = "D7" Wingdingsname = "THREE-D TOP-LIGHTED LEFTWARDS ARROWHEAD (kein Unicode)" Case Is = "D8" Wingdingsname = "THREE-D TOP-LIGHTED RIGHTWARDS ARROWHEAD (Unicode = hex. 27A2)" Case Is = "D9" Wingdingsname = "THREE-D RIGHT-LIGHTED UPWARDS ARROWHEAD (kein Unicode)" Case Is = "DA" Wingdingsname = "THREE-D LEFT-LIGHTED DOWNWARDS ARROWHEAD (kein Unicode)" Case Is = "DB" Wingdingsname = "CIRCLED HEAVY WHITE LEFTWARDS ARROW (kein Unicode)" Case Is = "DC" Wingdingsname = "CIRCLED HEAVY WHITE RIGHTWARDS ARROW (Unicode = hex. 27B2)" Case Is = "DD" Wingdingsname = "CIRCLED HEAVY WHITE UPWARDS ARROW (kein Unicode)" Case Is = "DE" Wingdingsname = "CIRCLED HEAVY WHITE DOWNWARDS ARROW (kein Unicode)" Case Is = "DF" Wingdingsname = "WIDE-HEADED LEFTWARDS ARROW (kein Unicode)" Case Is = "E0" Wingdingsname = "WIDE-HEADED RIGHTWARDS ARROW (kein Unicode)" Case Is = "E1" Wingdingsname = "WIDE-HEADED UPWARDS ARROW (kein Unicode)" Case Is = "E2" Wingdingsname = "WIDE-HEADED DOWNWARDS ARROW (kein Unicode)" Case Is = "E3" Wingdingsname = "WIDE-HEADED NORTH WEST ARROW (kein Unicode)" Case Is = "E4" Wingdingsname = "WIDE-HEADED NORTH EAST ARROW (kein Unicode)" Case Is = "E5" Wingdingsname = "WIDE-HEADED SOUTH WEST ARROW (kein Unicode)" Case Is = "E6" Wingdingsname = "WIDE-HEADED SOUTH EAST ARROW (kein Unicode)" Case Is = "E7" Wingdingsname = "HEAVY WIDE-HEADED LEFTWARDS ARROW (kein Unicode)" Case Is = "E8" Wingdingsname = "HEAVY WIDE-HEADED RIGHTWARDS ARROW (Unicode = hex. 2794)" Case Is = "E9" Wingdingsname = "HEAVY WIDE-HEADED UPWARDS ARROW (kein Unicode)" Case Is = "EA" Wingdingsname = "HEAVY WIDE-HEADED DOWNWARDS ARROW (kein Unicode)" Case Is = "EB" Wingdingsname = "HEAVY WIDE-HEADED NORTH WEST ARROW (kein Unicode)" Case Is = "EC" Wingdingsname = "HEAVY WIDE-HEADED NORTH EAST ARROW (kein Unicode)" Case Is = "ED" Wingdingsname = "HEAVY WIDE-HEADED SOUTH WEST ARROW (kein Unicode)" Case Is = "EE" Wingdingsname = "HEAVY WIDE-HEADED SOUTH EAST ARROW (kein Unicode)" Case Is = "EF" Wingdingsname = "LEFTWARDS WHITE ARROW (Unicode = hex. 21E6)" Case Is = "F0" Wingdingsname = "RIGHTWARDS WHITE ARROW (Unicode = hex. 21E8)" Case Is = "F1" Wingdingsname = "UPWARDS WHITE ARROW (Unicode = hex. 21E7)" Case Is = "F2" Wingdingsname = "DOWNWARDS WHITE ARROW (Unicode = hex. 21E9)" Case Is = "F3" Wingdingsname = "LEFT RIGHT WHITE ARROW (Unicode = hex. 2B04)" Case Is = "F4" Wingdingsname = "UP DOWN WHITE ARROW (Unicode = hex. 21F3)" Case Is = "F5" Wingdingsname = "NORTH WEST WHITE ARROW (Unicode = hex. 2B01)" Case Is = "F6" Wingdingsname = "NORTH EAST WHITE ARROW (Unicode = hex. 2B00)" Case Is = "F7" Wingdingsname = "SOUTH WEST WHITE ARROW (Unicode = hex. 2B03)" Case Is = "F8" Wingdingsname = "SOUTH EAST WHITE ARROW (Unicode = hex. 2B02)" Case Is = "F9" Wingdingsname = "WHITE RECTANGLE (Unicode = hex. 25AD)" Case Is = "FA" Wingdingsname = "WHITE SMALL SQUARE (Unicode = hex. 25AB)" Case Is = "FB" Wingdingsname = "BALLOT X (Unicode = hex. 2717)" Case Is = "FC" Wingdingsname = "CHECK MARK (Unicode = hex. 2713)" Case Is = "FD" Wingdingsname = "BALLOT BOX WITH X (FONT-WEIGHT: BOLD) (Unicode = hex. 2612)" Case Is = "FE" Wingdingsname = "BALLOT BOX WITH CHECK (FONT-WEIGHT: BOLD) (Unicode = hex. 2611)" Case Is = "FF" Wingdingsname = "WINDOWS LOGO (kein Unicode)" Case Else Wingdingsname = "(KEIN WINGDINGS-ZEICHEN FESTGELEGT!)" End Select End Function ' *************************************************************** Sub a011_Hexcode_und_Name_ermitteln() ' Erstellt von Dipl.-Ing. Hanna-Chris Gast, 3. bis 13. Juni 2010 (Stand 13. April 2012). ' Funktioniert in Word 2000 bis Word 2010. ' Dieses Makro ermittelt die Schriftart und die Unicode-Werte eines markierten Zeichens oder ' einer markierten Zeichenfolge, aber auch die Schriftart und den Code der beiden ' Windows-Sonderschriften "Symbol" und "Wingdings". ' Das Ergebnis kann in eine separate Datei ausgegeben werden. Dabei werden dann auch die ' jeweiligen (englischen) Namen der Unicode-Zeichen angegeben. ' Bei den Symbolzeichen und (seit März 2011) den Wingdingszeichen werden, soweit vorhanden, ' die entsprechenden Unicodezeichen mit (englischen) Namen angegeben. ' Dieses Makro kann seit 2011 auch in Tabellen mehrere Zellen auf einmal analysieren (Mai 2011). ' Dieses Makro analysiert auch Felder (seit Herbst 2011 auch bei Double-Strike). ' Gewählte Tastenkürzel: AltGr+C. ' Dim x() As String ' x(i) ist das zu analysierende Zeichen Dim y() As String ' z(i) der Hexcode Dim z() As String ' y(i) der Dezimalcode Dim f() As String ' f(i) die jeweilige Schriftart (Font) Dim Rg() As Range ' Rg(i) ist der Range des jeweiligen Zeichens Dim fs As String Dim Feldsteuerzeichen As Boolean '' Dim Undozähler As Integer Dim zL As String, zR As String Dim Ergebnis As String, Ergebnis1 As String Dim i As Integer, j As Integer, N As Integer Dim k1 As Integer, k2 As Integer Dim Zeichennummer1 Dim Rng0 As Range, rng1 As Range, Rng2 As Range ' Rng0 ist der zu analysierende Bereich. Dim MsgBoxAnzeige As String Dim Abfrage As Integer Dim Windowssonderschrift() As Boolean Dim Pfad1 As String, Unicodeliste1 As String Dim Pos1 As Integer, Pos2 As Integer Dim doc2 As Word.Document, doc1 As Word.Document Dim aTable As Table Dim Zwischendatei As Boolean: Zwischendatei = False Dim Unsichtbares_zeigen As Boolean ' ********************************** ' "Ausgeblendete" Zeichen sichtbar machen, wenn sie unsichtbar sind: If ActiveWindow.View.ShowAll = False Then Unsichtbares_zeigen = True ActiveWindow.View.ShowAll = True End If ' ' Wenn der Cursor am Textanfang steht und nichts markiert ist: If Selection.Range.End = 0 Then MsgBox "Bitte Zeichen markieren, der Cursor steht vor dem Text!" Exit Sub End If ' ' Wenn nichts markiert ist, 1 Zeichen links vom Cursor markieren: If Selection.Type < 2 Then Set Rng0 = Selection.Range Rng0.SetRange Start:=Rng0.End - 1, End:=Rng0.End Rng0.Select End If If Selection.Type = 8 Then MsgBox Ergebnis1 & "Es ist eine frei positionierte Grafik oder deren Ankerpunkt markiert." Exit Sub End If ' ''' Fehlerbehandlung: '' On Error GoTo Zeile_Abbruch_weil_kein_Schriftzeichen '' On Error Resume Next ' ***********************' ' Maximale Länge der Zeichenkette wird auf 44 Zeichen begrenzt wegen der maximalen Zeilenzahl ' der MessageBoxW (in eine normale MsgBox passen sogar nur 16 Zeilen): N = Len(Selection) If N > 44 Then MsgBox "Maximal 44 Zeichen markieren! Es sind hier " & N & " Zeichen markiert." Exit Sub End If ' ********************************************************************* ' "Autofokus" wegen kombinierenden diakritischen Zeichen und ' Zeichen höherer Unicode-Ebenen: ' ********************************************************************* ' a) Markierung um kombinierende diakritische Zeichen erweitern ' (Unicode-Zeichen von hex. 0300 bis hex. 036F., bzw. dezimal von 768 bis 879): ' a1) Wenn nur das kombinierende diakritische Zeichen (oder eines von bis zu vier) markiert ist: For i = 1 To 4 zL = Hex(AscW(Left(Selection, 1))) If Val("&H" & zL & "&") > 767 And Val("&H" & zL & "&") < 880 Then Set Rng0 = Selection.Range Set Rng2 = Rng0 Rng2.SetRange Start:=Rng2.Start - 1, End:=Rng2.End zL = Hex(AscW(Left(Rng2, 1))) ' Zeichen links davon gehört dazu. Rng2.Select Else Exit For End If Next i ' a2) Wenn rechts von der Markierung eins bis vier kombinierende diakritische Zeichen stehen: Set Rng0 = Selection.Range Set Rng2 = Rng0 For i = 1 To 4 Rng2.SetRange Start:=Rng2.Start, End:=Rng2.End + 1 zR = Hex(AscW(Right(Rng2, 1))) If Val("&H" & zR & "&") > 767 And Val("&H" & zR & "&") < 880 Then Rng2.Select Else Exit For End If Next i ' b) Wenn Surrogate für Unicode-Zeichen höherer Ebenen vorhanden sind: ' b1) Markierung nach rechts erweitern, wenn nur das linke Surrogat vorhanden ist: zR = Hex(AscW(Right(Selection, 1))) If Val("&H" & zR & "&") > 55295 And Val("&H" & zR & "&") < 56320 Then Set Rng0 = Selection.Range Set Rng2 = Rng0 Rng2.SetRange Start:=Rng2.Start, End:=Rng2.End + 1 ' Nur wenn das neue Zeichen das gesuchte rechte Surrogat ist, Markierung erweitern: zR = Hex(AscW(Right(Rng2, 1))) If Val("&H" & zR & "&") > 56319 And Val("&H" & zR & "&") < 57344 Then Rng2.Select End If End If ' b2) Markierung nach links erweitern, wenn nur das rechte Surrogat vorhanden ist: zL = Hex(AscW(Left(Selection, 1))) If Val("&H" & zL & "&") > 56319 And Val("&H" & zL & "&") < 57344 Then Set Rng0 = Selection.Range Set Rng2 = Rng0 Rng2.SetRange Start:=Rng2.Start - 1, End:=Rng2.End ' Nur wenn das neue Zeichen das gesuchte linke Surrogat ist, Markierung erweitern: zL = Hex(AscW(Left(Rng2, 1))) If Val("&H" & zL & "&") > 55295 And Val("&H" & zL & "&") < 56320 Then Rng2.Select End If End If ' *************** ' Durch "Autofokus" veränderte Länge des markierten Bereichs: N = Len(Selection) Set Rng0 = Selection.Range ' ************************************** ' Wenn die Markierung sichtbaren Feldcode mit den Feldsteuerzeichen enthält, ' Markierung auf den Text des Feldcodes (ohne die Steuerzeichen) einengen: Feldsteuerzeichen = False '' Undozähler = 0 Ergebnis1 = "" ' Text, der später ggf. den Feldcode enthalten soll. If InStr(Selection, ChrW(19)) > 0 And InStr(Selection, ChrW(21)) > 0 _ And Selection.Fields.Count > 0 Then ' Markierten Bereich einengen auf Feldfunktion ohne Steuerzeichen: Ergebnis1 = "Achtung, die Markierung enthielt Feldfunktionen (dezimale Codes 19 und 21, " _ & "auf dem Bildschirm als geschweifte Klammern angezeigt). " _ & "Im Folgenden wird nur die (erste) Feldcode-Anzeige analysiert:" & vbCrLf & vbCrLf Pos1 = InStr(Selection, ChrW(19)) Pos2 = InStr(Selection, ChrW(21)) Rng0.SetRange Start:=Rng0.Start + Pos1, End:=Rng0.Start + Pos2 - 1 Rng0.Select N = Len(Selection) End If ' ***************************************************************************************** ' Tabellensteuerzeichen und Feldfunktionen machen bei der Analyse per Einzel-Ranges Probleme. ' Deshalb erfolgt hier in einer separaten Zwischendatei ("doc2") die Umwandlung des markierten ' Tabellenbereichs in Text und (weiter unten) die Beseitigung von Feldfunktionen). ' ****************************************************************************************** ' Ergänzt 1. April 2011 bis 8. Mai 2011. ' Steuerzeichen von Tabellen und Feldfunktionen müssen vor der Analyse abgefangen werden: If InStr(Rng0, Chr(13) & Chr(7)) > 0 Or Selection.Fields.Count > 0 Then ' Die Markierung enthält Tabellensteuerzeichen oder Felder, die beseitigt werden müssen. ''''''''''''''''''''''''' ' Ergänzung März 2012, wegen Absturz des "Copy-Befehl" bei Tabellenreihen-Endmarke: '' If Len(Selection) <= 2 Then ' macht Probleme bei Seitenzahl in Positionsrahmen (9. 4. 2012). '' If Selection = Chr(13) & Chr(7) Then ' macht Problem bei Feld in Tabelle (13. April 2012) If Rng0 = Chr(13) & Chr(7) Then MsgBox "Es ist nur das Tabellen-Steuerzeichen (Code = 7) markiert." Exit Sub End If '''''''''''''''''''''''''''''' Selection.Copy Set doc1 = ActiveDocument Zwischendatei = True Application.ScreenUpdating = False ' Zwischendatei soll unsichtbar bleiben. Set doc2 = Documents.Add ' DocumentType:=wdNewBlankDocument Selection.WholeStory Selection.Paste Selection.WholeStory Selection.Range.HighlightColorIndex = wdNoHighlight Selection.Font.Color = wdColorAutomatic ' ' Vor der Umwandlung der Tabellen in doc2 alle Tabellen gelb markieren: For Each aTable In Selection.Tables aTable.Range.HighlightColorIndex = wdYellow Next aTable ' ' Echte Absatzmarken in Tabellen vorübergehend beseitigen: Selection.Find.ClearFormatting Selection.Find.Highlight = True Selection.Find.Replacement.ClearFormatting With Selection.Find .Text = "^p" .Replacement.Text = "" .Replacement.Font.Color = wdColorRed .Forward = True .Format = True .MatchCase = False .MatchWholeWord = False .MatchWildcards = False .MatchSoundsLike = False .MatchAllWordForms = False End With Selection.Find.Execute Replace:=wdReplaceAll ' ' Umwandlung der Tabellen in Text (ggf. mehrere kleine Tabellen): For Each aTable In Selection.Tables aTable.Rows.ConvertToText Separator:=ChrW(7) ' Tabellenfeld-Steuerzeichen. Next aTable Selection.WholeStory ' ' Absatzmarken in Tabellenzeilenschluss in doppeltes Tabellenfeldsteuerzeichen umwandeln: ' (dies entspricht dem Quellcode der Tabelle): Selection.Find.ClearFormatting Selection.Find.Highlight = True Selection.Find.Replacement.ClearFormatting With Selection.Find .Text = "^p" .Replacement.Text = ChrW(7) & ChrW(7) .Forward = True .Wrap = wdFindContinue .Format = True .MatchCase = False .MatchWholeWord = False .MatchWildcards = False .MatchSoundsLike = False .MatchAllWordForms = False End With Selection.Find.Execute Replace:=wdReplaceAll ' ' Absatzmarken in Tabellenfeldern wiederherstellen Selection.Find.ClearFormatting Selection.Find.Highlight = True With Selection.Find .Text = "" .Font.Color = wdColorRed .Replacement.Text = "^p" .Forward = True .Format = True .MatchCase = False .MatchWholeWord = False .MatchWildcards = False .MatchSoundsLike = False .MatchAllWordForms = False End With Selection.Find.Execute Replace:=wdReplaceAll ' ' Markierung in Hilfsdatei doc2 um letzte Absatzmarke verkürzen: Selection.WholeStory Set Rng0 = Selection.Range Rng0.SetRange Start:=Rng0.Start, End:=Rng0.End - 1 Rng0.Select ' ' Durch das Umwandeln einer Tabelle in Text änderte sich die Zahl der markierten Zeichen: N = Len(Selection) End If ' ************************************************************************** ' Feldfunktionen bei markierten Feldergebnissen in Zwischendatei beseitigen: ' ************************************************************************** ' Solange nur Feldergebnis sichtbar, werden Steuerzeichen von Feldern nicht gefunden: Application.ScreenUpdating = False '' ActiveDocument.UndoClear ' ab hier werden die Veränderungen rückgängig gemacht. Selection.Fields.ToggleShowCodes If InStr(Selection, ChrW(19)) > 0 And InStr(Selection, ChrW(21)) > 0 _ And Selection.Fields.Count > 0 Then ' Feldfunktion vorübergehend beseitigen, aber Feldfunktion speichern: Feldsteuerzeichen = True Ergebnis1 = Selection ' *************************** ' Durch Felder geschützte Formelzeichen für Analyse vorübergehend beseitigen (31. März 2011) ' wie zum Beispiel {SYMBOL 87 \f "Symbol" \s 10} oder {SYMBOL 937 \f "Arial" \s 10 \u}: If InStr(Selection, ChrW(19) & "SYMBOL") > 0 _ Or InStr(Selection, ChrW(19) & " SYMBOL") > 0 Then Ergebnis1 = "Achtung, die Markierung enthält Feldfunktionen (dezimale Codes 19 und 21) " _ & "mit einem oder mehreren geschützten Sonderzeichen;" _ & vbCrLf & vbCrLf & "Markierung in Feldcode-Ansicht: " _ & vbCrLf & Ergebnis1 & vbCrLf & vbCrLf _ & "Die Zeichenanalyse ergibt:" & vbCrLf With Selection.Find .ClearFormatting .Text = "^19Symbol" .Forward = True .Wrap = wdFindContinue ' es wird sonst nur ein Zeichen ersetzt! .Format = False .MatchCase = False .MatchWholeWord = False .MatchWildcards = False .MatchSoundsLike = False .MatchAllWordForms = False Do While .Execute ' solange etwas gefunden wird If InStr(Selection, "\f ") > 0 Then k1 = InStr(Selection, "\f ") + 4 ' Anfang des Schriftarts-Namen k2 = InStr(k1, Selection, " ") - 1 ' Ende des Schriftarts-Namen Selection.Font.Name = Mid(Selection, k1, k2 - k1) Selection.TypeText Text:=ChrW(Val(Mid(Selection, InStr(Selection, " ")))) '' Undozähler = Undozähler + 2 End If Loop End With ' Falls zwischen Feldanfang und dem Wort "Symbol" ein Leerzeichen ist: With Selection.Find .ClearFormatting .Text = "^19 Symbol" .Forward = True .Wrap = wdFindContinue ' es wird sonst nur ein Zeichen ersetzt! .Format = False .MatchCase = False .MatchWholeWord = False .MatchWildcards = False .MatchSoundsLike = False .MatchAllWordForms = False Do While .Execute ' solange etwas gefunden wird If InStr(Selection, "\f ") > 0 Then k1 = InStr(Selection, "\f ") + 4 ' Anfang des Schriftarts-Namen k2 = InStr(k1, Selection, " ") - 1 ' Ende des Schriftarts-Namen Selection.Font.Name = Mid(Selection, k1, k2 - k1) Selection.TypeText Text:=ChrW(Val(Mid(Selection, InStr(3, Selection, " ")))) '' Undozähler = Undozähler + 2 End If Loop End With Else Ergebnis1 = "Achtung, die Markierung enthält Feldfunktionen (dezimale Codes 19 und 21);" _ & vbCrLf & vbCrLf & "Markierung in Feldcode-Ansicht: " & vbCrLf & Ergebnis1 _ & vbCrLf & vbCrLf & "Die Zeichenanalyse ergibt:" & vbCrLf End If Rng0.Select ' ***************** Else ' keine Feld oder keine Feldsteuerzeichen in der Markierung: Rng0.Select End If Selection.Fields.ToggleShowCodes Application.ScreenUpdating = True If Feldsteuerzeichen = True Then Selection.Fields.Unlink End If ' ***************************************************************** ' Neuer Fehler entdeckt 2. November 2011: ' Bei dem Befehl "Overstrike" funktioniert der obige Unlink-Befehl nicht. ' Beseitigung durch Kopieren und als Inhalt wieder einfügen: If Selection.Fields.Count > 0 Then Dim F0 As Field Dim RngX As Range Set RngX = Selection.Range For Each F0 In RngX.Fields F0.Select Selection.Copy Selection.PasteSpecial Link:=False, DataType:=wdPasteText, _ Placement:=wdInLine, DisplayAsIcon:=False Next F0 Selection.WholeStory Selection.MoveEnd unit:=wdCharacter, Count:=-1 End If ' ****************************************************************** ' Analyse des markierten Bereichs (die eigentliche Zeichenanalyse) ' ****************************************************************** N = Len(Selection) ReDim Rg(N) ReDim x(N) ReDim y(N) ReDim z(N) ReDim f(N) ReDim Windowssonderschrift(N) ' Bestimmung der Schriftart des markierten Bereichs "f(0)": f(0) = Selection.Font.Name ' Wenn die Schriftart-Anzeige leer ist, ist sie unterschiedlich: If f(0) = "" Then f(0) = "unterschiedlich" End If ' For i = 1 To N Windowssonderschrift(i) = False Set Rg(i) = Selection.Range Rg(i).SetRange Start:=Rg(i).Start + i - 1, End:=Rg(i).Start + i f(i) = Rg(i).Font.Name x(i) = Rg(i).Text ' y(i) = AscW(x(i)) ' Ergibt negative Zahlen bei x(i) > 32'767! ' z(i) = Hex(y(i)) ' Da bei VBA das Integerformat nur bis + 32767 reicht, muss durch einen Umweg ' für den Dezimalcode (y) der Typ "Long" erzwungen werden. z(i) = Hex(AscW(x(i))) y(i) = Val("&H" & z(i) & "&") ' Der Hexadezimale Unicode wird in der Regel vierstellig angegeben: Select Case Len(z(i)) Case Is = 3 z(i) = "0" & z(i) Case Is = 2 z(i) = "00" & z(i) Case Is = 1 z(i) = "000" & z(i) End Select ' Steuerzeichen sollen im Ergebnis erklärt, aber nicht dargestellt werden: If y(i) <= 32 Then Select Case y(i) Case 32 x(i) = """Leerzeichen""" Case 31 x(i) = """Bedingter Trennstrich""" Case 30 x(i) = """Geschützter Bindestrich""" Case 13 x(i) = """Absatzzeichen""" Case 11 x(i) = """manueller Zeilenumbruch""" Case 12 x(i) = """manueller Seitenumbruch""" Case 9 x(i) = """Tabulator""" Case 1 x(i) = """Steuerzeichen für Bild oder Formel-Editor-Objekt""" Case 7 x(i) = """Tabellenfeld-Steuerzeichen""" Case Else x(i) = """Steuerzeichen""" End Select ' Bei Windows-Sonderschriften gelten völlig andere Regeln: ElseIf x(i) = "(" Or x(i) Like "[" & ChrW(61472) & "-" & ChrW(61695) & "]" Then Rg(i).Select With Dialogs(wdDialogInsertSymbol) fs = .Font Zeichennummer1 = .CharNum End With '' If fs <> "(normaler Text)" And fs <> "" Then '' If Zeichennummer1 < 0 Then If fs <> "(normaler Text)" And fs <> "" _ Or Zeichennummer1 < 0 And x(i) = "(" Then Windowssonderschrift(i) = True f(i) = fs y(i) = (Zeichennummer1 + 4096 + 61440) z(i) = Hex(y(i)) x(i) = ChrW(Zeichennummer1 + 4096 + 61440) End If Rng0.Select End If ' einige weitere nicht-Unicode-kompatible Schriftarten: If f(i) = "BSsymb9" Or f(i) = "BeuthPi2" Then x(i) = "Sonderschriftzeichen" End If If f(i) <> f(0) Then f(0) = "unterschiedlich" Next i ' **************************************** ' Ggf. Zwischendatei wieder schließen: ' **************************************** '''' Wurden Feldfunktionen oben beseitigt, müssen sie jetzt wieder hergestellt werden: ''' If Undozähler <> 0 Then ''' ActiveDocument.Undo Undozähler ''' End If ''' If Feldsteuerzeichen = True Then ''' ActiveDocument.Undo ''' Rng0.Select ''' '' Selection.Fields.ToggleShowCodes ''' End If ' ' Bei Tabellenanalyse in separater Datei muss diese geschlossen werden. If Zwischendatei = True Then doc2.Close (wdDoNotSaveChanges) doc1.Activate Application.ScreenUpdating = True End If ' ************************************************** ' Ergebniszusammenstellung für Messagebox: ' ************************************************** Ergebnis = Ergebnis1 & "Schriftart: " & f(0) For j = 1 To N If y(j) > 55295 And y(j) < 57344 Then ' Zeichen höherer Unicode-Ebene: If N > j And y(j) > 55295 And y(j) < 56320 Then If y(j + 1) > 56319 And y(j + 1) < 57344 Then ' Wenn ja, liegt Zeichen höherer Unicode-Ebene vor: ' Berechnung des Unicodes höherer Ebenen nach ISO 10646:2003, Anhang C: y(0) = ((y(j) - 55296) * 1024) + (y(j + 1) - 56320) + 65536 z(0) = Hex(y(0)) ' z(0) ist der Unicode des gesuchten Zeichen höherer Unicode-Ebene. Ergebnis = Ergebnis & "," & vbCrLf _ & "der Unicode des Zeichens höherer Ebene ist hexadezimal: " & z(0) _ & " und dezimal: " & y(0) j = j + 1 Else Ergebnis = Ergebnis & ", " & vbCrLf & "der Unicode von " & x(j) _ & " ist hexadezimal: " & z(j) & " und dezimal: " & y(j) _ & vbCrLf & " (unvollständiges Surrogat)" End If Else Ergebnis = Ergebnis & ", " & vbCrLf & "der Unicode von " & x(j) _ & " ist hexadezimal: " & z(j) & " und dezimal: " & y(j) _ & vbCrLf & " (unvollständiges Surrogat)" End If ElseIf Windowssonderschrift(j) = True Then ' Windows-Sonderzeichen: Ergebnis = Ergebnis & ", " & vbCrLf & "der Code von " & x(j) _ & " ist hexadezimal: " & Hex(y(j) - 61440) & "/" & Hex(y(j)) & " und dezimal: " _ & ((y(j) - 61440)) & "/" & y(j) & ", Schriftart: " & f(j) '' If f(j) = "Symbol" Then If f(j) = "Symbol" Or f(j) = "SymbolPS" Then Ergebnis = Ergebnis & "," & vbCrLf _ & " das entsprechende Unicode-Zeichen ist " _ & Symbolname(Hex(y(j) - 61440)) ElseIf f(j) = "Wingdings" Then ' (im März 2011 neu ergänzt) Ergebnis = Ergebnis & "," & vbCrLf _ & " Bedeutung: " & Wingdingsname(Hex(y(j) - 61440)) End If Else ' normales Unicode-Zeichen: ' Bei Dezimalcodes bis 255 wird bei Windows eine "0" davorgesetzt: If y(j) < 256 Then y(j) = "0" & y(j) End If If y(j) = 160 Then x(j) = """Festes Leerzeichen""" Ergebnis = Ergebnis & ", " & vbCrLf & "der Unicode von " & x(j) _ & " ist hexadezimal: " & z(j) & " und dezimal: " & y(j) End If Next j Ergebnis = Ergebnis & "." ' ' ***************************** ' Ergebnisanzeige in Messagebox mit Abfrage, ob Ergebnis in separater Datei gewünscht: MsgBoxAnzeige = Ergebnis & vbCrLf & vbCrLf _ & "Wollen Sie das Ergebnis ausführlicher in einer separaten Datei?" Abfrage = MessageBoxW(0, StrPtr(MsgBoxAnzeige), StrPtr("Zeichenanalyse"), _ vbYesNoCancel + vbDefaultButton2) ' Alternative einfache Funktion, wenn keine Windows-Umgebung, leider ohne Unicode: ' Abfrage = MsgBox(MsgBoxAnzeige, vbYesNoCancel + vbDefaultButton2, "Zeichenanalyse") ' Bei "Ja" kommt "6" heraus, bei "Nein" kommt "7" heraus, bei Abbrechen eine "2". ' If Abfrage <> 6 Then ' Speicher löschen und Programm beenden. GoTo Zeile_Suchverzeichnis_löschen_und_beenden End If ' ********************************************************************** ' Wenn "ja" (Abfrage = 6), ausführlichere Ergebnisanzeige in Extra-Datei: Selection.Copy ' ********************************************************************* ' Zeitmessen für die Makro-Dauer Dim Zeit1, Zeit2, Zeitdauer Zeit1 = Timer ' ************************** ' Zur Bestimmung des Unicode-Namens Unicodeliste öffnen: ' Das Makro braucht zum Nachschlagen des Unicode-Zeichennamens ' im Internet unter "http://unicode.org/Public/UNIDATA/UnicodeData.txt" ' (zumindest beim ersten Mal) mindestens 6 Sekunden. Von daher ist es ' besser, diese Datei (von Hand) vorher auf der Festplatte zu speichern. ' Dann beträgt die Dauer weniger als 1,2 Sekunden. ' Auf ein automatisches Speichern per Makro habe ich bewusst verzichtet. ' Application.StatusBar = "Bitte warten - das Makro läuft." Application.ScreenUpdating = False ' Pfad1 = Options.DefaultFilePath(wdUserTemplatesPath) ' Pfad1 = ActiveDocument.Path ' Alternativer Pfad für die Unicode-Liste. Unicodeliste1 = Pfad1 & "\UnicodeData.txt" ' ' Wenn die Unicodeliste nicht auf der Festplatte vorhanden ist, im Internet nachsehen: If Dir(Unicodeliste1) = "" Then ' Bei fehlendem Internetzugang gibt es eine Fehlermeldung: On Error GoTo Zeile_Internetzugang_fehlt Documents.Open FileName:= _ "http://unicode.org/Public/UNIDATA/UnicodeData.txt", _ ConfirmConversions:=False, ReadOnly:=True, AddToRecentFiles:=False, _ PasswordDocument:="", PasswordTemplate:="", Revert:=False, _ WritePasswordDocument:="", WritePasswordTemplate:="", _ Format:=wdOpenFormatAuto, Encoding:=1252 Else ' Unicodeliste ist vorhanden (im Ordner mit den ".dot"-Dateien). Datei öffnen: Documents.Open FileName:=Unicodeliste1, _ ConfirmConversions:=False, ReadOnly:=True, AddToRecentFiles:=False, _ PasswordDocument:="", PasswordTemplate:="", Revert:=False, _ WritePasswordDocument:="", WritePasswordTemplate:="", _ Format:=wdOpenFormatAuto, Encoding:=1252 End If ' On Error GoTo 0 ' Zum Beschleunigung beim Suchen in der Datei "UnicodeData.txt": ActiveWindow.View.Type = wdNormalView ' ' ********************************************************* ' Ausführlichere Ergebniszusammenstellung für Ausgabe in Datei: ' ******************************************************** Ergebnis = Ergebnis1 For j = 1 To N If y(j) > 55295 And y(j) < 57344 Then ' Zeichen höherer Unicode-Ebene If N > j And y(j) > 55295 And y(j) < 56320 Then If y(j + 1) > 56319 And y(j + 1) < 57344 Then ' Wenn ja, liegt Zeichen höherer Unicode-Ebene vor: ' Berechnung des Unicodes höherer Ebenen nach ISO 10646:2003, Anhang C: y(0) = ((y(j) - 55296) * 1024) + (y(j + 1) - 56320) + 65536 z(0) = Hex(y(0)) ' z(0) ist der Unicode des gesuchten Zeichen höherer Unicode-Ebene. x(j) = x(j) & x(j + 1) Ergebnis = Ergebnis _ & "Der Unicode des Zeichens höherer Ebene x(" & j _ & ") ist hexadezimal: " & z(0) & " und dezimal: " & y(0) & "," & Chr(11) _ & "(der Unicode des Surrogat 1 ist hexadezimal: " & z(j) _ & " und dezimal: " & y(j) & ", " & Chr(11) _ & "der Unicode des Surrogat 2 ist hexadezimal: " & z(j + 1) _ & " und dezimal: " & y(j + 1) & "), " & Chr(11) _ & EnglischName(z(0)) & ", " & Chr(11) _ & "die Schriftart ist " & f(j) & ". " & vbCrLf j = j + 1 Else Ergebnis = Ergebnis & "der Unicode von x(" & j _ & ") ist hexadezimal: " & z(j) & " und dezimal: " & y(j) _ & Chr(11) & "(unvollständiges Surrogat)" & ". " & vbCrLf End If Else Ergebnis = Ergebnis & "Der Unicode von x(" & j _ & ") ist hexadezimal: " & z(j) & " und dezimal: " & y(j) _ & Chr(11) & "(unvollständiges Surrogat)" & ". " & vbCrLf End If ElseIf Windowssonderschrift(j) = True Then ' Windowssonderschriftzeichen: Ergebnis = Ergebnis & "Der Code von x(" & j _ & ") ist hexadezimal: " & Hex(y(j) - 61440) & "/" & Hex(y(j)) & " und dezimal: " _ & ((y(j) - 61440)) & "/" & y(j) & ", Schriftart: " & f(j) ' If f(j) = "Symbol" Then If f(j) = "Symbol" Or f(j) = "SymbolPS" Then Ergebnis = Ergebnis & "," & vbCrLf _ & " das entsprechende Unicode-Zeichen ist " _ & Symbolname(Hex(y(j) - 61440)) & ". " & vbCrLf ElseIf f(j) = "Wingdings" Then ' (im März 2011 neu ergänzt) Ergebnis = Ergebnis & "," & vbCrLf _ & " Bedeutung: " & Wingdingsname(Hex(y(j) - 61440)) & ". " & vbCrLf Else Ergebnis = Ergebnis & ". " & vbCrLf End If ElseIf f(j) = "BSsymb9" Or f(j) = "BeuthPi2" Then ' Sonderschrift-Zeichen (hier eventuell weitere Sonderschriftarten aufnehmen): Ergebnis = Ergebnis & "Der Code des Sonderzeichens " _ & "ist hexadezimal: " & z(j) & " und dezimal: " & y(j) & ", " _ & "Schriftart:" & Chr(160) & f(j) & ". " & vbCrLf ElseIf y(j) < 32 Then ' Steuerzeichen (ohne englischen Zeichennamen und ohne Schriftart): Ergebnis = Ergebnis & "Der Unicode von x(" & j _ & ") ist hexadezimal: " & z(j) & " und dezimal: " & y(j) & ". " & vbCrLf Else ' normales Unicode-Zeichen: Ergebnis = Ergebnis & "Der Unicode von x(" & j _ & ") ist hexadezimal: " & z(j) & " und dezimal: " & y(j) & ", " _ & "Schriftart:" & Chr(160) & f(j) & ", " & EnglischName(z(j)) & ". " & vbCrLf End If Next j ' **************************************** ' Unicode-Liste schließen: ActiveDocument.Close SaveChanges:=False ' **************************************** ' Anzeige in separater Datei: ' **************************************** Documents.Add DocumentType:=wdNewBlankDocument ' falls in der Normal.dot schon Name und Datum vorgesehen waren: ActiveWindow.View.Type = wdPrintView Selection.WholeStory ' Absatzabstand auf Null stellen: With Selection.ParagraphFormat .Alignment = wdAlignParagraphLeft .LeftIndent = CentimetersToPoints(0.5) .FirstLineIndent = CentimetersToPoints(-0.5) .SpaceBefore = 0 .SpaceAfter = 0 .SpaceAfterAuto = False .Alignment = wdAlignParagraphLeft End With Selection.Font.Size = 11 ' If Val(y(1)) < 30 And N < 3 Then Selection.TypeText Text:="Das markierte Zeichen bzw. die Zeichenfolge setzt sich " _ & "wie folgt zusammen:" & vbCrLf Selection.TypeText Text:=Ergebnis Else Selection.TypeText Text:="Das markierte Zeichen bzw. die Zeichenfolge " ' Das Zeichen muss mitsamt seiner Schriftart eingefügt werden. ' Und danach muss wieder die Ausgangsschrift usw. wiederhergestellt werden. ' Dies gelang mir über den kleinen Umweg des nachträglichen Einfügens: Set rng1 = Selection.Range Selection.TypeText Text:=vbCrLf & "setzt sich wie folgt zusammen:" & vbCrLf & vbCrLf Selection.TypeText Text:=Ergebnis Set Rng2 = Selection.Range rng1.Select Selection.Paste rng1.SetRange Start:=rng1.Start, End:=Selection.End rng1.Select Selection.Range.HighlightColorIndex = wdYellow Rng2.Select ' Falls in "Ergebnis" Hyperlinks, diese alle aktivieren: Selection.HomeKey unit:=wdStory Selection.Find.ClearFormatting With Selection.Find .Text = "http://www.unicode.org/charts/PDF/U*.pdf" .Replacement.Text = "" .Forward = True ' .Wrap = wdFindContinue (führt zu Endlosschleife!) .Format = True .MatchCase = False .MatchWholeWord = False .MatchAllWordForms = False .MatchSoundsLike = False .MatchWildcards = True Do While .Execute ActiveDocument.Hyperlinks.Add Anchor:=Selection.Range, _ Address:=Selection.Range.Text, _ SubAddress:="", ScreenTip:="", TextToDisplay:=Rng2.Text Selection.Collapse Direction:=wdCollapseEnd Loop End With Selection.EndKey unit:=wdStory End If ' **************** ' Die Original-Zeichen sollen mitsamt ihrer Schriftart dargestellt und markiert werden, ' außer wenn sie bereits durch eine Beschreibung ersetzt worden sind: For j = 1 To N Selection.HomeKey unit:=wdStory Selection.Find.ClearFormatting Selection.Find.Replacement.ClearFormatting With Selection.Find .Text = "x(" & j & ")" .Forward = True .Format = True .MatchCase = False .MatchWholeWord = False .MatchWildcards = False .MatchSoundsLike = False .MatchAllWordForms = False Do While .Execute If Len(x(j)) < 3 Then Selection.Font.Name = f(j) Selection.Range.HighlightColorIndex = wdYellow Selection.Font.Bold = True Selection.TypeText Text:=x(j) Else Selection.Font.Name = "Times New Roman" Selection.Range.HighlightColorIndex = wdYellow Selection.Font.Bold = True Selection.Text = x(j) End If Loop End With Next j ' ************************* Selection.EndKey unit:=wdStory Selection.TypeParagraph ' Selection.TypeText Text:= _ "Die englischen Namen aller Unicode-Schriftzeichen sind in ISO/IEC 10646 genormt " _ & " und weitgehend in " ActiveDocument.Hyperlinks.Add Anchor:=Selection.Range, _ Address:="http://unicode.org/Public/UNIDATA/UnicodeData.txt", SubAddress:="", _ ScreenTip:="", TextToDisplay:="http://unicode.org/Public/UNIDATA/UnicodeData.txt" Selection.TypeText Text:=Chr(11) & "oder über " ActiveDocument.Hyperlinks.Add Anchor:=Selection.Range, _ Address:="http://www.unicode.org/charts", SubAddress:="", _ ScreenTip:="", TextToDisplay:="http://www.unicode.org/charts" Selection.TypeText Text:=" zu finden." Selection.TypeParagraph ' Ergänzung 03.04.2011 Selection.Find.ClearFormatting Selection.Find.Replacement.ClearFormatting With Selection.Find .Text = "Times New Roman" .Replacement.Text = "Times^sNew^sRoman" .Forward = True .Wrap = wdFindContinue .Format = False .MatchCase = False .MatchWholeWord = False .MatchWildcards = False .MatchSoundsLike = False .MatchAllWordForms = False End With Selection.Find.Execute Replace:=wdReplaceAll ' ************************ ' Bildschirm wieder anstellen: Application.ScreenUpdating = True ' **************************************************************** ' Zeitmessen für die Makro-Dauer auf drei Stellen hinter dem Komma Zeit2 = Timer Zeitdauer = Format((Zeit2 - Zeit1), "##,##0.000") Selection.TypeParagraph Selection.TypeText Text:="Die Rechenzeit war " & Zeitdauer & " Sekunden." Selection.HomeKey unit:=wdStory ' An den Anfang des Ergebnisses gehen. ' *************************************************** ' Zwischenspeicher aufräumen und alles zurückstellen: Zeile_Suchverzeichnis_löschen_und_beenden: ' *************************************************** ' Im Suchen/Ersetzen-Menü alles zurückstellen Selection.Find.ClearFormatting Selection.Find.Replacement.ClearFormatting With Selection.Find .Text = "" .Replacement.Text = "" .Forward = True .Wrap = wdFindContinue .Format = False .MatchCase = False .MatchWholeWord = False .MatchWildcards = False .MatchSoundsLike = False .MatchAllWordForms = False End With ' Ansicht zurückstellen: If Unsichtbares_zeigen = True Then ActiveWindow.View.ShowAll = False End If Exit Sub ' **************************************** Zeile_Internetzugang_fehlt: MsgBox "Bitte aus dem Internet die Datei " _ & """http://unicode.org/Public/UNIDATA/UnicodeData.txt""" _ & " auf der Festplatte " & vbCrLf & "unter """ & Pfad1 & """ speichern" _ & " oder wenigstens einen Internet-Zugang herstellen." End Sub ' ----------------------------------------------------------------------------