REM ***** BASIC ***** option Explicit Global allChars as String Global cursor as Object ' Formatieren von Urig Texten in OpenOffice ' Fuehren Sie das Makro FormatUrig aus, am besten aus der Entwicklungsumgebung ' Achtung: es hat sehr lange, haben Sie Geduld und editieren sie nicht weiter! ' Achtung: es funktioniert nicht mit Urig Blockschrift! Sub FormatUrig Dim i as Long Dim stext as String Dim prevChar as String Dim char as String Dim nextChar as String Dim newChar as String cursor = Thiscomponent.text.createtextcursor() stext = GetText allChars = AllUrigLetters 'msgbox stext prevChar = GetUrigChar(-1) char = GetUrigChar(0) for i = 0 to Len(stext)-1 nextChar = GetUrigChar(i+1) if char <> "" then if UrigConnectsRight(prevChar) then if UrigConnectsLeft(nextChar) then newChar = MedialChar(char) else newChar = FinalChar(char) endif else if UrigConnectsLeft(nextChar) then if UrigConnectsRight(prevChar) then newChar = MedialChar(char) else newChar = InitialChar(char) endif else newChar = SingelChar(char) endif endif ReplaceCharacter(i, char, newChar) char = newChar endif prevChar = char char = nextChar next i End Sub Sub UnFormatUrig Dim i as Long Dim stext as String Dim char as String cursor = Thiscomponent.text.createtextcursor() stext = GetText allChars = AllUrigLetters for i = 0 to Len(stext)-1 char = GetUrigChar(i) if char <> "" then ReplaceCharacter(i, char, MedialChar(char)) endif next i End Sub Sub UrigToLatin Dim i as Long Dim stext as String Dim char as String cursor = Thiscomponent.text.createtextcursor() stext = GetText allChars = AllUrigLetters for i = 0 to Len(stext) + 200 char = GetUrigChar(i) if char <> "" then ReplaceUrigWithLatin(i, char, MedialChar(char)) endif next i End Sub Sub ReplaceUrigWithLatin(pos as Integer, oldChar as String, newChar as String) select case newChar case "j" newChar = "sch" case "c" newChar = "ch" case "v" newChar = "ng" case "E" newChar = "e" case "Ä" newChar = "e" case "O" newChar = "o" case "Ö" newChar = "ö" end select cursor.gotoStart(false) cursor.goRight(pos, false) cursor.goRight(1, true) cursor.CharFontName = "Arial" Thiscomponent.text.insertString(cursor, newChar, true) End Sub Function IsUrigChar(char as String) as Boolean IsUrigChar = (InStr(allChars, char) > 0) End Function Function UrigConnectsLeft(char as String) as Boolean if char = "" then UrigConnectsLeft = false else UrigConnectsLeft = true endif End Function Function UrigConnectsRight(char as String) as Boolean if char = "" then UrigConnectsRight = false else UrigConnectsRight = true endif End Function Function GetText as String cursor.gotoStart(false) cursor.gotoEnd(true) GetText = cursor.String End Function Function GetUrigChar(pos as Long) as String GetUrigChar = "" if pos >= 0 then cursor.gotoStart(false) cursor.goRight(pos, false) if cursor.goRight(1, true) then if (cursor.CharFontName = "Urig" or cursor.CharFontName = "UrigLinear") and IsUrigChar(cursor.String) then GetUrigChar = cursor.String endif endif endif End Function Sub ReplaceCharacter(pos as Integer, oldChar as String, newChar as String) if oldChar <> newChar then cursor.gotoStart(false) cursor.goRight(pos + 1, false) Thiscomponent.text.insertString(cursor, newChar, false) cursor.gotoStart(false) cursor.goRight(pos, false) cursor.goRight(1, true) Thiscomponent.text.insertString(cursor, "", true) ' the following simple version does not work for mixed fonts, because of a formating bug ' in openoffice 'cursor.goRight(pos, false) 'cursor.goRight(1, true) 'doctext.insertString(cursor, newChar, true) endif End Sub Function AllUrigLetters() as String Dim letters as String Dim all as String Dim i as integer Dim c as String letters = "jsnvgkchdtbpmwrlfeEisaäÄoOöÖuü" all = "" for i = 1 to Len(letters) c = Mid(letters, i, 1) all = all + c + InitialChar(c) + FinalChar(c) + SingelChar(c) next i AllUrigLetters = all End Function Function InitialChar(char as String) as String InitialChar = CodeChar(char, &HEA00) End Function Function MedialChar(char as String) as String MedialChar = CodeChar(char, &H0000) End Function Function FinalChar(char as String) as String FinalChar = CodeChar(char, &HEE00) End Function Function SingelChar(char as String) as String SingelChar = CodeChar(char, &HEC00) End Function Function CodeChar(char as String, codeRange as long) as String Dim unicode as long unicode = Asc(char) MOD &H100 CodeChar = Chr(codeRange + unicode) End Function