Word　VBAで文書内のUnicode文字を赤色にしたい

こんにちは。 #2の回答者です。 >Unicodeのみの文字判定ツールというのはどういうものですか？ それ自体の理屈は簡単です、その文字コードを、JISに切り替えたときに、文字化けするかどうか、というものです。ただ、それは、JIS,SJIS,区点,Unicode 共有の文字コード検索のアドインで、ずいぶん前に、私のVBAの力を見てもらうためにも作ったものです。 Yahoo のブリーフケースには公開してあるのですが、それを、ここで紹介すると削除されてしまうので、その中身を抜き出して作ってみました。なにぶん、昔に作ったものですから、おかしい部分があるかもしれません。 一応、こちらで試した範囲では、Unicode のみの文字は、記号を含めて、すべて検出するはずです。 JISは、もともと日本独特のものですから、海外に同様のツールはないし、なぜか、ライター用のJIS/区点用のツールがどんどん減ってしまって、Wordに標準装備されていないので、本当は、私も困っています。こらちは、標準的に、Wordを使っているわけではありませんが、納品はWord指定です。 もう1つ困るのは、Office 2007 では、Word側は、Excel側よりも、内部的に、改変されている度合いが高いようです。Word 2003 のVBAコードが、Word 2007 とは共有しないようです。今回のコードは、Word 2003 までしか分かりません。 ------------------------------------------------- '今回は、Wordの標準モジュールに入れてください。 Public Const MYCOLOR As Long = wdColorRed　'色-赤 Sub UnicodeLettersSearch() 'Unicode検索プログラム Dim mySelection As Selection Dim num As Long, t As Long Dim TowByte() As String Dim j As Long Dim i As Long Dim ltr As String Selection.HomeKey Unit:=wdStory Selection.EndKey Unit:=wdStory, Extend:=wdExtend Set mySelection = Selection 　For i = 1 To Len(mySelection) 　　ltr = Mid$(mySelection, i, 1) 　　　　num = AscW(ltr) 　　　　t = Asc(ltr) 　　 If (num <> 63 And t = 63) Or (num > 0 And num < 1000 And num <> t) Then 　　　　ReDim Preserve TowByte(j) 　　　　TowByte(j) = ltr 　　　　j = j + 1 　　　End If 　Next i 　If j = 0 Then 　　MsgBox "単語は見つかりません。", vbInformation 　　Selection.HomeKey Unit:=wdStory 　　Exit Sub 　End If 　Application.ScreenUpdating = False 　For j = 0 To UBound(TowByte) 　　　WordHilightPrc TowByte(j) 　Next 　Application.ScreenUpdating = True 　Selection.HomeKey Unit:=wdStory End Sub Private Sub WordHilightPrc(ByVal myStr As String) 　　Selection.Find.ClearFormatting 　　Selection.Find.Replacement.ClearFormatting 　　Selection.Find.Replacement.Highlight = True 　　With Selection.Find 　　　　.Text = myStr 　　　　.Replacement.Text = myStr 　　　　.Replacement.Font.Color = MYCOLOR 　　　　.Forward = True 　　　　.Wrap = wdFindContinue 　　　　.Format = True 　　　　.MatchCase = False 　　　　.MatchWholeWord = False 　　　　.MatchByte = False 　　　　.MatchAllWordForms = False 　　　　.MatchSoundsLike = False 　　　　.MatchWildcards = False 　　　　.MatchFuzzy = False 　　End With 　　Selection.Find.Execute Replace:=wdReplaceAll End Sub