Wordデータを英語環境に持って行くと2バイトフォントが使われている箇所を探せないかという話があったのでいい方法はないかな？
下のサンプルは少々強引だが・・・選択範囲に使用している文字のフォント名を取得してWin32APIを使用してフォントが２バイト（日中韓）フォントかの確認をしています。
当然OSに無いフォントがある場合は正常に動作しません。たぶん・・・。
簡単に説明するとCharacter.Font.Nameが実際に表示されているフォントでCharacter.Font.ASCIIが欧文フォント、Character.Font.NameFarEastが日中韓フォントのどれかになります。
他にもアラビア語用とかも選択できるみたいだがめんどくさいので割愛ということで。
Option Explicit
Private Const LF_FACESIZE As Long = 32&
Private Const LF_FULLFACESIZE As Long = 64&
Private Const DEVICE_FONTTYPE As Long = &H2&
Private Const RASTER_FONTTYPE As Long = &H1&
Private Const TRUETYPE_FONTTYPE As Long = &H4&
Private Type LOGFONT
lfHeight As Long
lfWidth As Long
lfEscapement As Long
lfOrientation As Long
lfWeight As Long
lfItalic As Byte
lfUnderline As Byte
lfStrikeOut As Byte
lfCharSet As Byte
lfOutPrecision As Byte
lfClipPrecision As Byte
lfQuality As Byte
lfPitchAndFamily As Byte
lfFaceName(LF_FACESIZE - 1&) As Byte
End Type
Type NEWTEXTMETRIC
tmHeight As Long
tmAscent As Long
tmDescent As Long
tmInternalLeading As Long
tmExternalLeading As Long
tmAveCharWidth As Long
tmMaxCharWidth As Long
tmWeight As Long
tmOverhang As Long
tmDigitizedAspectX As Long
tmDigitizedAspectY As Long
tmFirstChar As Byte
tmLastChar As Byte
tmDefaultChar As Byte
tmBreakChar As Byte
tmItalic As Byte
tmUnderlined As Byte
tmStruckOut As Byte
tmPitchAndFamily As Byte
tmCharSet As Byte
ntmFlags As Long
ntmSizeEM As Long
ntmCellHeight As Long
ntmAveWidth As Long
End Type
Private Const ANSI_CHARSET As Byte = 0&
Private Const BALTIC_CHARSET As Byte = 186&
Private Const CHINESEBIG5_CHARSET As Byte = 136&
Private Const DEFAULT_CHARSET As Byte = 1&
Private Const EASTEUROPE_CHARSET As Byte = 238&
Private Const GB2312_CHARSET As Byte = 134&
Private Const GREEK_CHARSET As Byte = 161&
Private Const HANGUL_CHARSET As Byte = 129&
Private Const MAC_CHARSET As Byte = 77&
Private Const OEM_CHARSET As Byte = 255&
Private Const RUSSIAN_CHARSET As Byte = 204&
Private Const SHIFTJIS_CHARSET As Byte = 128&
Private Const SYMBOL_CHARSET As Byte = 2&
Private Const TURKISH_CHARSET As Byte = 162&
Private Const VIETNAMESE_CHARSET As Byte = 163&
Private IsCJK As Boolean ' CJKフォントかの確認
Private Declare Function EnumFontFamiliesEx Lib "gdi32" Alias "EnumFontFamiliesExA" ( _
ByVal hdc As Long, _
lpLogFont As LOGFONT, _
ByVal lpEnumFontProc As Long, _
ByVal LParam As Long, _
ByVal dw As Long _
) As Long
Private Declare Sub MoveMemory Lib "kernel32" Alias "RtlMoveMemory" ( _
Destination As Any, _
Source As Any, _
ByVal Length As Long _
)
Private Declare Function GetDC Lib "user32" ( _
ByVal hwnd As Long _
) As Long
Public Sub CheckFarEastFont()
' フォントが日中韓フォントかの確認
Dim wd_Selection As Word.Selection
Dim i As Long
Set wd_Selection = Application.Selection
For i = 1 To wd_Selection.Characters.Count
With wd_Selection.Characters(i)
If .Font.Name = .Font.NameFarEast And .Font.Name <> "" Then
Call FontCheck(.Font)
End If
End With
Next
End Sub
Private Sub FontCheck(wd_Font As Word.Font)
' フォントが日中韓のエンコードを所持しているかの確認
Dim bytBuf() As Byte
Dim udtLogFont As LOGFONT
bytBuf = StrConv(wd_Font.Name, vbFromUnicode)
With udtLogFont
.lfCharSet = DEFAULT_CHARSET
Call MoveMemory(.lfFaceName(0), bytBuf(0), UBound(bytBuf) + 1&)
.lfPitchAndFamily = 0&
End With
IsCJK = False
Call EnumFontFamiliesEx(GetDC(0), udtLogFont, AddressOf EnumFontFamProc, ByVal 0&, 0)
If IsCJK Then
wd_Font.Animation = wdAnimationMarchingRedAnts ' CJKフォントの場合赤い線のアニメーション
Else
wd_Font.Animation = wdAnimationNone
End If
End Sub
Private Function EnumFontFamProc(lpNLF As LOGFONT, lpNTM As NEWTEXTMETRIC, ByVal FontType As Long, LParam As Long) As Long
Dim FaceName As String
FaceName = StrConv(lpNLF.lfFaceName, vbUnicode)
Debug.Print Left$(FaceName, InStr(FaceName, vbNullChar) - 1) ' フォント名
EnumFontFamProc = 1
Select Case lpNLF.lfCharSet
Case SHIFTJIS_CHARSET, GB2312_CHARSET, CHINESEBIG5_CHARSET, HANGUL_CHARSET:
IsCJK = True
End Select
End Function
しかし、Unicodeの時代なのに未だに２バイト文字というのもなんだかなぁ。