【中国語-日本語用】用語List一括置換マクロ

概要  Unicode(UTF-16 Big Endian)のTAB区切り用語リスト(置換リスト)をリストの上から順に読み込み、開いてるWord文書に一括置換を行うマクロ。中国語・日本語の置換も可能。
使用方法  マクロを実行すると、読み込む用語リストファイルの選択を促すダイアログが開かれるので目的の用語リストファイルをダブルクリック。
作成日  2014/09/24
更新日  2018/03/06
作成者  糸目 慈樹
[Source Code]
Dim Stopper As Boolean
Dim FSO As Object
Dim TrmLis As String

Sub KajiCN01_Replacer_Main()
Dim TextFile As Object ' Variable for text object
Dim buf As String ' for text stream
Dim str As Variant ' array for split text
Dim LC As Long ' for line count of term list file.
Dim i As Long ' Counter

'Prompt User to select term list file, and get the file path.
TrmLis = FilePath("Select Term List File", "Text File", "*.txt")
 If TrmLis = "" Then Exit Sub

Set FSO = CreateObject("Scripting.FileSystemObject")
Set TextFile = FSO.OpenTextFile(TrmLis, 1, 0, -1)

LC = ListLine_Count(TrmLis) ' retrieves line count of selected term list file
i = 1 ' initializing the counter

Application.ScreenUpdating = False

With ActiveDocument.Range.Find
 .ClearAllFuzzyOptions
 .ClearFormatting
 .Replacement.ClearFormatting
 .MatchWildcards = False
End With

 Do Until TextFile.AtEndOfStream
 buf = TextFile.ReadLine
 str = Split(buf, vbTab)

' Actual replacement takes place here.
 On Error GoTo Label1
 With ActiveDocument.Range.Find
 .Text = str(0)
 
 With .Replacement
 .Text = str(1)
 End With
 .Replacement.Highlight = True
 .Wrap = wdFindContinue
 .MatchWildcards = True
 .Execute
 
' Execute Replacement only when the string is found for the sake of saving memory
 If .Found = True Then
 .Execute Replace:=wdReplaceAll
 End If
 
 End With
Label1:
 i = i + 1
 Loop

' Release Text、FSO
Set TextFile = Nothing
Set FSO = Nothing

End Sub

Sub KajiCN02_ClearHighlight()

Selection.WholeStory
Selection.Range.HighlightColorIndex = wdAuto
Selection.Collapse (wdCollapseStart)

End Sub

Function ListLine_Count(ByRef Path As String) As Long
 'Retrieves Line count
Dim FSO As Object
Set FSO = CreateObject("Scripting.FileSystemObject")
 With FSO.OpenTextFile(Path, 8)
 ListLine_Count = .Line
 .Close
 End With
Set FSO = Nothing
End Function
 
Public Function FilePath(ByRef DlgTitle As String, ByRef fileType As String, ByRef Attr As String) As String

Dim Dlg As FileDialog
Set Dlg = Application.FileDialog(msoFileDialogOpen)

With Dlg
 .Title = DlgTitle
 .AllowMultiSelect = False
 .InitialFileName = Application.Parent
 .Filters.Clear
 .Filters.Add fileType, Attr
 If .Show = 0 Then
 MsgBox "Cancelled"
 FilePath = ""
 Else
 FilePath = .SelectedItems(1)
 End If
 End With
 
Set Dlg = Nothing
End Function

Share
Share
Share