Sub GerFx()
Rem *----*----* *----*----* *----*----* *----*----*
Rem ドイツ語代用文字範囲内置換処理
Rem 作譜：Hitrock Camellia Shinopy
Rem 言語：Word VBA
Rem 機能...
Rem ドイツ語代用文字を正書文字に置換する。
Rem ドイツ語正書文字を代用文字に置換する。
Rem 注記...
Rem 「GerFx」を起動して、ツールバーを追加し、コマンドボタンを押して、処理を実行する｡
Rem 不具合あり。
Rem GerFxSuff実行後に、カーソル位置が選択範囲の末尾より1〜2文字分左になることがある。
Rem 履歴...
Rem 第1版：2004/12/28：作成。
Rem （...）
Rem 第10版：2007/01/22：Word2007以降に対応するため、バルーン表示を廃止。ツールバー表示に変更。
Rem 第11版：2007/01/25：[^代用表記]処理を追加。
Rem *----*----* *----*----* *----*----* *----*----*
Dim myTitle As String
Dim myBoolean As Boolean
Rem *----*----* *----*----* *----*----* *----*----*
'
Rem 既定値の設定
myTitle = "GerFx"
myBoolean = True ' アプリケーションの終了時に自動的にツールバー削除する。
Rem *----*----* *----*----* *----*----* *----*----*
'
Rem 同名ツールバーの削除
On Error Resume Next
CommandBars(myTitle).Delete
On Error GoTo 0
'
Rem ステータスバーの表示
Application.DisplayStatusBar = True
'
Call GerFxBlln(myTitle, myBoolean)
End Sub ' GerFx *----*----* *----*----* *----*----* *----*----*
Sub GerFxBlln(myTitle As String, myBoolean As Boolean)
Rem *----*----* *----*----* *----*----* *----*----*
Rem ツールバー表示処理
Rem *----*----* *----*----* *----*----* *----*----*
Dim myCmmdBar As CommandBar
Dim myCtrlBttn As CommandBarControl
Dim myCtrlCboxItem As CommandBarControl
Rem *----*----* *----*----* *----*----* *----*----*
'
Set myCmmdBar = CommandBars.Add(Name:=myTitle, Position:=msoBarTop, Temporary:=myBoolean)
Set myCtrlBttn = myCmmdBar.Controls.Add(Type:=msoControlButton, Before:=1, Temporary:=myBoolean)
Set myCtrlCboxItem = myCmmdBar.Controls.Add(Type:=msoControlComboBox, Before:=2, Temporary:=myBoolean)
Rem *----*----* *----*----* *----*----* *----*----*
'
With myCtrlBttn
.DescriptionText = "ドイツ語 代用文字 範囲内置換：選択した処理を実行します。"
.Style = msoButtonIcon
.Caption = myTitle
.TooltipText = "実行！"
.FaceId = 1611
.OnAction = "GerFxBttn"
End With
'
With myCtrlCboxItem
.DescriptionText = "実行する処理を選択します。"
.Style = msoComboNormal
.Caption = "処理"
'
.AddItem "AOUe/ss記法", 1
.AddItem "^記法", 2
.AddItem "&;記法", 3
.AddItem "===========", 4
.AddItem "AOUe/ss代用表記", 5
.AddItem "^代用表記", 6
.AddItem "&;代用表記", 7
'
.ListIndex = 1
.TooltipText = "AOUe/ss記法"
.DropDownLines = 11
.DropDownWidth = 200
.OnAction = "GerFxCboxItem"
End With
'
myCmmdBar.Visible = True
End Sub ' GerFxBlln *----*----* *----*----* *----*----* *----*----*
Sub GerFxCboxItem(Optional myDummy As Boolean)
Rem *----*----* *----*----* *----*----* *----*----*
Rem [処理]コンボボックス処理
Rem *----*----* *----*----* *----*----* *----*----*
With CommandBars("GerFx").Controls(2)
If .Text = "===========" Then
.TooltipText = "処理が未選択です。"
Else
If .Text = "&;記法" Or .Text = "&;代用表記" Then
.TooltipText = "&" & .Text
Else
.TooltipText = .Text
End If
End If
End With
End Sub ' GerFxCboxItem *----*----* *----*----* *----*----* *----*----*
Sub GerFxBttn(Optional myDummy As Boolean)
Rem *----*----* *----*----* *----*----* *----*----*
Rem 各ボタン処理
Rem *----*----* *----*----* *----*----* *----*----*
Dim myTitle As String
Dim myBttn As Long
Dim myLabel As String
Dim c As Long
Rem *----*----* *----*----* *----*----* *----*----*
'
myTitle = "GerFx"
'
With CommandBars(myTitle).Controls(2)
myLabel = .Text
myBttn = .ListIndex
End With
Rem *----*----* *----*----* *----*----* *----*----*
'
Select Case myBttn
Case 0, 4
GoTo GerFxBttnSubExit
End Select
Rem *----*----* *----*----* *----*----* *----*----*
'
Application.ScreenUpdating = False
'
If Selection.Range.Text = "" Then
c = Selection.MoveUp(wdParagraph, 1, wdExtend)
If c = 0 Then
GoTo GerFxBttnSubExit
End If
End If
Rem *----*----* *----*----* *----*----* *----*----*
'
GerFxBttnSubEntry:
Select Case myBttn
Case 1
Call GerFxSffx("e")
Case 2
Call GerFxSffx("^")
Case 3
Call GerFxUcs2
Case 5
Call GerFxSuff("e")
Case 6
Call GerFxSuff("^")
Case 7
Call GerFxSuff("")
End Select
Rem *----*----* *----*----* *----*----* *----*----*
'
GerFxBttnSubExit:
Selection.Collapse wdCollapseEnd
'
Rem 続けて処理する場合に備える。
CommandBars(myTitle).Enabled = False
CommandBars(myTitle).Enabled = True
'
Application.ScreenUpdating = True
'
Select Case myBttn
Case 1 To 3, 5 To 7
Application.StatusBar = myTitle & "：" & "処理完了！" & "[ " & myLabel & " ]"
End Select
End Sub ' GerFxBttn *----*----* *----*----* *----*----* *----*----*
Sub GerFxSffx(mySffx As String)
Rem *----*----* *----*----* *----*----* *----*----*
Rem 各接尾字記法処理
Rem mySffxの値...
Rem 「^」の場合：^接尾字の文字列を置換する。
Rem 「x」の場合：^接尾字とx接尾字ともに文字列を置換する。
Rem 「e」の場合：^接尾字とe接尾字・ssともに文字列を置換する。
Rem 注記...
Rem 参照設定する場合：Microsoft VBScript Regular Expressions 5.5
Rem *----*----* *----*----* *----*----* *----*----*
'
If Selection.Range.Characters.Count < 2 Then Exit Sub
'
Dim myCursor As Long
Dim c As Long
'
Dim myRange As Range
Dim myChrs As Characters
Dim myChrsFound As Characters
Dim myText As String
Dim myLen As Long
'
Dim myRegExp As Variant ' VBScript_RegExp_55.RegExp
Dim myMatches As Variant ' MatchCollection
Dim myMatch As Variant ' Match
Dim myPttn As String
'
Set myRegExp = CreateObject("VBScript.RegExp") ' New VBScript_RegExp_55.RegExp
Set myRange = Selection.Range
Set myChrs = myRange.Characters
Selection.Collapse wdCollapseStart
'
Rem パターンを設定
Select Case mySffx
Case "x"
myPttn = "([AEIOUaeiou]{1,1}[\_]{1,1})|([AOUaous]{1,1}[x\^]{1,1})"
Case "^"
myPttn = "([AEIOUaeiou]{1,1}[\_]{1,1})|([AOUaous]{1,1}[\^]{1,1})"
Case "e"
myPttn = "([AEIOUaeiou]{1,1}[\_]{1,1})|([AOUaou]{1,1}[e\^]{1,1})|(s\^)|(ss)"
End Select
'
With myRegExp
.Pattern = myPttn ' パターンを指定
.IgnoreCase = False ' 大文字小文字を区別する。
.Global = True ' 文字列全体を検索
End With
Set myMatches = myRegExp.Execute(myRange.Text)
'
For Each myMatch In myMatches
With Selection.Find
.ClearFormatting
.Text = myMatch.Value
.Forward = True
.Wrap = wdFindStop
.MatchCase = True
.MatchAllWordForms = False
.MatchSoundsLike = False
.MatchFuzzy = False
.MatchWildcards = False
.Execute
End With
'
Set myChrsFound = Selection.Range.Characters
myText = myChrsFound.Parent.Text
myLen = Len(myText)
'
Select Case myChrsFound.First.Next.Text
Case "^"
Select Case myChrsFound.First.Text
Case "A", "O", "U", "a", "o", "u", "s"
Call GerFxAous("", "^", myText)
End Select
Case "x"
Select Case myChrsFound.First.Text
Case "A", "O", "U", "a", "o", "u", "s"
Call GerFxAous("", "x", myText)
End Select
Case "e"
Select Case myChrsFound.First.Text
Case "A", "O", "U", "a", "o", "u"
Call GerFxAous("", "e", myText)
End Select
Case "s"
Select Case myChrsFound.First.Text
Case "s"
Call GerFxAous("", "e", myText)
End Select
Case "_"
Select Case myChrsFound.First.Text
Case "A", "E", "I", "O", "U", "a", "e", "i", "o", "u"
Call GerFxAeiou("", "_", myText)
End Select
End Select
'
If myLen <> Len(myText) Then
Rem 置換する文字列があった場合。
myChrsFound.First.Text = myText
myChrsFound.First.Next.Text = ""
End If
'
myCursor = myChrsFound.First.Start - myChrs.First.Start + 1
c = myCursor * 100 \ myChrs.Count
Application.StatusBar = "GerFx" & "：処理中" & " " & Format(c, "##0") & "%"
Next ' myMatch
'
myRange.Select ' 当初の選択範囲。
Selection.Collapse wdCollapseEnd
'
Set myRegExp = Nothing
Set myMatches = Nothing
'
Set myRange = Nothing
Set myChrs = Nothing
Set myChrsFound = Nothing
End Sub ' GerFxSffx *----*----* *----*----* *----*----* *----*----*
Sub GerFxUcs2(Optional myDummy As Boolean)
Rem *----*----* *----*----* *----*----* *----*----*
Rem &;記法処理
Rem 「&〜;」（UCS_2十進符号表記）を検索し、文字列を置換する。
Rem 注記...
Rem 参照設定する場合：Microsoft VBScript Regular Expressions 5.5
Rem *----*----* *----*----* *----*----* *----*----*
'
If Selection.Range.Characters.Count < 3 Then Exit Sub
'
Dim i As Long
Dim j As Long
Dim c As Long
'
Dim myRange As Range
Dim myChrsFound As Characters
Dim myText As String
Dim myLen As Long
'
Dim myRegExp As Variant ' VBScript_RegExp_55.RegExp
Dim myMatches As Variant ' MatchCollection
Dim myMatch As Variant ' Match
'
Set myRegExp = CreateObject("VBScript.RegExp") ' New VBScript_RegExp_55.RegExp
Set myRange = Selection.Range
Selection.Collapse wdCollapseStart
'
GerFxUcs2SubEntry:
With myRegExp
.Pattern = "\&{1}[\#A-Za-z0-9]{1,10}\;{1}" ' 「&〜;」を指定。
.IgnoreCase = False ' 大文字小文字を区別する。
.Global = True ' 文字列全体を検索。
End With
Set myMatches = myRegExp.Execute(myRange.Text)
'
If myMatches.Count = 0 Then GoTo GerFxUcs2SubExit
'
With Selection.Find
.ClearFormatting
.Text = "&{1,1}[\#A-Za-z0-9]{1,10};{1,1}"
.Forward = True
.Wrap = wdFindStop
.MatchCase = True
.MatchAllWordForms = False
.MatchSoundsLike = False
.MatchFuzzy = False
.MatchWildcards = True
For i = 1 To myMatches.Count
.Execute
'
Set myChrsFound = Selection.Range.Characters
myText = myChrsFound.Parent.Text
myLen = Len(myText)
'
Call GerFxUcAeiou(myText)
Call GerFxUcAous(myText)
Call GerFxUcOthers(myText)
'
If myLen <> Len(myText) Then
myChrsFound.First.Text = myText
For j = 2 To myLen
myChrsFound.First.Next.Text = ""
Next ' j
End If
'
c = i * 100 \ myMatches.Count
Application.StatusBar = "GerFx" & "：処理中" & " " & Format(c, "##0") & "%"
Next ' i
End With
'
GerFxUcs2SubExit:
myRange.Select ' 当初の選択範囲。
Selection.Collapse wdCollapseEnd
'
Set myRegExp = Nothing
Set myMatches = Nothing
'
Set myRange = Nothing
Set myChrsFound = Nothing
End Sub ' GerFxUcs2 *----*----* *----*----* *----*----* *----*----*
Sub GerFxSuff(mySffx As String)
Rem *----*----* *----*----* *----*----* *----*----*
Rem 代用文字表記処理
Rem 各国文字など各種の文字（Unicodeで160〜511の範囲）を検索し、
Rem (1)：検索した文字列を、UCS_2十進表記に置換する。
Rem (2)：ドイツ語文字を、指定した接尾字付き文字に置換する。
Rem (3)：屈音符付き母音字を、「_」接尾字付き文字に置換する。
Rem mySffxの値...
Rem 「」の場合：検索した総ての文字列を対象に(1)処理。
Rem 「^」の場合：(3)処理、「^」接尾字付き(2)処理、その他は(1)処理。
Rem 「e」の場合：(3)処理、「e」接尾字付き(2)処理、その他は(1)処理。
Rem 注記...
Rem 参照設定する場合：Microsoft VBScript Regular Expressions 5.5
Rem *----*----* *----*----* *----*----* *----*----*
'
If Selection.Range.Characters.Count < 1 Then Exit Sub
'
Dim i As Long
Dim c As Long
Dim myCount As Long
'
Dim myRange As Range
Dim myChrsFound As Characters
Dim myText As String
Dim myLen As Long
'
Dim myRegExp As Variant ' VBScript_RegExp_55.RegExp
Dim myMatches As Variant ' MatchCollection
Dim myMatch As Variant ' Match
'
Set myRegExp = CreateObject("VBScript.RegExp") ' New VBScript_RegExp_55.RegExp
Set myRange = Selection.Range
myCount = Selection.Range.Characters.Count
Selection.Collapse wdCollapseStart
'
GerFxSuffSubEntry:
With myRegExp
.Pattern = "[" & ChrW(160) & "-" & ChrW(511) & "]{1}"
.IgnoreCase = False ' 大文字小文字を区別する。
.Global = True ' 文字列全体を検索
End With
Set myMatches = myRegExp.Execute(myRange.Text)
'
If myMatches.Count = 0 Then GoTo GerFxSuffSubExit
'
With Selection.Find
.ClearFormatting
.Text = "[" & ChrW(160) & "-" & ChrW(511) & "]{1,1}"
.Forward = True
.Wrap = wdFindStop
.MatchCase = True
.MatchAllWordForms = False
.MatchSoundsLike = False
.MatchFuzzy = False
.MatchWildcards = True
For i = 1 To myMatches.Count
.Execute
'
Set myChrsFound = Selection.Range.Characters
myText = myChrsFound.Parent.Text
myLen = Len(myText)
'
If mySffx = "" Then
Call GerFxRvOthers(myText)
Else
Select Case myText
Case ChrW(194), ChrW(202), ChrW(206), ChrW(212), ChrW(219)
Call GerFxRvAeiou("", "_", myText)
Case ChrW(226), ChrW(234), ChrW(238), ChrW(244), ChrW(251)
Call GerFxRvAeiou("", "_", myText)
Case ChrW(196), ChrW(214), ChrW(220)
Call GerFxRvAous("", mySffx, myText)
Case ChrW(228), ChrW(246), ChrW(252), ChrW(223)
Call GerFxRvAous("", mySffx, myText)
Case Else
Call GerFxRvOthers(myText)
End Select
End If
'
If myLen <> Len(myText) Then
Rem 置換する文字列があった場合。
myChrsFound.Parent.Text = myText
myCount = myCount + Len(myText) - 1
End If
'
c = i * 100 \ myMatches.Count
Application.StatusBar = "GerFx" & "：処理中" & " " & Format(c, "##0") & "%"
Next ' i
End With
'
GerFxSuffSubExit:
myRange.Select ' 当初の選択範囲。
Selection.Collapse wdCollapseStart
Selection.MoveRight Unit:=wdCharacter, Count:=myCount, Extend:=wdMove
'
Set myRegExp = Nothing
Set myMatches = Nothing
'
Set myRange = Nothing
Set myChrsFound = Nothing
End Sub ' GerFxSuff *----*----* *----*----* *----*----* *----*----*
Sub GerFxAeiou(prefixC As String, suffixC As String, myText As String)
myText = Replace(myText, prefixC & "A" & suffixC, ChrW(194)) ' A_
myText = Replace(myText, prefixC & "E" & suffixC, ChrW(202)) ' E_
myText = Replace(myText, prefixC & "I" & suffixC, ChrW(206)) ' I_
myText = Replace(myText, prefixC & "O" & suffixC, ChrW(212)) ' O_
myText = Replace(myText, prefixC & "U" & suffixC, ChrW(219)) ' U_
'
myText = Replace(myText, prefixC & "a" & suffixC, ChrW(226)) ' a_
myText = Replace(myText, prefixC & "e" & suffixC, ChrW(234)) ' e_
myText = Replace(myText, prefixC & "i" & suffixC, ChrW(238)) ' i_
myText = Replace(myText, prefixC & "o" & suffixC, ChrW(244)) ' o_
myText = Replace(myText, prefixC & "u" & suffixC, ChrW(251)) ' u_
End Sub ' GerFxAeiou *----*----* *----*----* *----*----*
Sub GerFxAous(prefixC As String, suffixC As String, myText As String)
myText = Replace(myText, prefixC & "A" & suffixC, ChrW(196)) ' A^
myText = Replace(myText, prefixC & "O" & suffixC, ChrW(214)) ' O^
myText = Replace(myText, prefixC & "U" & suffixC, ChrW(220)) ' U^
'
myText = Replace(myText, prefixC & "a" & suffixC, ChrW(228)) ' a^
myText = Replace(myText, prefixC & "o" & suffixC, ChrW(246)) ' o^
myText = Replace(myText, prefixC & "u" & suffixC, ChrW(252)) ' u^
If suffixC = "e" Then
myText = Replace(myText, "ss", ChrW(223)) ' s^
Else
myText = Replace(myText, prefixC & "s" & suffixC, ChrW(223)) ' s^
End If
End Sub ' GerFxAous *----*----* *----*----* *----*----*
Sub GerFxUcAeiou(myText As String)
myText = Replace(myText, "Â", ChrW(194)) ' A_
myText = Replace(myText, "Ê", ChrW(202)) ' E_
myText = Replace(myText, "Î", ChrW(206)) ' I_
myText = Replace(myText, "Ô", ChrW(212)) ' O_
myText = Replace(myText, "Û", ChrW(219)) ' U_
'
myText = Replace(myText, "â", ChrW(226)) ' a_
myText = Replace(myText, "ê", ChrW(234)) ' e_
myText = Replace(myText, "î", ChrW(238)) ' i_
myText = Replace(myText, "ô", ChrW(244)) ' o_
myText = Replace(myText, "û", ChrW(251)) ' u_
End Sub ' GerFxUcAeiou *----*----* *----*----* *----*----*
Sub GerFxUcAous(myText As String)
myText = Replace(myText, "Ä", ChrW(196)) ' A^
myText = Replace(myText, "Ö", ChrW(214)) ' O^
myText = Replace(myText, "Ü", ChrW(220)) ' U^
'
myText = Replace(myText, "ä", ChrW(228)) ' a^
myText = Replace(myText, "ö", ChrW(246)) ' o^
myText = Replace(myText, "ü", ChrW(252)) ' u^
myText = Replace(myText, "ß", ChrW(223)) ' s^
End Sub ' GerFxUcAous *----*----* *----*----* *----*----*
Sub GerFxUcOthers(myText As String)
Dim i As Integer
Rem
myText = Replace(myText, " ", ChrW(160))
myText = Replace(myText, "¡", ChrW(161))
myText = Replace(myText, "¢", ChrW(162))
myText = Replace(myText, "£", ChrW(163))
myText = Replace(myText, "¤", ChrW(164))
myText = Replace(myText, "¥", ChrW(165))
myText = Replace(myText, "¦", ChrW(166))
Rem
Rem
myText = Replace(myText, "©", ChrW(169))
myText = Replace(myText, "ª", ChrW(170))
myText = Replace(myText, "«", ChrW(171))
myText = Replace(myText, "¬", ChrW(172))
myText = Replace(myText, "­", ChrW(173))
myText = Replace(myText, "®", ChrW(174))
myText = Replace(myText, "¯", ChrW(175))
Rem
Rem
myText = Replace(myText, "²", ChrW(178))
myText = Replace(myText, "³", ChrW(179))
Rem
myText = Replace(myText, "µ", ChrW(181))
Rem
myText = Replace(myText, "·", ChrW(183))
myText = Replace(myText, "¸", ChrW(184))
myText = Replace(myText, "¹", ChrW(185))
myText = Replace(myText, "º", ChrW(186))
myText = Replace(myText, "»", ChrW(187))
myText = Replace(myText, "¼", ChrW(188))
myText = Replace(myText, "½", ChrW(189))
myText = Replace(myText, "¾", ChrW(190))
myText = Replace(myText, "¿", ChrW(191))
myText = Replace(myText, "À", ChrW(192))
myText = Replace(myText, "Á", ChrW(193))
myText = Replace(myText, "Â", ChrW(194))
myText = Replace(myText, "Ã", ChrW(195))
myText = Replace(myText, "Ä", ChrW(196))
myText = Replace(myText, "Å", ChrW(197))
myText = Replace(myText, "Æ", ChrW(198))
myText = Replace(myText, "Ç", ChrW(199))
myText = Replace(myText, "È", ChrW(200))
myText = Replace(myText, "É", ChrW(201))
myText = Replace(myText, "Ê", ChrW(202))
myText = Replace(myText, "Ë", ChrW(203))
myText = Replace(myText, "Ì", ChrW(204))
myText = Replace(myText, "Í", ChrW(205))
myText = Replace(myText, "Î", ChrW(206))
myText = Replace(myText, "Ï", ChrW(207))
myText = Replace(myText, "Ð", ChrW(208))
myText = Replace(myText, "Ñ", ChrW(209))
myText = Replace(myText, "Ò", ChrW(210))
myText = Replace(myText, "Ó", ChrW(211))
myText = Replace(myText, "Ô", ChrW(212))
myText = Replace(myText, "Õ", ChrW(213))
myText = Replace(myText, "Ö", ChrW(214))
Rem
myText = Replace(myText, "Ø", ChrW(216))
myText = Replace(myText, "Ù", ChrW(217))
myText = Replace(myText, "Ú", ChrW(218))
myText = Replace(myText, "Û", ChrW(219))
myText = Replace(myText, "Ü", ChrW(220))
myText = Replace(myText, "Ý", ChrW(221))
myText = Replace(myText, "Þ", ChrW(222))
myText = Replace(myText, "ß", ChrW(223))
myText = Replace(myText, "à", ChrW(224))
myText = Replace(myText, "á", ChrW(225))
myText = Replace(myText, "â", ChrW(226))
myText = Replace(myText, "ã", ChrW(227))
myText = Replace(myText, "ä", ChrW(228))
myText = Replace(myText, "å", ChrW(229))
myText = Replace(myText, "æ", ChrW(230))
myText = Replace(myText, "ç", ChrW(231))
myText = Replace(myText, "è", ChrW(232))
myText = Replace(myText, "é", ChrW(233))
myText = Replace(myText, "ê", ChrW(234))
myText = Replace(myText, "ë", ChrW(235))
myText = Replace(myText, "ì", ChrW(236))
myText = Replace(myText, "í", ChrW(237))
myText = Replace(myText, "î", ChrW(238))
myText = Replace(myText, "ï", ChrW(239))
myText = Replace(myText, "ð", ChrW(240))
myText = Replace(myText, "ñ", ChrW(241))
myText = Replace(myText, "ò", ChrW(242))
myText = Replace(myText, "ó", ChrW(243))
myText = Replace(myText, "ô", ChrW(244))
myText = Replace(myText, "õ", ChrW(245))
myText = Replace(myText, "ö", ChrW(246))
Rem
myText = Replace(myText, "ø", ChrW(248))
myText = Replace(myText, "ù", ChrW(249))
myText = Replace(myText, "ú", ChrW(250))
myText = Replace(myText, "û", ChrW(251))
myText = Replace(myText, "ü", ChrW(252))
myText = Replace(myText, "ý", ChrW(253))
myText = Replace(myText, "þ", ChrW(254))
myText = Replace(myText, "ÿ", ChrW(255))
'
For i = 256 To 511
myText = Replace(myText, "&#" & i & ";", ChrW(i))
Next ' i
End Sub ' GerFxUcOthers *----*----* *----*----* *----*----*
Sub GerFxRvAeiou(prefixC As String, suffixC As String, myText As String)
myText = Replace(myText, ChrW(194), prefixC & "A" & suffixC) ' A^
myText = Replace(myText, ChrW(202), prefixC & "E" & suffixC) ' E^
myText = Replace(myText, ChrW(206), prefixC & "I" & suffixC) ' I^
myText = Replace(myText, ChrW(212), prefixC & "O" & suffixC) ' O^
If prefixC = "" Then
myText = Replace(myText, ChrW(219), "U_") ' U_
Else
myText = Replace(myText, ChrW(219), "_U") ' U_
End If
'
myText = Replace(myText, ChrW(226), prefixC & "a" & suffixC) ' a^
myText = Replace(myText, ChrW(234), prefixC & "e" & suffixC) ' e^
myText = Replace(myText, ChrW(238), prefixC & "i" & suffixC) ' i^
myText = Replace(myText, ChrW(244), prefixC & "o" & suffixC) ' o^
If prefixC = "" Then
myText = Replace(myText, ChrW(251), "u_") ' u_
Else
myText = Replace(myText, ChrW(251), "_u") ' u_
End If
End Sub ' GerFxRvAeiou *----*----* *----*----* *----*----* *----*----*
Sub GerFxRvAous(prefixC As String, suffixC As String, myText As String)
myText = Replace(myText, ChrW(196), prefixC & "A" & suffixC) ' A^
myText = Replace(myText, ChrW(214), prefixC & "O" & suffixC) ' O^
myText = Replace(myText, ChrW(220), prefixC & "U" & suffixC) ' U^
'
myText = Replace(myText, ChrW(228), prefixC & "a" & suffixC) ' a^
myText = Replace(myText, ChrW(246), prefixC & "o" & suffixC) ' o^
myText = Replace(myText, ChrW(252), prefixC & "u" & suffixC) ' u^
If suffixC = "e" Then
myText = Replace(myText, ChrW(223), "ss") ' s^
Else
myText = Replace(myText, ChrW(223), prefixC & "s" & suffixC) ' s^
End If
End Sub ' GerFxRvAous *----*----* *----*----* *----*----*
Sub GerFxRvOthers(myText As String)
Dim i As Integer
Rem
myText = Replace(myText, ChrW(160), " ")
myText = Replace(myText, ChrW(161), "¡")
myText = Replace(myText, ChrW(162), "¢")
myText = Replace(myText, ChrW(163), "£")
myText = Replace(myText, ChrW(164), "¤")
myText = Replace(myText, ChrW(165), "¥")
myText = Replace(myText, ChrW(166), "¦")
Rem
Rem
myText = Replace(myText, ChrW(169), "©")
myText = Replace(myText, ChrW(170), "ª")
myText = Replace(myText, ChrW(171), "«")
myText = Replace(myText, ChrW(172), "¬")
myText = Replace(myText, ChrW(173), "­")
myText = Replace(myText, ChrW(174), "®")
myText = Replace(myText, ChrW(175), "¯")
Rem
Rem
myText = Replace(myText, ChrW(178), "²")
myText = Replace(myText, ChrW(179), "³")
Rem
myText = Replace(myText, ChrW(181), "µ")
Rem
myText = Replace(myText, ChrW(183), "·")
myText = Replace(myText, ChrW(184), "¸")
myText = Replace(myText, ChrW(185), "¹")
myText = Replace(myText, ChrW(186), "º")
myText = Replace(myText, ChrW(187), "»")
myText = Replace(myText, ChrW(188), "¼")
myText = Replace(myText, ChrW(189), "½")
myText = Replace(myText, ChrW(190), "¾")
myText = Replace(myText, ChrW(191), "¿")
myText = Replace(myText, ChrW(192), "À")
myText = Replace(myText, ChrW(193), "Á")
myText = Replace(myText, ChrW(194), "Â")
myText = Replace(myText, ChrW(195), "Ã")
myText = Replace(myText, ChrW(196), "Ä")
myText = Replace(myText, ChrW(197), "Å")
myText = Replace(myText, ChrW(198), "Æ")
myText = Replace(myText, ChrW(199), "Ç")
myText = Replace(myText, ChrW(200), "È")
myText = Replace(myText, ChrW(201), "É")
myText = Replace(myText, ChrW(202), "Ê")
myText = Replace(myText, ChrW(203), "Ë")
myText = Replace(myText, ChrW(204), "Ì")
myText = Replace(myText, ChrW(205), "Í")
myText = Replace(myText, ChrW(206), "Î")
myText = Replace(myText, ChrW(207), "Ï")
myText = Replace(myText, ChrW(208), "Ð")
myText = Replace(myText, ChrW(209), "Ñ")
myText = Replace(myText, ChrW(210), "Ò")
myText = Replace(myText, ChrW(211), "Ó")
myText = Replace(myText, ChrW(212), "Ô")
myText = Replace(myText, ChrW(213), "Õ")
myText = Replace(myText, ChrW(214), "Ö")
Rem
myText = Replace(myText, ChrW(216), "Ø")
myText = Replace(myText, ChrW(217), "Ù")
myText = Replace(myText, ChrW(218), "Ú")
myText = Replace(myText, ChrW(219), "Û")
myText = Replace(myText, ChrW(220), "Ü")
myText = Replace(myText, ChrW(221), "Ý")
myText = Replace(myText, ChrW(222), "Þ")
myText = Replace(myText, ChrW(223), "ß")
myText = Replace(myText, ChrW(224), "à")
myText = Replace(myText, ChrW(225), "á")
myText = Replace(myText, ChrW(226), "â")
myText = Replace(myText, ChrW(227), "ã")
myText = Replace(myText, ChrW(228), "ä")
myText = Replace(myText, ChrW(229), "å")
myText = Replace(myText, ChrW(230), "æ")
myText = Replace(myText, ChrW(231), "ç")
myText = Replace(myText, ChrW(232), "è")
myText = Replace(myText, ChrW(233), "é")
myText = Replace(myText, ChrW(234), "ê")
myText = Replace(myText, ChrW(235), "ë")
myText = Replace(myText, ChrW(236), "ì")
myText = Replace(myText, ChrW(237), "í")
myText = Replace(myText, ChrW(238), "î")
myText = Replace(myText, ChrW(239), "ï")
myText = Replace(myText, ChrW(240), "ð")
myText = Replace(myText, ChrW(241), "ñ")
myText = Replace(myText, ChrW(242), "ò")
myText = Replace(myText, ChrW(243), "ó")
myText = Replace(myText, ChrW(244), "ô")
myText = Replace(myText, ChrW(245), "õ")
myText = Replace(myText, ChrW(246), "ö")
Rem
myText = Replace(myText, ChrW(248), "ø")
myText = Replace(myText, ChrW(249), "ù")
myText = Replace(myText, ChrW(250), "ú")
myText = Replace(myText, ChrW(251), "û")
myText = Replace(myText, ChrW(252), "ü")
myText = Replace(myText, ChrW(253), "ý")
myText = Replace(myText, ChrW(254), "þ")
myText = Replace(myText, ChrW(255), "ÿ")
'
For i = 256 To 511
myText = Replace(myText, ChrW(i), "&#" & i & ";")
Next ' i
End Sub ' GerFxRvOthers *----*----* *----*----* *----*----* *----*----*
