Sub EspRevizo() Rem *----*----* *----*----* *----*----* *----*----* Rem エスペラント語辞書参照処理(即席スペルチェッカー) Rem 作譜:Hitrock Camellia Shinopy Rem 言語:Word VBA Rem 機能... Rem 選択した範囲にある単語に関して、エスペラント語の辞書データを参照する。 Rem 注記... Rem 1. 「EspRevizoSetUp」を、「EspRevizo」初回実行前に先行して、一度だけ実行しておくこと。 Rem 2. 「EspRevizo」を起動して、ツールバーを追加し、コマンドボタンを押して、処理を実行する。 Rem 3. [単語の点検]処理で、辞書にない単語に対し、蛍光ペン書式(水色/明るい緑)を設定する。 Rem 4. このマクロの一部に下記の「Espizo」のプロシージャを使用している。 Rem EspizoAeiou・EspizoCghjsu・EspizoOthers・ Rem EspizoRvAeiou・EspizoRvCghjsu・EspizoRvOthers Rem 履歴... Rem 第01版:2005/05/14 作成。 Rem (...) Rem 第22版:2007/01/07 Word2007以降に対応するため、バルーン表示を廃止。ツールバー表示に変更。 Rem 第23版:2007/01/27... Rem ポップアップ表示時にWordウィンドウ以外の箇所をクリックした場合に対応。 Rem 訳語の表示で、「<英>」表示を「<mso>」に変更した。 Rem 第24版:2007/01/30 アイコン表示変更。 Rem 第25版:2007/03/05 空白表示をSpace関数に変更。 Rem 第26版:2007/03/11... Rem EspRevizoInitで、辞書ファイル「EspRevizoPcase.csv」「EspRevizoLcase.csv」の Rem 区切りを空白から「;」に変更。 Rem 第27版:2007/11/01... Rem 他の言語のラテン文字に対応。EspizoUcOthers・EspizoRvOthersを追加。 Rem 第28版:2008/07/03... Rem 複数形だけの単語で不具合が発生。「pluraj」の対格に対応。 Rem 第29版:2008/08/21... Rem FaceIdの指定を変更。「459」=>「964」(Word2007に対応)。 Rem 第30版:2008/08/28:FaceIdを変更。(1613=>2533 1023=>44 1018=>2310) Rem 第31版:2008/10/13:呼び出す処理の引数を見直し。 Rem *----*----* *----*----* *----*----* *----*----* Dim myTitle As String Rem *----*----* *----*----* *----*----* *----*----* ' Rem 既定値の設定 Call EspRevizoConst("myTitle", myTitle) Rem *----*----* *----*----* *----*----* *----*----* ' Rem 同名ツールバーの削除 On Error Resume Next CommandBars(myTitle).Delete On Error GoTo 0 ' Rem ステータスバーの表示 Application.DisplayStatusBar = True ' Rem ツールバー表示処理 Dim myCmmdBar As CommandBar Dim myCtrlBttn As CommandBarControl Dim myCtrlCboxItem As CommandBarControl Dim myCtrlBttnSelr As CommandBarControl Dim myCtrlBttnOdic As CommandBarControl Dim myCtrlBttnRubi As CommandBarControl Dim myCtrlBttnRevizio As CommandBarControl Dim myCtrlBttnPopUp As CommandBarControl Rem *----*----* *----*----* *----*----* *----*----* ' Set myCmmdBar = CommandBars.Add(Name:=myTitle, Position:=msoBarTop, Temporary:=True) ' Set myCtrlBttn = myCmmdBar.Controls.Add(Type:=msoControlButton, Before:=1, Temporary:=True) Set myCtrlCboxItem = myCmmdBar.Controls.Add(Type:=msoControlDropdown, Before:=2, Temporary:=True) Set myCtrlBttnSelr = myCmmdBar.Controls.Add(Type:=msoControlButton, Before:=3, Temporary:=True) Set myCtrlBttnOdic = myCmmdBar.Controls.Add(Type:=msoControlButton, Before:=4, Temporary:=True) Set myCtrlBttnRubi = myCmmdBar.Controls.Add(Type:=msoControlButton, Before:=5, Temporary:=True) Set myCtrlBttnRevizio = myCmmdBar.Controls.Add(Type:=msoControlButton, Before:=6, Temporary:=True) Set myCtrlBttnPopUp = myCmmdBar.Controls.Add(Type:=msoControlButton, Before:=7, Temporary:=True) Rem *----*----* *----*----* *----*----* *----*----* ' With myCtrlBttn .DescriptionText = "エスペラント語辞書参照処理(即席スペルチェッカー):選択した処理を実行します。" .Style = msoButtonIcon .Caption = myTitle .TooltipText = "実行!" .FaceId = 2533 .OnAction = "EspRevizoBttn" End With ' With myCtrlCboxItem .DescriptionText = "実行する処理を選択します。" .Style = msoComboNormal .Caption = "処理" ' .AddItem "単語の点検", 1 .AddItem "===========", 2 .AddItem "蛍光ペン書式検索", 3 .AddItem "===========", 4 .AddItem "訳語の表示", 5 .AddItem "===========", 6 .AddItem "辞書に登録:明るい緑", 7 .AddItem "辞書に登録:水色", 8 .AddItem "===========", 9 .AddItem "蛍光ペン書式解除", 10 ' .ListIndex = 0 .Width = 130 .TooltipText = "処理を選択して下さい。" .DropDownLines = 10 .DropDownWidth = 200 .OnAction = "EspRevizoCboxItem" End With ' With myCtrlBttnSelr .DescriptionText = "[単語の点検]で、処理の対象となる範囲を指定します。" .Style = msoButtonIcon .Caption = "選択範囲" .TooltipText = "選択範囲の単語を点検する。" .FaceId = 44 .OnAction = "EspRevizoBttnSelr" End With ' With myCtrlBttnOdic .DescriptionText = "[単語の点検]で、Microsoft Office辞書の使用/不使用を指定します。" .Style = msoButtonIcon .Caption = "Office辞書" .TooltipText = "Officeの辞書も使用する。" .FaceId = 4031 .OnAction = "EspRevizoBttnOdic" End With ' With myCtrlBttnRubi .DescriptionText = "[単語の点検]で、訳語ルビを表示/非表示を指定します。" .Style = msoButtonIcon .Caption = "訳語ルビ" .TooltipText = "訳語ルビは非表示にする。" .FaceId = 291 .OnAction = "EspRevizoBttnRubi" End With ' With myCtrlBttnRevizio .DescriptionText = "訳語を表示を指定します。" .BeginGroup = True .Style = msoButtonIcon .Caption = "[単語の点検]" .TooltipText = "[ 単語の点検 ]" .FaceId = 329 .OnAction = "EspRevizoBttnRevizio" End With ' With myCtrlBttnPopUp .DescriptionText = "訳語を表示を指定します。" .Style = msoButtonIcon .Caption = "[訳語の表示]" .TooltipText = "[ 訳語の表示 ]" .FaceId = 983 .OnAction = "EspRevizoBttnPopUp" End With ' myCmmdBar.Visible = True DoEvents Call EspRevizoBttn End Sub ' EspRevizo *----*----* *----*----* *----*----* *----*----* Sub EspRevizoCboxItem(Optional myDummy As Boolean) Rem *----*----* *----*----* *----*----* *----*----* Rem [処理]コンボボックス処理 Rem *----*----* *----*----* *----*----* *----*----* Dim myTitle As String Rem *----*----* *----*----* *----*----* *----*----* ' Call EspRevizoConst("myTitle", myTitle) ' With CommandBars(myTitle).Controls(2) If .Text = "===========" Then .TooltipText = "処理が未選択です。" Else .TooltipText = .Text End If End With End Sub ' EspRevizoCboxItem *----*----* *----*----* *----*----* *----*----* Sub EspRevizoBttnSelr(Optional myDummy As Boolean) Rem *----*----* *----*----* *----*----* *----*----* Rem [選択範囲]ボタン処理 Rem *----*----* *----*----* *----*----* *----*----* Dim myTitle As String Rem *----*----* *----*----* *----*----* *----*----* ' Call EspRevizoConst("myTitle", myTitle) ' With CommandBars(myTitle).Controls(3) If .FaceId = 44 Then .FaceId = 2310 .TooltipText = "カーソルから後の単語を点検する。" Else .FaceId = 44 .TooltipText = "選択範囲の単語を点検する。" End If End With End Sub ' EspRevizoBttnSelr *----*----* *----*----* *----*----* *----*----* Sub EspRevizoBttnOdic(Optional myDummy As Boolean) Rem *----*----* *----*----* *----*----* *----*----* Rem [Office辞書]ボタン処理 Rem *----*----* *----*----* *----*----* *----*----* Dim myTitle As String Rem *----*----* *----*----* *----*----* *----*----* ' Call EspRevizoConst("myTitle", myTitle) ' With CommandBars(myTitle).Controls(4) If .FaceId = 4031 Then .FaceId = 1104 .TooltipText = "Officeの辞書は不使用にする。" Else .FaceId = 4031 .TooltipText = "Officeの辞書も使用する。" End If End With End Sub ' EspRevizoBttnOdic *----*----* *----*----* *----*----* *----*----* Sub EspRevizoBttnRubi(Optional myDummy As Boolean) Rem *----*----* *----*----* *----*----* *----*----* Rem [訳語ルビ]ボタン処理 Rem *----*----* *----*----* *----*----* *----*----* Dim myTitle As String Rem *----*----* *----*----* *----*----* *----*----* ' Call EspRevizoConst("myTitle", myTitle) ' With CommandBars(myTitle).Controls(5) If .FaceId = 291 Then .FaceId = 2805 .TooltipText = "訳語ルビを表示する。" Else .FaceId = 291 .TooltipText = "訳語ルビは非表示にする。" End If End With End Sub ' EspRevizoBttnRubi *----*----* *----*----* *----*----* *----*----* Sub EspRevizoBttnRevizio(Optional myDummy As Boolean) Rem *----*----* *----*----* *----*----* *----*----* Rem [単語の点検]ボタン処理 Rem *----*----* *----*----* *----*----* *----*----* Dim myTitle As String Rem *----*----* *----*----* *----*----* *----*----* ' Call EspRevizoConst("myTitle", myTitle) ' With CommandBars(myTitle).Controls(1) .FaceId = 329 End With ' Call EspRevizoBttn End Sub ' EspRevizoBttnRevizio *----*----* *----*----* *----*----* *----*----* Sub EspRevizoBttnPopUp(Optional myDummy As Boolean) Rem *----*----* *----*----* *----*----* *----*----* Rem [訳語の表示]ボタン処理 Rem *----*----* *----*----* *----*----* *----*----* Dim myTitle As String Rem *----*----* *----*----* *----*----* *----*----* ' Call EspRevizoConst("myTitle", myTitle) ' With CommandBars(myTitle).Controls(1) .FaceId = 983 End With ' Call EspRevizoBttn End Sub ' EspRevizoBttnPopUp *----*----* *----*----* *----*----* *----*----* Sub EspRevizoBttnMyOk(Optional myDummy As Boolean) Rem *----*----* *----*----* *----*----* *----*----* Rem コマンドボタン[OK]OnAction処理 Rem *----*----* *----*----* *----*----* *----*----* Dim myTitle As String Rem *----*----* *----*----* *----*----* *----*----* ' Call EspRevizoConst("myTitle", myTitle) ' CommandBars(myTitle).Controls(1).FaceId = 964 End Sub ' EspRevizoBttnMyOk *----*----* *----*----* *----*----* *----*----* Sub EspRevizoBttnMyCancel(Optional myDummy As Boolean) Rem *----*----* *----*----* *----*----* *----*----* Rem コマンドボタン[キャンセル]OnAction処理 Rem *----*----* *----*----* *----*----* *----*----* Dim myTitle As String Rem *----*----* *----*----* *----*----* *----*----* ' Call EspRevizoConst("myTitle", myTitle) ' CommandBars(myTitle).Controls(1).FaceId = 330 End Sub ' EspRevizoBttnMyCancel *----*----* *----*----* *----*----* *----*----* Sub EspRevizoBttnMyRetry(Optional myDummy As Boolean) Rem *----*----* *----*----* *----*----* *----*----* Rem コマンドボタン[再試行](選択範囲の先頭へ)OnAction処理 Rem *----*----* *----*----* *----*----* *----*----* Dim myTitle As String Rem *----*----* *----*----* *----*----* *----*----* ' Call EspRevizoConst("myTitle", myTitle) ' CommandBars(myTitle).Controls(1).FaceId = 154 End Sub ' EspRevizoBttnMyRetry *----*----* *----*----* *----*----* *----*----* Sub EspRevizoBttn(Optional myDummy As Boolean) Rem *----*----* *----*----* *----*----* *----*----* Rem 各ボタン処理 Rem *----*----* *----*----* *----*----* *----*----* Static myDic As Variant ' Dim myTitle As String Dim myBttn As Long Dim myLabel As String ' Dim myDicPcase As String Dim myDicLcase As String Rem *----*----* *----*----* *----*----* *----*----* ' Rem マクロ名・辞書ファイル名。 Call EspRevizoConst("myTitle", myTitle) Call EspRevizoConst("myDicPcase", myDicPcase) Call EspRevizoConst("myDicLcase", myDicLcase) ' If CommandBars(myTitle).Controls(1).FaceId = 2533 Then With CommandBars(myTitle).Controls(2) myLabel = .Text myBttn = .ListIndex End With Else Select Case CommandBars(myTitle).Controls(1).FaceId Case 329 myLabel = CommandBars(myTitle).Controls(6).Caption myBttn = 1 Case 983 myLabel = CommandBars(myTitle).Controls(7).Caption myBttn = 5 End Select CommandBars(myTitle).Controls(1).FaceId = 2533 End If ' Select Case myBttn Case 0 Call EspRevizoInit(myDic) CommandBars(myTitle).Controls(2).ListIndex = 3 ' Exit Sub Case 2, 4, 6, 9 GoTo EspRevizoBttnSubExit End Select ' Rem 辞書ファイルを開いている場合は、 Rem [辞書に登録]ボタン以外は無効にする。 If ActiveDocument.Name = myDicPcase Or ActiveDocument.Name = myDicLcase Then Select Case myBttn Case 7, 8 Rem Case Else GoTo EspRevizoBttnSubExit End Select End If Rem *----*----* *----*----* *----*----* *----*----* ' EspRevizoBttnSubEntry: Select Case myBttn Case 1 Call EspRevizoRevizio(myDic) Case 3 Call EspRevizoHiLight Case 5 Call EspRevizoPopItem(myDic) Case 7, 8 Call EspRevizoLeksiko(myDic) Case 10 Call EspRevizoNoHiLight End Select Rem *----*----* *----*----* *----*----* *----*----* ' EspRevizoBttnSubExit: Rem 続けて処理する場合に備える。 Application.ScreenUpdating = False CommandBars(myTitle).Enabled = False CommandBars(myTitle).Enabled = True Application.ScreenUpdating = True ' Select Case myBttn Case 1, 3, 5, 7, 8, 10 Application.StatusBar = myTitle & ":" & "処理完了!" & "[ " & myLabel & " ]" End Select End Sub ' EspRevizoBttn *----*----* *----*----* *----*----* *----*----* Sub EspRevizoRevizio(myDic As Variant) Rem *----*----* *----*----* *----*----* *----*----* Rem [単語の点検] Rem *----*----* *----*----* *----*----* *----*----* Dim myLatin As String Dim myLatinEx As String Dim myMarks As String ' Dim myRange As Range Dim myField As Fields Dim myChrs As Characters Dim myStartMarker As Word.Range ' Dim i As Long Dim c As Long ' Dim myWord As String Dim myItem As String Dim myCount As Long ' 辞書にない単語の数。 Dim myFieldMax As Long ' フィールドが設定された単語の数 Dim myFlag As Boolean Dim myHighlightColor As String ' Dim myTitle As String Dim myStatusBar As String Dim myMsg As String Dim myAns As Long ' Dim myCmmdBar As CommandBar Dim myCtrlBttn As CommandBarControl Dim myCtrlBttnOk As CommandBarControl Dim myCtrlBttnRetry As CommandBarControl Dim mySubName As String Dim myFaceId As Long ' Rem 参照設定する場合:Microsoft VBScript Regular Expressions 5.5 Dim myRegExp As Variant ' VBScript_RegExp_55.RegExp Dim myMatches As Variant ' MatchCollection Dim myMatch As Variant ' Match Dim myPttn As String Rem *----*----* *----*----* *----*----* *----*----* ' Call EspRevizoConst("myTitle", myTitle) mySubName = "EspRevizoRevizio" ' Set myRegExp = CreateObject("VBScript.RegExp") ' New VBScript_RegExp_55.RegExp ' Rem Unicode(16進)によるラテン文字の文字コードの範囲を指定する。 myLatin = "A-Za-z0-9" ' 基本ラテン文字 myMarks = "\-\^\.@" ' 句読点:連字符・屈音符・終止符・単価記号 myMarks = myMarks & "\u0027" & "\u2019" ' 句読点:単一引用符 myLatinEx = ChrW(Val("&h00C0")) & "-" & ChrW(Val("&h00FF")) ' 拡張ラテン文字 myLatinEx = myLatinEx & ChrW(Val("&h0100")) & "-" & ChrW(Val("&h017F")) myLatinEx = myLatinEx & ChrW(Val("&h0192")) & "-" & ChrW(Val("&h01FF")) myLatinEx = myLatinEx & ChrW(Val("&h1E80")) & "-" & ChrW(Val("&h1EF3")) ' Rem パターンを指定 myPttn = "[" & myLatin & myLatinEx & myMarks & "]+" myPttn = "[" & myLatinEx & "]?" & myPttn Rem *----*----* *----*----* *----*----* *----*----* ' Rem [単語の点検]をする範囲を指定する。 If CommandBars(myTitle).Controls(3).FaceId = 44 Then ' .TooltipText = "選択範囲の単語を点検する。" If Selection.Range.Text = "" Then Rem カーソルが単語の途中あると、不都合がなので、 Rem カーソルを単語の先頭または末尾に移動させ、 Rem カーソル位置から前にある段落の先頭までの範囲を選択する。 Selection.Words(1).Select Select Case Selection.Range.Text Case vbVerticalTab, vbCr Rem カーソル位置が垂直タブ・改行の場合 Selection.Collapse wdCollapseStart Selection.MoveUp Unit:=wdParagraph, Count:=1, Extend:=wdExtend Select Case Selection.Range.Text Case vbVerticalTab, vbCr Rem 垂直タブ・改行が2行続いた時、再度選択の処理をする。 Selection.MoveUp Unit:=wdParagraph, Count:=1, Extend:=wdExtend End Select Case Else Selection.Collapse wdCollapseEnd Selection.MoveUp Unit:=wdParagraph, Count:=1, Extend:=wdExtend End Select End If Else Selection.Words(1).Select Selection.Collapse wdCollapseStart Rem カーソル位置から文書の末尾までの範囲を選択する。 Selection.EndKey Unit:=wdStory, Extend:=wdExtend End If Rem *----*----* *----*----* *----*----* *----*----* ' Set myRange = Selection.Range Set myField = myRange.Fields Set myChrs = myRange.Characters ' If CommandBars(myTitle).Controls(5).FaceId = 291 Then ' .TooltipText = "訳語ルビは非表示にする。" Rem [訳語ルビ]オフの時、ルビを削除する。 myFieldMax = myField.Count For i = myField.Count To 1 Step -1 myField.Item(i).Select If InStr(myField.Item(i).Code, "\o(\s\up") > 0 Then With Selection .Start = .Range.Start .End = .Range.End .Range.PhoneticGuide Text:="" End With End If ' c = (myFieldMax + 1 - i) * 100 \ myFieldMax myStatusBar = " [" & "ルビ削除" & "] " & Format(c, "##0") & "%" Application.StatusBar = myTitle & ":処理中" & myStatusBar Next ' i End If Rem *----*----* *----*----* *----*----* *----*----* ' myRange.Select With myRegExp .Pattern = myPttn ' パターンを設定 .IgnoreCase = False ' 大文字と小文字を区別する .Global = True ' 文字列全体を検索 End With Set myMatches = myRegExp.Execute(myRange.Text) ' Rem 検索開始点の取得。 Selection.Collapse wdCollapseStart Set myStartMarker = Selection.Range myCount = 0 ' Rem ラテン文字の単語を検索。 With Selection.Find For i = 0 To myMatches.Count - 1 .ClearFormatting .Text = myMatches.Item(i).Value .Forward = True .Wrap = wdFindStop .MatchCase = True .MatchAllWordForms = False .MatchSoundsLike = False .MatchFuzzy = False .MatchWildcards = False .Execute Rem *----*----* *----*----* ' myFlag = False myItem = "" myWord = Selection.Range.Text Call EspRevizoKontrolo(myFlag, myWord, myItem, myDic) Rem *----*----* *----*----* ' Rem 辞書にない単語を蛍光ペン書式にする。 If myFlag = True Then Selection.Range.HighlightColorIndex = wdNoHighlight Else If Right(Selection.Range.Text, 1) = "." Then Selection.MoveLeft Unit:=wdCharacter, Count:=1, Extend:=wdExtend End If ' Select Case Left(Selection.Range.Text, 1) Case "A" To "Z" myHighlightColor = wdBrightGreen ' 明るい緑 Case ChrW(194), ChrW(202), ChrW(206), ChrW(212), ChrW(219) Rem A_ E_ I_ O_ U_ myHighlightColor = wdBrightGreen ' 明るい緑 Case ChrW(264), ChrW(284), ChrW(292), ChrW(308), ChrW(348), ChrW(364) Rem C^ G^ H^ J^ S^ U^ myHighlightColor = wdBrightGreen ' 明るい緑 Case Else myHighlightColor = wdTurquoise ' 水色 End Select Selection.Range.HighlightColorIndex = myHighlightColor myCount = myCount + 1 End If ' Rem 訳語ルビ設定。 If CommandBars(myTitle).Controls(5).FaceId = 2805 Then ' .TooltipText = "訳語ルビを表示する。" Call EspRevizoPhGuide(myItem) End If ' If Not Selection.Range.Characters.Last.Next Is Nothing Then If Selection.Range.Characters.Last.Next.Text = "." Then Selection.MoveRight Unit:=wdCharacter, Count:=1, Extend:=wdExtend End If End If Rem *----*----* *----*----* ' c = (i + 1) * 100 \ myMatches.Count myStatusBar = Format(c, "##0") & "%" Application.StatusBar = myTitle & ":処理中" & " " & myStatusBar ' Selection.Collapse wdCollapseEnd Next ' i End With Rem *----*----* *----*----* *----*----* *----*----* ' On Error Resume Next CommandBars(mySubName).Delete On Error GoTo 0 ' If myCount > 0 Then Set myCmmdBar = CommandBars.Add(Name:=mySubName, Position:=msoBarPopup, Temporary:=True) Set myCtrlBttn = myCmmdBar.Controls.Add(Type:=msoControlButton, Before:=1, Temporary:=True) Set myCtrlBttnOk = myCmmdBar.Controls.Add(Type:=msoControlButton, Before:=2, Temporary:=True) ' myMsg = "辞書にない単語が、" & vbCrLf myMsg = myMsg & myCount & "箇所ありました。" ' With myCtrlBttn .DescriptionText = "[単語の点検]処理後ポップアップメニュー" .Style = msoButtonIconAndWrapCaption .Caption = myTitle & vbCrLf & "[単語の点検]" & vbCrLf & myMsg .TooltipText = "辞書にない単語がありました。" .FaceId = 463 myFaceId = .FaceId End With ' With myCtrlBttnOk .DescriptionText = "[単語の点検]処理:[選択範囲の先頭へ]ボタン" .BeginGroup = True .Style = msoButtonIconAndCaption .Caption = "[選択範囲の先頭へ]" & Space(26) .TooltipText = "カーソルを選択範囲の先頭へ戻します。" .FaceId = 154 .OnAction = "EspRevizoBttnMyRetry" End With Else Set myCmmdBar = CommandBars.Add(Name:=mySubName, Position:=msoBarPopup, Temporary:=True) Set myCtrlBttn = myCmmdBar.Controls.Add(Type:=msoControlButton, Before:=1, Temporary:=True) Set myCtrlBttnRetry = myCmmdBar.Controls.Add(Type:=msoControlButton, Before:=2, Temporary:=True) Set myCtrlBttnOk = myCmmdBar.Controls.Add(Type:=msoControlButton, Before:=3, Temporary:=True) ' myMsg = "辞書にない単語は、発見できませんでした。" ' With myCtrlBttn .DescriptionText = "[単語の点検]処理後ポップアップメニュー" .Style = msoButtonIconAndWrapCaption .Caption = myTitle & vbCrLf & "[単語の点検]" & vbCrLf & myMsg .TooltipText = "辞書にない単語は、発見できませんでした。" .FaceId = 487 myFaceId = .FaceId End With ' With myCtrlBttnRetry .DescriptionText = "[単語の点検]処理:[選択範囲の先頭へ]ボタン" .BeginGroup = True .Style = msoButtonIconAndCaption .Caption = "[選択範囲の先頭へ]" & Space(26) .TooltipText = "カーソルを選択範囲の先頭へ戻します。" .FaceId = 154 .OnAction = "EspRevizoBttnMyRetry" End With ' With myCtrlBttnOk .DescriptionText = "[単語の点検]処理:[OK]ボタン" .Style = msoButtonIconAndCaption .Caption = "OK" .TooltipText = "辞書にない単語は、発見できませんでした。" .FaceId = 964 .OnAction = "EspRevizoBttnMyOk" End With End If Rem *----*----* *----*----* *----*----* *----*----* ' CommandBars(myTitle).Controls(1).FaceId = myFaceId Beep Do On Error Resume Next myCmmdBar.ShowPopup On Error GoTo 0 DoEvents If CommandBars(myTitle).Controls(1).FaceId <> myFaceId Then Exit Do Loop ' Select Case CommandBars(myTitle).Controls(1).FaceId Case 154 myAns = vbRetry Case Else myAns = vbOK End Select ' If myAns = vbRetry Then Rem 検索開始点に戻る。 myStartMarker.Select Else myChrs.Last.Select Selection.Collapse wdCollapseEnd End If ' On Error Resume Next myCmmdBar.Delete CommandBars(myTitle).Controls(1).FaceId = 2533 On Error GoTo 0 Rem *----*----* *----*----* *----*----* *----*----* ' Set myRegExp = Nothing Set myMatches = Nothing Set myRange = Nothing Set myField = Nothing Set myChrs = Nothing Set myStartMarker = Nothing ' Set myCmmdBar = Nothing Set myCtrlBttn = Nothing Set myCtrlBttnOk = Nothing Set myCtrlBttnRetry = Nothing End Sub ' EspRevizoRevizio *----*----* *----*----* *----*----* *----*----* Sub EspRevizoLeksiko(myDic As Variant) Rem *----*----* *----*----* *----*----* *----*----* Rem [辞書に登録] Rem *----*----* *----*----* *----*----* *----*----* Dim myFolder As String Dim myFullName As String Dim myDicPcase As String Dim myDicLcase As String Dim myDicName As String ' Dim myHighlightColor As String Dim myStartMarker As Word.Range Dim myPara As Paragraph Dim myCount As Long ' Dim myText As String Dim myKey As String Dim myItem As String ' Dim myTitle As String Dim myMsg As String Dim myAns As Long ' Dim myCmmdBar As CommandBar Dim myCtrlBttn As CommandBarControl Dim myCtrlBttnOk As CommandBarControl Dim myCtrlBttnCancel As CommandBarControl Dim mySubName As String Dim myFaceId As Long Rem *----*----* *----*----* *----*----* *----*----* ' Rem マクロ名・関連フォルダ名・関連ファイル名。 Call EspRevizoConst("myTitle", myTitle) Call EspRevizoConst("myFolder", myFolder) Call EspRevizoConst("myDicPcase", myDicPcase) Call EspRevizoConst("myDicLcase", myDicLcase) mySubName = "EspRevizoLeksiko" ' Select Case ActiveDocument.Name Case myDicPcase, myDicLcase GoTo EspRevizoLeksikoSubEntry End Select Rem *----*----* *----*----* *----*----* *----*----* ' Select Case CommandBars(myTitle).Controls(2).ListIndex Case 7 ' "辞書に登録:明るい緑" myDicName = myDicPcase myHighlightColor = wdBrightGreen ' 明るい緑 Case 8 ' "辞書に登録::水色" myDicName = myDicLcase myHighlightColor = wdTurquoise ' 水色 End Select Rem *----*----* *----*----* *----*----* *----*----* ' myCount = 0 Call EspRevizoDicSelect(myFolder, myDicName, myHighlightColor, myCount) ' On Error Resume Next CommandBars(mySubName).Delete On Error GoTo 0 ' Set myCmmdBar = CommandBars.Add(Name:=mySubName, Position:=msoBarPopup, Temporary:=True) Set myCtrlBttn = myCmmdBar.Controls.Add(Type:=msoControlButton, Before:=1, Temporary:=True) Set myCtrlBttnOk = myCmmdBar.Controls.Add(Type:=msoControlButton, Before:=2, Temporary:=True) ' If myCount > 0 Then myMsg = "単語を辞書に登録する準備ができました!" & vbCrLf & vbCrLf myMsg = myMsg & myCount & "件の追加する単語があります。" & vbCrLf myMsg = myMsg & "訳語を入力して下さい。" & vbCrLf & vbCrLf myMsg = myMsg & "文書上の単語を辞書に登録する場合は、" & vbCrLf myMsg = myMsg & "再度[辞書に登録]を実行して下さい。" ' With myCtrlBttn .DescriptionText = "[辞書に登録]処理前ポップアップメニュー" .Style = msoButtonIconAndWrapCaption .Caption = myTitle & vbCrLf & "[辞書に登録]" & vbCrLf & myMsg .TooltipText = "訳語を入力して、再度[辞書に登録]を単語を登録して下さい。" .FaceId = 463 myFaceId = .FaceId End With ' With myCtrlBttnOk .DescriptionText = "[辞書に登録]処理:[OK]ボタン" .Style = msoButtonIconAndCaption .Caption = "OK" & Space(48) .TooltipText = "この後、訳語を入力して下さい。" .FaceId = 964 .OnAction = "EspRevizoBttnMyOk" End With Else myMsg = "該当する単語は、ありませんでした。" ' With myCtrlBttn .DescriptionText = "[辞書に登録]処理前ポップアップメニュー" .Style = msoButtonIconAndWrapCaption .Caption = myTitle & vbCrLf & "[辞書に登録]" & vbCrLf & myMsg .TooltipText = "該当する蛍光ペン書式の単語がありません。" .FaceId = 1019 myFaceId = .FaceId End With ' With myCtrlBttnOk .DescriptionText = "[辞書に登録]処理:[OK]ボタン" .Style = msoButtonIconAndCaption .Caption = "OK" & Space(48) .TooltipText = "処理を中止します。" .FaceId = 964 .OnAction = "EspRevizoBttnMyOk" End With End If Rem *----*----* *----*----* *----*----* *----*----*' ' CommandBars(myTitle).Controls(1).FaceId = myFaceId Beep Do On Error Resume Next myCmmdBar.ShowPopup On Error GoTo 0 DoEvents If CommandBars(myTitle).Controls(1).FaceId <> myFaceId Then Exit Do Loop ' On Error Resume Next myCmmdBar.Delete CommandBars(myTitle).Controls(1).FaceId = 2533 On Error GoTo 0 ' GoTo EspRevizoLeksikoSubExit Rem *----*----* *----*----* *----*----* *----*----* ' EspRevizoLeksikoSubEntry: myDicName = ActiveDocument.Name myFullName = myFolder & "\" & myDicName ' On Error Resume Next CommandBars(mySubName).Delete On Error GoTo 0 ' Set myCmmdBar = CommandBars.Add(Name:=mySubName, Position:=msoBarPopup, Temporary:=True) Set myCtrlBttn = myCmmdBar.Controls.Add(Type:=msoControlButton, Before:=1, Temporary:=True) Set myCtrlBttnOk = myCmmdBar.Controls.Add(Type:=msoControlButton, Before:=2, Temporary:=True) Set myCtrlBttnCancel = myCmmdBar.Controls.Add(Type:=msoControlButton, Before:=3, Temporary:=True) ' myMsg = "単語を辞書に登録します。" & vbCrLf myMsg = myMsg & "( " & myDicName & " ) " & vbCrLf & vbCrLf myMsg = myMsg & "処理を中止したい場合は、" & vbCrLf myMsg = myMsg & "[キャンセル]を選択して下さい。" ' With myCtrlBttn .DescriptionText = "[辞書に登録]処理前ポップアップメニュー" .Style = msoButtonIconAndWrapCaption .Caption = myTitle & vbCrLf & "[辞書に登録]" & vbCrLf & myMsg .TooltipText = "単語を辞書に登録します。" .FaceId = 1089 myFaceId = .FaceId End With ' With myCtrlBttnOk .DescriptionText = "[辞書に登録]処理:[OK]ボタン" .Style = msoButtonIconAndCaption .Caption = "OK" & Space(48) .TooltipText = "この後、訳語を入力して下さい。" .FaceId = 964 .OnAction = "EspRevizoBttnMyOk" End With ' With myCtrlBttnCancel .DescriptionText = "[辞書に登録]処理:[キャンセル]ボタン" .Style = msoButtonIconAndCaption .Caption = "キャンセル" .TooltipText = "[辞書に登録]処理を中止します。" .FaceId = 330 .OnAction = "EspRevizoBttnMyCancel" End With Rem *----*----* *----*----* *----*----* *----*----* ' CommandBars(myTitle).Controls(1).FaceId = myFaceId Beep Do On Error Resume Next myCmmdBar.ShowPopup On Error GoTo 0 DoEvents If CommandBars(myTitle).Controls(1).FaceId <> myFaceId Then Exit Do Loop ' Select Case CommandBars(myTitle).Controls(1).FaceId Case 964 myAns = vbOK Case Else myAns = vbCancel End Select ' On Error Resume Next myCmmdBar.Delete CommandBars(myTitle).Controls(1).FaceId = 2533 On Error GoTo 0 Rem *----*----* *----*----* *----*----* *----*----* ' If myAns <> vbOK Then GoTo EspRevizoLeksikoSubExit ' Rem 実行中の辞書に追加する。 For Each myPara In ActiveDocument.Paragraphs myText = Replace(myPara.Range.Text, vbCrLf, "") myText = Replace(myText, vbCr, "") If myText <> "" Then myKey = Left(myText, InStr(myText, ":") - 1) myKey = Trim(myKey) myItem = Mid(myText, InStr(myText, ":") + 1) myItem = Trim(myItem) If Not myDic.Exists(myKey) Then Call myDic.Add(myKey, myItem) myPara.Range.Font.Color = wdColorAutomatic End If End If Next ' myPara Rem *----*----* *----*----* *----*----* *----*----* ' Rem 辞書の文書を保存。テキスト形式で保存。 ActiveDocument.SaveAs FileName:=myFullName, FileFormat:=wdFormatText, AddToRecentFiles:=False Rem 文書を閉じる。 ActiveDocument.Close Rem *----*----* *----*----* *----*----* *----*----* ' myMsg = "辞書に単語を登録しました。" & vbCrLf myMsg = myMsg & "( " & myDicName & " )" ' On Error Resume Next CommandBars(mySubName).Delete On Error GoTo 0 ' Set myCmmdBar = CommandBars.Add(Name:=mySubName, Position:=msoBarPopup, Temporary:=True) Set myCtrlBttn = myCmmdBar.Controls.Add(Type:=msoControlButton, Before:=1, Temporary:=True) Set myCtrlBttnOk = myCmmdBar.Controls.Add(Type:=msoControlButton, Before:=2, Temporary:=True) ' With myCtrlBttn .DescriptionText = "[辞書に登録]処理後ポップアップメニュー" .Style = msoButtonIconAndWrapCaption .Caption = myTitle & vbCrLf & "[辞書に登録]" & vbCrLf & myMsg .TooltipText = "[辞書に登録]を実行しました。" .FaceId = 487 myFaceId = .FaceId End With ' With myCtrlBttnOk .DescriptionText = "[辞書に登録]処理:[OK]ボタン" .Style = msoButtonIconAndCaption .Caption = "OK" & Space(32) .TooltipText = "[辞書に登録]を実行しました。" .FaceId = 964 .OnAction = "EspRevizoBttnMyOk" End With Rem *----*----* *----*----* *----*----* *----*----* ' CommandBars(myTitle).Controls(1).FaceId = myFaceId Beep Do On Error Resume Next myCmmdBar.ShowPopup On Error GoTo 0 DoEvents If CommandBars(myTitle).Controls(1).FaceId <> myFaceId Then Exit Do Loop ' On Error Resume Next myCmmdBar.Delete CommandBars(myTitle).Controls(1).FaceId = 2533 On Error GoTo 0 Rem *----*----* *----*----* *----*----* *----*----* ' EspRevizoLeksikoSubExit: Set myCmmdBar = Nothing Set myCtrlBttn = Nothing Set myCtrlBttnOk = Nothing Set myCtrlBttnCancel = Nothing End Sub ' EspRevizoLeksiko *----*----* *----*----* *----*----* *----*----* Sub EspRevizoHiLight(Optional myDummy As Boolean) Rem *----*----* *----*----* *----*----* *----*----* Rem [蛍光ペン書式検索](水色・明るい緑) Rem *----*----* *----*----* *----*----* *----*----* Dim myCount As Long Dim myTitle As String Dim myMsg As String ' Dim myCmmdBar As CommandBar Dim myCtrlBttn As CommandBarControl Dim myCtrlBttnOk As CommandBarControl Dim mySubName As String Dim myFaceId As Long Rem *----*----* *----*----* *----*----* *----*----* ' Call EspRevizoConst("myTitle", myTitle) mySubName = "EspRevizoHiLight" ' If Selection.Range.Text <> "" Then Selection.Collapse wdCollapseEnd Exit Sub End If Rem *----*----* *----*----* *----*----* *----*----* ' EspRevizoHiLightSubEntry: Rem 蛍光ペン書式を検索。 With Selection.Find .ClearFormatting .Highlight = True ' 蛍光ペン書式を検索することを指定 .Text = "" .Replacement.Text = "" .Forward = True .Wrap = wdFindStop End With ' Rem 検索を実行。 Do While Selection.Find.Execute Select Case Selection.Range.HighlightColorIndex Case wdTurquoise, wdBrightGreen Rem ルビなどのフィールドが設定されている場合は、フィールドを解除する。 If AscW(Selection.Range.Words.Item(1).Text) = 21 Then With Selection .MoveRight Unit:=wdCharacter, Count:=1, Extend:=wdExtend .Start = .Range.Characters.First.Start .End = .Range.Characters.Last.End .Range.PhoneticGuide Text:="", Alignment:=wdPhoneticGuideAlignmentCenter, _ Raise:=9, FontSize:=5, FontName:="MS UI Gothic" .Find.Execute ' カーソルが単語の先頭に行くため、再検索し、単語を選択状態にする。 End With End If Exit Do End Select Loop Rem *----*----* *----*----* *----*----* *----*----* ' If Not Selection.Find.Found Then On Error Resume Next CommandBars(mySubName).Delete On Error GoTo 0 ' Set myCmmdBar = CommandBars.Add(Name:=mySubName, Position:=msoBarPopup, Temporary:=True) Set myCtrlBttn = myCmmdBar.Controls.Add(Type:=msoControlButton, Before:=1, Temporary:=True) Set myCtrlBttnOk = myCmmdBar.Controls.Add(Type:=msoControlButton, Before:=2, Temporary:=True) ' myMsg = "該当する書式は、ありません。" ' With myCtrlBttn .DescriptionText = "[蛍光ペン書式検索]処理後ポップアップメニュー" .Style = msoButtonIconAndWrapCaption .Caption = myTitle & vbCrLf & "[蛍光ペン書式検索]" & vbCrLf & myMsg .TooltipText = "[蛍光ペン書式検索]を実行しました。" .FaceId = 1019 myFaceId = .FaceId End With ' With myCtrlBttnOk .DescriptionText = "[蛍光ペン書式検索]処理:[OK]ボタン" .BeginGroup = True .Style = msoButtonIconAndCaption .Caption = "OK" & Space(32) .TooltipText = "該当する書式は、ありません。" .FaceId = 964 .OnAction = "EspRevizoBttnMyOk" End With Rem *----*----* *----*----* *----*----* *----*----* ' CommandBars(myTitle).Controls(1).FaceId = myFaceId Beep Do On Error Resume Next myCmmdBar.ShowPopup On Error GoTo 0 DoEvents If CommandBars(myTitle).Controls(1).FaceId <> myFaceId Then Exit Do Loop ' On Error Resume Next myCmmdBar.Delete CommandBars(myTitle).Controls(1).FaceId = 2533 On Error GoTo 0 End If Rem *----*----* *----*----* *----*----* *----*----* ' EspRevizoHiLightSubExit: Set myCmmdBar = Nothing Set myCtrlBttn = Nothing Set myCtrlBttnOk = Nothing End Sub ' EspRevizoHiLight *----*----* *----*----* *----*----* *----*----* Sub EspRevizoNoHiLight(Optional myDummy As Boolean) Rem *----*----* *----*----* *----*----* *----*----* Rem [蛍光ペン書式解除] Rem *----*----* *----*----* *----*----* *----*----* Dim myStartMarker As Word.Range Dim myCount As Long Dim myTitle As String Dim myMsg As String Dim myAns As Long ' Dim myCmmdBar As CommandBar Dim myCtrlBttn As CommandBarControl Dim myCtrlBttnOk As CommandBarControl Dim myCtrlBttnCancel As CommandBarControl Dim mySubName As String Dim myFaceId As Long Rem *----*----* *----*----* *----*----* *----*----* ' Call EspRevizoConst("myTitle", myTitle) mySubName = "EspRevizoNoHiLight" ' On Error Resume Next CommandBars(mySubName).Delete On Error GoTo 0 ' Set myCmmdBar = CommandBars.Add(Name:=mySubName, Position:=msoBarPopup, Temporary:=True) Set myCtrlBttn = myCmmdBar.Controls.Add(Type:=msoControlButton, Before:=1, Temporary:=True) Set myCtrlBttnOk = myCmmdBar.Controls.Add(Type:=msoControlButton, Before:=2, Temporary:=True) Set myCtrlBttnCancel = myCmmdBar.Controls.Add(Type:=msoControlButton, Before:=3, Temporary:=True) ' myMsg = "カーソル位置以降の" & vbCrLf myMsg = myMsg & "蛍光ペン書式を解除します。" ' With myCtrlBttn .DescriptionText = "[蛍光ペン書式解除]処理前ポップアップメニュー" .Style = msoButtonIconAndWrapCaption .Caption = myTitle & vbCrLf & "[蛍光ペン書式解除]" & vbCrLf & myMsg .TooltipText = "[蛍光ペン書式解除]を実行しますか?" .FaceId = 1089 myFaceId = .FaceId End With ' With myCtrlBttnOk .DescriptionText = "[蛍光ペン書式解除]処理:[OK]ボタン" .BeginGroup = True .Style = msoButtonIconAndCaption .Caption = "OK" .TooltipText = "[蛍光ペン書式解除]を実行!" .FaceId = 964 .OnAction = "EspRevizoBttnMyOk" End With ' With myCtrlBttnCancel .DescriptionText = "[蛍光ペン書式解除]処理:[キャンセル]ボタン" .Style = msoButtonIconAndCaption .Caption = "キャンセル" & Space(24) .TooltipText = "[蛍光ペン書式解除]処理を中止します。" .FaceId = 330 .OnAction = "EspRevizoBttnMyCancel" End With Rem *----*----* *----*----* *----*----* *----*----* ' CommandBars(myTitle).Controls(1).FaceId = myFaceId Beep Do On Error Resume Next myCmmdBar.ShowPopup On Error GoTo 0 DoEvents If CommandBars(myTitle).Controls(1).FaceId <> myFaceId Then Exit Do Loop ' Select Case CommandBars(myTitle).Controls(1).FaceId Case 964 myAns = vbOK Case Else myAns = vbCancel End Select ' On Error Resume Next myCmmdBar.Delete CommandBars(myTitle).Controls(1).FaceId = 2533 On Error GoTo 0 Rem *----*----* *----*----* *----*----* *----*----* ' If myAns <> vbOK Then GoTo EspRevizoNoHiLightSubExit End If Rem *----*----* *----*----* *----*----* *----*----* ' EspRevizoNoHiLightSubEntry: Rem 検索開始点の取得。 Selection.Collapse wdCollapseStart Set myStartMarker = Selection.Range Rem Selection.HomeKey Unit:=wdStory ' 一括変換の場合は、注釈を外す。 myCount = 0 ' Rem 蛍光ペン書式を検索。 With Selection.Find .ClearFormatting .Highlight = True ' 蛍光ペンを検索することを指定 .Text = "" .Replacement.Text = "" .Forward = True .Wrap = wdFindStop End With ' Rem 検索を実行。 Do While Selection.Find.Execute Select Case Selection.Range.HighlightColorIndex Case wdBrightGreen, wdTurquoise ' ' 明るい緑・水色 Rem ルビなどのフィールドが設定されている場合は、フィールドを解除する。 If AscW(Selection.Range.Words.Item(1).Text) = 21 Then With Selection .MoveRight Unit:=wdCharacter, Count:=1, Extend:=wdExtend .Start = .Range.Characters.First.Start .End = .Range.Characters.Last.End .Range.PhoneticGuide Text:="", Alignment:=wdPhoneticGuideAlignmentCenter, _ Raise:=9, FontSize:=5, FontName:="MS UI Gothic" .Find.Execute ' カーソルが単語の先頭に行くため、再検索し、単語を選択状態にする。 End With End If Selection.Range.HighlightColorIndex = wdNoHighlight myCount = myCount + 1 End Select Selection.Collapse wdCollapseEnd Loop Rem *----*----* *----*----* *----*----* *----*----* ' On Error Resume Next CommandBars(mySubName).Delete On Error GoTo 0 ' Set myCmmdBar = CommandBars.Add(Name:=mySubName, Position:=msoBarPopup, Temporary:=True) Set myCtrlBttn = myCmmdBar.Controls.Add(Type:=msoControlButton, Before:=1, Temporary:=True) Set myCtrlBttnOk = myCmmdBar.Controls.Add(Type:=msoControlButton, Before:=2, Temporary:=True) ' If myCount = 0 Then Rem 蛍光ペン書式の文字列がない場合。 myMsg = "該当する書式は、ありません。" Else myMsg = "蛍光ペン書式を解除しました。" End If ' With myCtrlBttn .DescriptionText = "[蛍光ペン書式解除]処理後ポップアップメニュー" .Style = msoButtonIconAndWrapCaption .Caption = myTitle & vbCrLf & "[蛍光ペン書式解除]" & vbCrLf & myMsg .TooltipText = "[蛍光ペン書式解除]を実行しました。" If myCount = 0 Then .FaceId = 1019 Else .FaceId = 487 End If myFaceId = .FaceId End With ' With myCtrlBttnOk .DescriptionText = "[蛍光ペン書式解除]処理:[OK]ボタン" .BeginGroup = True .Style = msoButtonIconAndCaption .Caption = "OK" & Space(36) If myCount = 0 Then .TooltipText = "該当する書式は、ありません。" Else .TooltipText = "蛍光ペン書式を解除しました。" End If .FaceId = 964 .OnAction = "EspRevizoBttnMyOk" End With Rem *----*----* *----*----* *----*----* *----*----* ' CommandBars(myTitle).Controls(1).FaceId = myFaceId Beep Do On Error Resume Next myCmmdBar.ShowPopup On Error GoTo 0 DoEvents If CommandBars(myTitle).Controls(1).FaceId <> myFaceId Then Exit Do Loop ' On Error Resume Next myCmmdBar.Delete CommandBars(myTitle).Controls(1).FaceId = 2533 On Error GoTo 0 Rem *----*----* *----*----* *----*----* *----*----* ' Rem 検索開始点に戻る。 myStartMarker.Select Rem *----*----* *----*----* *----*----* *----*----* ' EspRevizoNoHiLightSubExit: Set myCmmdBar = Nothing Set myCtrlBttn = Nothing Set myCtrlBttnOk = Nothing Set myCtrlBttnCancel = Nothing ' Set myStartMarker = Nothing End Sub ' EspRevizoNoHiLight *----*----* *----*----* *----*----* *----*----* Sub EspRevizoPopItem(myDic As Variant) Rem *----*----* *----*----* *----*----* *----*----* Rem [訳語の表示] Rem *----*----* *----*----* *----*----* *----*----* Dim myLatin As String Dim myLatinEx As String Dim myMarks As String Dim myPttn As String ' Dim myFlagChrs As Boolean Dim myCount As Long Dim i As Long ' Dim myFlag As Boolean Dim myWord As String Dim myWordPrev As String Dim myItem As String ' Dim myTitle As String Dim myText As String Dim myMsg As String Dim myAns As Long ' Dim myCmmdBar As CommandBar Dim myCtrlBttn As CommandBarControl Dim myCtrlBttnOk As CommandBarControl Dim mySubName As String Dim myFaceId As Long Rem *----*----* *----*----* *----*----* *----*----* ' Call EspRevizoConst("myTitle", myTitle) mySubName = "EspRevizoPopItem" ' Rem Unicode(16進)によるラテン文字の文字コードの範囲を指定する。 myLatin = "A-Za-z0-9" ' 基本ラテン文字 myMarks = "\-^^.\@" ' 句読点:連字符・屈音符・終止符・単価記号 myMarks = myMarks & "\u0027" & "\u2019" ' 句読点:単一引用符 myLatinEx = ChrW(Val("&h00C0")) & "-" & ChrW(Val("&h00FF")) ' 拡張ラテン文字 myLatinEx = myLatinEx & ChrW(Val("&h0100")) & "-" & ChrW(Val("&h017F")) myLatinEx = myLatinEx & ChrW(Val("&h0192")) & "-" & ChrW(Val("&h01FF")) myLatinEx = myLatinEx & ChrW(Val("&h1E80")) & "-" & ChrW(Val("&h1EF3")) myPttn = "[" & myLatin & myLatinEx & myMarks & "]" & "{1,}" Rem *----*----* *----*----* *----*----* *----*----* ' myWord = "" Rem 単語の取得 Selection.Expand (wdWord) Select Case Selection.Range.Text Case vbCr, vbVerticalTab, vbTab, vbFormFeed, vbLf Selection.MoveLeft Unit:=wdCharacter, Count:=2, Extend:=wdMove Selection.Expand (wdWord) End Select ' If AscW(Selection.Range.Text) = 21 Then If InStr(Selection.Range.Fields(1).Code, "\o(\s\up") > 0 Then Rem 選択範囲が[訳語ルビ]の場合 i = InStrRev(Selection.Range.Fields(1).Code, "),") myWord = Mid(Selection.Range.Fields(1).Code, i + 2) myWord = Left(myWord, Len(myWord) - 1) With Selection .Start = .Range.Characters.First.Start .End = .Range.Characters.Last.End .Range.PhoneticGuide Text:="", Alignment:=wdPhoneticGuideAlignmentCenter, _ Raise:=9, FontSize:=5, FontName:="MS UI Gothic" End With ' Rem 単語を検索して範囲選択する。 With Selection.Find .ClearFormatting .Text = myWord .Replacement.Text = "" .Forward = True .Wrap = wdFindStop .MatchAllWordForms = False .MatchSoundsLike = False .MatchFuzzy = False .MatchWildcards = False .Execute End With End If Rem *----*----* *----*----* Else Rem 選択範囲が[訳語ルビ]でない場合 Selection.Collapse wdCollapseStart If AscW(Selection.Range.Characters.First.Text) <= 32 Then Exit Sub ' Do Rem 文字列の先頭を探す。 myFlagChrs = False If Not Selection.Range.Characters.First.Previous Is Nothing Then If Selection.Range.Characters.First.Previous.Text Like myPttn Then myFlagChrs = True Selection.MoveLeft Unit:=wdCharacter, Count:=1, Extend:=wdMove End If End If ' If myFlagChrs = False Then Exit Do Loop ' Do Rem 文字列の先頭がラテン文字の場合、単語の先頭と見なす。 myFlagChrs = False If Selection.Range.Characters.First.Text Like "[" & myLatin & myLatinEx & "]" Then myFlagChrs = True Else myCount = Selection.MoveRight(Unit:=wdCharacter, Count:=1, Extend:=wdMove) If myCount = 0 Then Exit Sub End If ' If myFlagChrs = True Then Exit Do Loop ' Rem 単語を検索して範囲選択する。 With Selection.Find .ClearFormatting .Text = myPttn .Replacement.Text = "" .Forward = True .Wrap = wdFindStop .MatchAllWordForms = False .MatchSoundsLike = False .MatchFuzzy = False .MatchWildcards = True .Execute End With ' myWord = Selection.Range.Text End If Rem *----*----* *----*----* *----*----* *----*----* ' myFlag = False myItem = "" myWordPrev = myWord ' Call EspRevizoKontrolo(myFlag, myWord, myItem, myDic) Rem *----*----* *----*----* *----*----* *----*----* ' myText = myItem Call EspizoAeiou("", "_", myWord) Call EspizoCghjsu("", "^", myWord) Call EspizoUcOthers(myWord) ' On Error Resume Next CommandBars(mySubName).Delete On Error GoTo 0 ' Set myCmmdBar = CommandBars.Add(Name:=mySubName, Position:=msoBarPopup, Temporary:=True) Set myCtrlBttn = myCmmdBar.Controls.Add(Type:=msoControlButton, Before:=1, Temporary:=True) Set myCtrlBttnOk = myCmmdBar.Controls.Add(Type:=msoControlButton, Before:=2, Temporary:=True) ' If myFlag = True Then myText = Replace(myText, ";", ";" & vbCrLf) myMsg = myWord & vbCrLf & vbCrLf & myText & vbCrLf ' With myCtrlBttn .DescriptionText = "[訳語の表示]処理後ポップアップメニュー" .Style = msoButtonIconAndCaption .Caption = myTitle & ":" & "[訳語の表示]" & Space(30) .TooltipText = "[訳語の表示]を実行しました。" .FaceId = 2922 .OnAction = "EspRevizoBttnMyOk" myFaceId = .FaceId End With ' With myCtrlBttnOk .DescriptionText = "[訳語の表示]処理:[OK]ボタン" .BeginGroup = True .Style = msoButtonIconAndWrapCaption .Caption = myMsg .TooltipText = "訳語を表示しました。" .FaceId = 1087 .OnAction = "EspRevizoBttnMyOk" End With Else myMsg = "選択した単語が、辞書にありません。" & vbCrLf & vbCrLf & myWordPrev ' With myCtrlBttn .DescriptionText = "[訳語の表示]処理後ポップアップメニュー" .Style = msoButtonIconAndCaption .Caption = myTitle & ":" & "[訳語の表示]" & Space(20) .TooltipText = "[訳語の表示]を実行しました。" .FaceId = 1019 .OnAction = "EspRevizoBttnMyOk" myFaceId = .FaceId End With ' With myCtrlBttnOk .DescriptionText = "[訳語の表示]処理:[OK]ボタン" .BeginGroup = True .Style = msoButtonIconAndWrapCaption .Caption = myMsg .TooltipText = "選択した単語が、辞書にありません。" .FaceId = 1088 .OnAction = "EspRevizoBttnMyOk" End With End If ' CommandBars(myTitle).Controls(1).FaceId = myFaceId Do On Error Resume Next myCmmdBar.ShowPopup On Error GoTo 0 DoEvents If CommandBars(myTitle).Controls(1).FaceId <> myFaceId Then Exit Do Loop ' On Error Resume Next myCmmdBar.Delete CommandBars(myTitle).Controls(1).FaceId = 2533 On Error GoTo 0 Rem *----*----* *----*----* *----*----* *----*----* ' If Not Selection.Range.Characters.Last.Next Is Nothing Then Select Case Selection.Range.Characters.Last.Next.Text Case ".", ",", ":", ";" Selection.MoveRight Unit:=wdCharacter, Count:=1, Extend:=wdExtend End Select End If ' ' Selection.Collapse wdCollapseStart Selection.MoveRight Unit:=wdWord, Count:=1, Extend:=wdMove ' Set myCmmdBar = Nothing Set myCtrlBttn = Nothing Set myCtrlBttnOk = Nothing End Sub ' EspRevizoPopItem *----*----* *----*----* *----*----* *----*----* Sub EspRevizoKontrolo(myFlag As Boolean, myWord As String, myItem As String, myDic As Variant) Rem *----*----* *----*----* *----*----* *----*----* Rem 単語の検査 Rem *----*----* *----*----* *----*----* *----*----* Dim myWordPrev As String Dim myFlagNext As String Dim myWordNext As String Dim myItemNext As String ' Dim myTitle As String Dim i As Long Dim myHighlightColor As String Dim myCount As Long Rem *----*----* *----*----* *----*----* *----*----* ' Call EspRevizoConst("myTitle", myTitle) Rem 屈音符付き母音字を「_」付き代用文字に置換。 Rem エスペラント語正書文字を「^」付き代用文字に置換。 Call EspizoRvAeiou("", "_", myWord) Call EspizoRvCghjsu("", "^", myWord) Call EspizoRvOthers(myWord) myWordPrev = myWord Rem *----*----* *----*----* *----*----* *----*----* ' Rem 三点リーダーに対応。 If Right(myWord, 3) = "..." Then myWord = Left(myWord, Len(myWord) - 2) End If ' Rem 辞書を参照して、単語を検索する。 Rem (1) そのまま辞書を参照。 Call EspRevizoFleksio(myWord, myItem, myFlag, myDic) Rem *----*----* *----*----* *----*----* *----*----* ' Rem (2) 単語の末尾に終止符がある場合、終止符を除外して辞書を参照。 If myFlag = True Then Exit Sub ' If Right(myWord, 1) = "." Then Selection.MoveLeft Unit:=wdCharacter, Count:=1, Extend:=wdExtend myWord = Left(myWord, Len(myWord) - 1) Call EspRevizoFleksio(myWord, myItem, myFlag, myDic) End If Rem *----*----* *----*----* *----*----* *----*----* ' Rem (3) 連結した複数単語の場合は、単一の単語ごとに辞書を参照。 If myFlag = True Then Exit Sub ' If Selection.Range.Words.Count > 1 Then myWordNext = "" myItemNext = "" myFlagNext = "" For i = 1 To Selection.Range.Words.Count myFlag = False myWord = Selection.Range.Words.Item(i).Text Call EspizoRvAeiou("", "_", myWord) Call EspizoRvCghjsu("", "^", myWord) Call EspRevizoFleksio(myWord, myItem, myFlag, myDic) If myFlag = False Then myFlagNext = myFlagNext & "False" End If myWordNext = myWordNext & myWord & vbCr myItemNext = myItemNext & myItem & vbCr Next ' i myWord = myWordNext myItem = myItemNext ' Rem 連結した単語で、一つでも辞書にない場合は、 Rem 辞書にない単語と見なす。 If myFlagNext = "" Then myFlag = True Else myFlag = False End If End If Rem *----*----* *----*----* *----*----* *----*----* ' Rem (4) その他単語校正(メイン辞書・既存ユーザー辞書を参照)。 If myFlag = True Then Exit Sub ' If CommandBars(myTitle).Controls(4).FaceId = 4031 Then ' .TooltipText = "Officeの辞書も使用する。" If Application.CheckSpelling(myWordPrev, "CUSTOM.DIC", False) = True Then ' If Application.CheckSpelling(myWordPrev, "CUSTOM.DIC", False, , "myCustom2.DIC") = True Then myFlag = True myWord = myWordPrev myItem = "<mso>" End If End If End Sub ' EspRevizoKontrolo *----*----* *----*----* *----*----* *----*----* Sub EspRevizoFleksio(myWord As String, myItem As String, myFlag As Boolean, myDic As Variant) Rem *----*----* *----*----* *----*----* *----*----* Rem エスペラント単語の屈折に対処する。 Rem 名詞・形容詞の変化(deklinacio)/動詞の語尾変化(konjugacio)に対処。 Rem *----*----* *----*----* *----*----* *----*----* ' myItem = "?" myWord = Trim(myWord) Rem *----*----* *----*----* *----*----* *----*----* ' Rem 「-」の検出。 If Trim(myWord) = "-" Then myFlag = True myItem = "-" Exit Sub End If ' Rem 「.」の検出。 If Trim(myWord) = "." Then myFlag = True myItem = "" Exit Sub End If ' Rem 「re-」の検出。 If LCase(myWord) = "re" Then If Mid(Selection.Range.Text, InStr(LCase(Selection.Range.Text), "re") + 2, 1) = "-" Then myWord = myWord & "-" End If End If Rem *----*----* *----*----* *----*----* *----*----* ' Rem 相関詞・人称代名詞対格 Select Case LCase(myWord) Case "tion", "kion", "ion", "c^ion", "nenion" myWord = Left(LCase(myWord), Len(myWord) - 1) Case "tiuj", "kiuj", "iuj", "c^iuj", "neniuj" myWord = Left(LCase(myWord), Len(myWord) - 1) Case "tiun", "kiun", "iun", "c^iun", "neniun" myWord = Left(LCase(myWord), Len(myWord) - 1) Case "tiujn", "kiujn", "iujn", "c^iujn", "neniujn" myWord = Left(LCase(myWord), Len(myWord) - 2) Case "tiaj", "kiaj", "iaj", "c^iaj", "neniaj" myWord = Left(LCase(myWord), Len(myWord) - 1) Case "tian", "kian", "ian", "c^ian", "nenian" myWord = Left(LCase(myWord), Len(myWord) - 1) Case "tiajn", "kiajn", "iajn", "c^iajn", "neniajn" myWord = Left(LCase(myWord), Len(myWord) - 2) Case "tien", "kien", "ien", "c^ien", "nenien" myWord = Left(LCase(myWord), Len(myWord) - 1) Case "min", "vin", "lin", "s^in", "g^in", "nin", "ilin", "sin" myWord = Left(LCase(myWord), Len(myWord) - 1) Case "mian", "vian", "lian", "s^ian", "g^ian", "nian", "ilian", "sian" myWord = Left(LCase(myWord), Len(myWord) - 1) Case "mian", "viaj", "liaj", "s^iaj", "g^iaj", "niaj", "iliaj", "siaj" myWord = Left(LCase(myWord), Len(myWord) - 1) Case "miajn", "viajn", "liajn", "s^iajn", "g^iajn", "niajn", "iliajn", "siajn" myWord = Left(LCase(myWord), Len(myWord) - 2) Rem あり得ない単語:複数形-事物全体-相関詞 Case "tioj", "kioj", "ioj", "c^ioj", "nenioj" Exit Sub Case "tiojn", "kiojn", "iojn", "c^iojn", "neniojn" Exit Sub Rem 複数形だけの単語 Case "plura", "Plura" Exit Sub Case "plurajn", "Plurajn" myWord = Left(LCase(myWord), Len(myWord) - 1) End Select Rem *----*----* *----*----* *----*----* *----*----* ' Call EspRevizoDicKey(myFlag, myWord, myItem, myDic) If myFlag = True Then Exit Sub Rem *----*----* *----*----* *----*----* *----*----* ' If Len(myWord) >= 3 Then Rem 名詞語尾省略形 Select Case Right(myWord, 1) Case ChrW(Val("&h0027")), ChrW(Val("&h2019")) ' 単一引用符 myWord = Left(myWord, Len(myWord) - 1) & "o" GoTo EspRevizoFleksioSubEntry End Select End If If Len(myWord) >= 4 Then Rem 冠詞語尾省略形 Select Case Left(myWord, 2) Case "L" & ChrW(Val("&h0027")), "L" & ChrW(Val("&h2019")) myWord = Mid(myWord, 3) Case "l" & ChrW(Val("&h0027")), "l" & ChrW(Val("&h2019")) myWord = Mid(myWord, 3) End Select End If Rem *----*----* *----*----* *----*----* *----*----* ' If Len(myWord) >= 5 Then Rem 複数形-対格 Select Case Right(myWord, 3) Case "ajn" myWord = Left(myWord, Len(myWord) - 2) GoTo EspRevizoFleksioSubEntry Case "ojn" myWord = Left(myWord, Len(myWord) - 2) GoTo EspRevizoFleksioSubEntry End Select End If ' If Len(myWord) >= 4 Then Rem 複数形-主格/単数形-対格/動詞語尾・対格副詞 Select Case Right(myWord, 2) Case "oj" myWord = Left(myWord, Len(myWord) - 1) GoTo EspRevizoFleksioSubEntry Case "on" myWord = Left(myWord, Len(myWord) - 1) GoTo EspRevizoFleksioSubEntry Case "aj" myWord = Left(myWord, Len(myWord) - 1) GoTo EspRevizoFleksioSubEntry Case "an" myWord = Left(myWord, Len(myWord) - 1) GoTo EspRevizoFleksioSubEntry Case "is", "as", "os", "us" myWord = Left(myWord, Len(myWord) - 2) & "i" myWord = LCase(myWord) GoTo EspRevizoFleksioSubEntry Case "en" myWord = Left(myWord, Len(myWord) - 2) & "e" myWord = LCase(myWord) GoTo EspRevizoFleksioSubEntry End Select End If ' Rem 副詞・命令形-動詞 If Len(myWord) >= 3 Then Select Case Right(myWord, 1) Case "e" myWord = Left(myWord, Len(myWord) - 1) & "a" myWord = LCase(myWord) GoTo EspRevizoFleksioSubEntry Case "u" myWord = Left(myWord, Len(myWord) - 1) & "i" myWord = LCase(myWord) GoTo EspRevizoFleksioSubEntry End Select End If Rem *----*----* *----*----* *----*----* *----*----* ' EspRevizoFleksioSubEntry: Call EspRevizoDicKey(myFlag, myWord, myItem, myDic) If myFlag = True Then Exit Sub Rem *----*----* *----*----* *----*----* *----*----* ' If Right(myWord, 1) = "a" Then myWord = Left(myWord, Len(myWord) - 1) & "i" Call EspRevizoDicKey(myFlag, myWord, myItem, myDic) If myFlag = True Then Exit Sub ' myWord = Left(myWord, Len(myWord) - 1) & "a" End If Rem *----*----* *----*----* *----*----* *----*----* ' If Len(myWord) >= 5 Then Rem 抽象名詞・動詞語根名詞 Select Case Right(myWord, 3) Case "eco" myWord = Left(myWord, Len(myWord) - 3) & "a" GoTo EspRevizoFleksioSubExit Case "ado" myWord = Left(myWord, Len(myWord) - 3) & "i" myWord = LCase(myWord) GoTo EspRevizoFleksioSubExit End Select End If ' Rem 能動分詞 If Len(myWord) >= 6 Then Select Case Right(myWord, 4) Case "inta", "anta", "onta" myWord = Left(myWord, Len(myWord) - 4) & "i" myWord = LCase(myWord) GoTo EspRevizoFleksioSubExit End Select End If ' Rem 受動分詞 If Len(myWord) >= 5 Then Select Case Right(myWord, 3) Case "ita", "ata", "ota" myWord = Left(myWord, Len(myWord) - 3) & "i" myWord = LCase(myWord) GoTo EspRevizoFleksioSubExit End Select End If Rem *----*----* *----*----* *----*----* *----*----* ' EspRevizoFleksioSubExit: Call EspRevizoDicKey(myFlag, myWord, myItem, myDic) If myFlag = True Then Exit Sub Rem *----*----* *----*----* *----*----* *----*----* ' Rem 品詞転換(形容詞/名詞/副詞) If Len(myWord) >= 3 Then Select Case Right(myWord, 1) Case "a" myWord = Left(myWord, Len(myWord) - 1) & "o" Case "o" myWord = Left(myWord, Len(myWord) - 1) & "a" Case "e" myWord = Left(myWord, Len(myWord) - 1) & "a" End Select End If Rem *----*----* *----*----* *----*----* *----*----* ' Call EspRevizoDicKey(myFlag, myWord, myItem, myDic) ' If myFlag = True Then Exit Sub End Sub ' EspRevizoFleksio *----*----* *----*----* *----*----* *----*----* Sub EspRevizoDicKey(myFlag As Boolean, myWord As String, myItem As String, myDic As Variant) Rem *----*----* *----*----* *----*----* *----*----* Rem 単語に関して、辞書を参照する。 Rem *----*----* *----*----* *----*----* *----*----* ' If myDic.Exists(myWord) Then myFlag = True myItem = myDic.Item(myWord) Call EspRevizoDicItem(myWord, myItem) Exit Sub End If Rem *----*----* *----*----* *----*----* *----*----* ' Select Case Left(myWord, 1) Case "A" To "Z" If myDic.Exists(LCase(myWord)) Then myFlag = True myWord = LCase(myWord) myItem = myDic.Item(myWord) Call EspRevizoDicItem(myWord, myItem) Exit Sub End If End Select End Sub ' EspRevizoDicKey *----*----* *----*----* *----*----* *----*----* Sub EspRevizoDicItem(myWord As String, myItem As String) Rem *----*----* *----*----* *----*----* *----*----* Rem 特定の単語に関して、辞書の訳語を置換する。 Rem *----*----* *----*----* *----*----* *----*----* ' Select Case LCase(myWord) Case "g^i" myItem = "それ[中性]" Case "ili" myItem = "[三・複]" Case "sia" myItem = "自身の" Case "c^i" myItem = "[近接]" Case "la" myItem = "[冠詞]" Case "re-" myItem = "[再び・元へ]" Case "je" myItem = "[〜に]" Case "povi" myItem = "<他>できる/かも知れない" Case "ne" myItem = "[否定]" Case "de" myItem = "〜の/から/によって" End Select End Sub ' EspRevizoDicItem *----*----* *----*----* *----*----* *----*----* Sub EspRevizoPhGuide(myItem As String) Rem *----*----* *----*----* *----*----* *----*----* Rem 訳語ルビ設定 Rem *----*----* *----*----* *----*----* *----*----* ' If Trim(myItem) = "" Then Exit Sub If Trim(myItem) = "-" Then Exit Sub Rem *----*----* *----*----* *----*----* *----*----* ' myItem = Replace(myItem, "<B>", "") myItem = Replace(myItem, "<O>", "") myItem = Replace(myItem, "<代>", "") myItem = Replace(myItem, "<前>", "") myItem = Replace(myItem, "<接>", "") ' With Selection .Range.PhoneticGuide Text:=myItem, Alignment:=wdPhoneticGuideAlignmentCenter, _ Raise:=9, FontSize:=4, FontName:="MS UI Gothic" ' .Fields(1).ShowCodes = False .SetRange Start:=.Start, End:=.End .Collapse wdCollapseEnd End With End Sub ' EspRevizoPhGuide *----*----* *----*----* *----*----* *----*----* Sub EspRevizoDicSelect(myFolder As String, myDicName As String, myHighlightColor As String, myCount As Long) Rem *----*----* *----*----* *----*----* *----*----* Rem 辞書に登録する単語(蛍光ペン書式の文字列)を検索 Rem *----*----* *----*----* *----*----* *----*----* Dim myDicPcase As String Dim myFullName As String Dim myDocOne As Document Dim myDocNew As Document Dim myDocDic As Document ' Dim myStartMarker As Word.Range Dim myPara As Paragraph Dim myWord As String Dim myPrevWord As String Dim myText As String Dim myAbbr As String ' Dim myStatusBar As String Dim myTitle As String Dim myMsg As String Dim myAns As Long Rem *----*----* *----*----* *----*----* *----*----* ' Application.ScreenUpdating = False ' Call EspRevizoConst("myAbbr", myAbbr) Call EspRevizoConst("myDicPcase", myDicPcase) Rem 書き出し先の辞書。 myFullName = myFolder & "\" & myDicName ' Set myDocOne = ActiveDocument Rem 作業用の文書を新規作成する。 Set myDocNew = Documents.Add myDocOne.Activate ' Rem 検索開始点の取得。(読み込み元の文書) Selection.Collapse wdCollapseStart Set myStartMarker = Selection.Range ' Rem 蛍光ペン書式を検索。 With Selection.Find .ClearFormatting .Highlight = True ' 蛍光ペンを検索することを指定 .Text = "" .Replacement.Text = "" .Forward = True .Wrap = wdFindStop End With ' 'myStatusBar = "辞書に登録する単語を文書から取り出します。" 'Application.StatusBar = myTitle & ":処理中" & " " & myStatusBar Rem *----*----* *----*----* *----*----* *----*----* ' EspRevizoDicSelectSubEntry: Rem 検索を実行。 Do While Selection.Find.Execute If Selection.Range.HighlightColorIndex = myHighlightColor Then Rem ルビなどのフィールドが設定されている場合は、フィールドを解除する。 If AscW(Selection.Range.Words.Item(1).Text) = 21 Then With Selection .Start = .Range.Characters.First.Start .End = .Range.Characters.Last.End .Range.PhoneticGuide Text:="", Alignment:=wdPhoneticGuideAlignmentCenter, _ Raise:=9, FontSize:=5, FontName:="MS UI Gothic" End With End If Rem *----*----* *----*----* ' Rem 空文字を範囲選択することがあるので、この場合は、処理を避ける。 If Selection.Range.Text <> "" Then If Selection.Range.Text = vbCr Then Exit Do ' 文書末尾にカーソルがある場合の対策。 myWord = Replace(myWord, vbCr, "") ' 文末に文字列があった場合の対策。 Rem *----*----* *----*----* ' Rem 屈音符付き母音字を「_」付き代用文字に置換。 Rem エスペラント語正書文字を「^」付き代用文字に置換。 myWord = Trim(Selection.Range.Text) Call EspizoRvAeiou("", "_", myWord) Call EspizoRvCghjsu("", "^", myWord) Call EspizoRvOthers(myWord) Rem *----*----* *----*----* ' myDocNew.Activate Selection.TypeText Text:=myWord & vbCrLf myCount = myCount + 1 myDocOne.Activate End If End If ' Selection.Collapse wdCollapseEnd Loop Rem *----*----* *----*----* *----*----* *----*----* ' If myCount = 0 Then myDocNew.Close SaveChanges:=wdDoNotSaveChanges Application.ScreenUpdating = True ' Rem 検索開始点に戻る。(読み込み元の文書) myStartMarker.Select ' GoTo EspRevizoDicSelectSubExit End If ' Rem 検索開始点に戻る。(読み込み元の文書) myStartMarker.Select Rem *----*----* *----*----* *----*----* *----*----* ' Rem 作業用の文書で取り出した単語を並び替える。 myDocNew.Activate Rem 文書末尾の改行を削る。 With Selection .EndKey Unit:=wdStory, Extend:=wdMove .TypeBackspace End With ' myStatusBar = "取り出した単語を昇順に並び替えします。" Application.StatusBar = myTitle & ":処理中" & " " & myStatusBar ' Rem 昇順に並べ替え。 Selection.WholeStory ' すべて選択。 On Error Resume Next ' 辞書に登録する単語が1件以下の場合に備える。 Selection.Sort ExcludeHeader:=False, FieldNumber:="段落", _ SortFieldType:=wdSortFieldJapanJIS, SortOrder:=wdSortOrderAscending, _ LanguageID:=wdJapanese Selection.HomeKey Unit:=wdStory, Extend:=wdMove Rem *----*----* *----*----* *----*----* *----*----* ' Rem 辞書を開く。 Documents.Open FileName:=myFullName, Format:=wdOpenFormatText, AddToRecentFiles:=False Documents(myDicName).Activate Selection.EndKey Unit:=wdStory, Extend:=wdMove Selection.TypeParagraph Rem 単語追加の開始点の取得。(辞書) Set myStartMarker = Selection.Range ' myStatusBar = "単語を辞書に追加する準備をします。" myStatusBar = myStatusBar & "( " & myDicName & " )" Application.StatusBar = myTitle & ":処理中" & " " & myStatusBar ' If myDicName = myDicPcase Then myText = "[社駅店商標地域路線名]" & myAbbr Else myText = "[自他形副代前接間擬略N]" & myAbbr End If Rem 辞書に登録する単語を追加する。 Rem 重複する単語は除外する。 myCount = 0 myPrevWord = "" For Each myPara In myDocNew.Paragraphs myDocNew.Activate If myPara.Range.Text <> myPrevWord Then myWord = Left(myPara.Range.Text, Len(myPara.Range.Text) - 1) Documents(myDicName).Activate If myDicName = myDicPcase Then With Selection .Font.Color = wdColorRed .TypeText Text:=myWord .Font.Color = wdColorSkyBlue .TypeText Text:=":" .Font.Color = wdColorAutomatic .TypeText Text:=myText & vbCrLf End With myCount = myCount + 1 Else With Selection .Font.Color = wdColorRed .TypeText Text:=myWord .Font.Color = wdColorSkyBlue .TypeText Text:=":" .Font.Color = wdColorAutomatic .TypeText Text:=myText & vbCrLf End With myCount = myCount + 1 End If End If myPrevWord = myPara.Range.Text Next myPara ' Rem 作業用の文書を閉じる。 myDocNew.Close SaveChanges:=wdDoNotSaveChanges Rem *----*----* *----*----* *----*----* *----*----* ' Application.ScreenUpdating = True ' Documents(myDicName).Activate Selection.TypeBackspace Rem 単語追加の開始点に戻る。(辞書) myStartMarker.Select Rem *----*----* *----*----* *----*----* *----*----* ' EspRevizoDicSelectSubExit: Set myDocOne = Nothing Set myDocNew = Nothing Set myStartMarker = Nothing End Sub ' EspRevizoDicSelect *----*----* *----*----* *----*----* *----*----* Sub EspRevizoInit(myDic As Variant) Rem *----*----* *----*----* *----*----* *----*----* Rem エスペラント語辞典読み込み処理(初期処理) Rem 機能... Rem エスペラント語辞典の単語を元に、当該処理用の辞書を作る。 Rem 注記... Rem 重複した単語は、訳語を連結して辞書に追加する。 Rem *----*----* *----*----* *----*----* *----*----* ' If TypeName(myDic) = "Dictionary" Then Exit Sub Rem *----*----* *----*----* *----*----* *----*----* ' Dim myShell As Variant ' IWshShell3 Dim myFso As Variant Dim myFile As Variant ' Dim myFolder As String Dim myFullName As String Dim myDicPejvo As String Dim myDicPcase As String Dim myDicLcase As String ' Dim myText As String Dim myKey As String Dim myItem As String ' Dim c As Long Dim i As Long Dim myMax As Long ' Dim myTitle As String Dim myStatusBar As String Dim myMsg As String Rem *----*----* *----*----* *----*----* *----*----* ' Rem マクロ名・関連フォルダ名・関連ファイル名 Call EspRevizoConst("myTitle", myTitle) Call EspRevizoConst("myFolder", myFolder) Call EspRevizoConst("myDicPejvo", myDicPejvo) Call EspRevizoConst("myDicPcase", myDicPcase) Call EspRevizoConst("myDicLcase", myDicLcase) ' Rem 辞書の単語総数 Call EspRevizoConst("myDicCount", myText) myMax = Val(myText) Rem *----*----* *----*----* *----*----* *----*----* ' Set myShell = CreateObject("WScript.Shell") Set myFso = CreateObject("Scripting.FileSystemObject") Set myDic = CreateObject("Scripting.Dictionary") Rem *----*----* *----*----* *----*----* *----*----* ' Application.ScreenUpdating = False Rem *----*----* *----*----* *----*----* *----*----* ' myFullName = myFolder & "\" & myDicPejvo Set myFile = myFso.OpenTextFile(myFullName, 1) ' c = 0 ' Do Until myFile.AtEndOfStream myText = myFile.ReadLine ' myKey = Left(myText, InStr(myText, ":") - 1) myItem = Mid(myText, InStr(myText, ":") + 1) ' If myKey <> "" Then Rem 訳語ルビ不具合予防のため、 Rem 訳語の「,」を半角空白にする。 訳語の波括弧を各括弧に置換する。 If myDic.Exists(myKey) Then Rem 重複した単語は、項目を追加する。 myItem = Replace(myItem, ",", " ") myItem = Replace(myItem, "{", "<") myItem = Replace(myItem, "}", ">") myDic(myKey) = myDic.Item(myKey) & " " & myItem Rem myTypeText = myKey & ": " & myDic.Item(myKey) & " // " & myItem Rem Selection.TypeText Text:=myTypeText & vbCrLf Else myItem = Replace(myItem, ",", " ") myItem = Replace(myItem, "{", "<") myItem = Replace(myItem, "}", ">") Rem 単語を辞書に追加にする。 Call myDic.Add(myKey, myItem) End If End If c = c + 1 ' i = c * 100 \ myMax myStatusBar = myTitle & ":処理中" myStatusBar = myStatusBar & " ( " & myFullName & "から辞書を取込中" & " ) " myStatusBar = myStatusBar & Format(i, "##0") & "% " Application.StatusBar = myStatusBar DoEvents Loop ' Rem 事前試行調査 件数確認用 Rem MsgBox myFullName & vbCrLf & "辞書に追加した単語数:" & myDic.Count & "件" myFile.Close Rem *----*----* *----*----* *----*----* *----*----* ' myFullName = myFolder & "\" & myDicPcase Set myFile = myFso.OpenTextFile(myFullName, 1) ' Do Until myFile.AtEndOfStream myText = myFile.ReadLine ' myKey = Left(myText, InStr(myText, ":") - 1) myItem = Mid(myText, InStr(myText, ":") + 1) ' If myKey <> "" Then Rem 訳語ルビ不具合予防のため、 Rem 訳語の「,」を半角空白にする。 訳語の波括弧を各括弧に置換する。 If myDic.Exists(myKey) Then Rem 重複した単語は、項目を追加する。 myItem = Replace(myItem, ",", " ") myItem = Replace(myItem, "{", "<") myItem = Replace(myItem, "}", ">") myDic(myKey) = myDic.Item(myKey) & ";" & myItem Rem myTypeText = myKey & ": " & myDic.Item(myKey) & " // " & myItem Rem Selection.TypeText Text:=myTypeText & vbCrLf Else myItem = Replace(myItem, ",", " ") myItem = Replace(myItem, "{", "<") myItem = Replace(myItem, "}", ">") Call myDic.Add(myKey, myItem) End If End If c = c + 1 ' i = c * 100 \ myMax myStatusBar = myTitle & ":処理中" & " " & Format(i, "##0") & "% " myStatusBar = myStatusBar & "( " & myFullName & "から辞書を作成中" & " )" Application.StatusBar = myStatusBar Loop ' myFile.Close Rem *----*----* *----*----* *----*----* *----*----* ' myFullName = myFolder & "\" & myDicLcase Set myFile = myFso.OpenTextFile(myFullName, 1) ' Do Until myFile.AtEndOfStream myText = myFile.ReadLine ' myKey = Left(myText, InStr(myText, ":") - 1) myItem = Mid(myText, InStr(myText, ":") + 1) ' If myKey <> "" Then Rem 訳語ルビ不具合予防のため、 Rem 訳語の「,」を半角空白にする。 訳語の波括弧を各括弧に置換する。 If myDic.Exists(myKey) Then Rem 重複した単語は、項目を追加する。 myItem = Replace(myItem, ",", " ") myItem = Replace(myItem, "{", "<") myItem = Replace(myItem, "}", ">") myDic(myKey) = myDic.Item(myKey) & ";" & myItem Rem myTypeText = myKey & ": " & myDic.Item(myKey) & " // " & myItem Rem Selection.TypeText Text:=myTypeText & vbCrLf Else myItem = Replace(myItem, ",", " ") myItem = Replace(myItem, "{", "<") myItem = Replace(myItem, "}", ">") Call myDic.Add(myKey, myItem) End If End If c = c + 1 ' i = c * 100 \ myMax myStatusBar = myTitle & ":処理中" & " " & Format(i, "##0") & "% " myStatusBar = myStatusBar & "( " & myFullName & "から辞書を作成中" & " )" Application.StatusBar = myStatusBar Loop ' myFile.Close Rem *----*----* *----*----* *----*----* *----*----* ' Application.ScreenUpdating = True Beep myStatusBar = myTitle & ":エスペラント語辞典の読み込み完了! " Application.StatusBar = myStatusBar & "辞書に追加した単語総数:" & myDic.Count & "件" ' Set myShell = Nothing Set myFso = Nothing Set myFile = Nothing Rem Set myDic = Nothing ' 呼び出し元で辞書を使うため、解放しない。 End Sub ' EspRevizoInit *----*----* *----*----* *----*----* *----*----* Sub EspRevizoConst(myFlag As String, myConst As String) Rem *----*----* *----*----* *----*----* *----*----* Rem 定数設定処理 Rem *----*----* *----*----* *----*----* *----*----* Dim myTitle As String Dim myDicPejvo As String Dim myDicPcase As String Dim myDicLcase As String Dim myMsg As String Rem *----*----* *----*----* *----*----* *----*----* ' Rem マクロ名。 myTitle = "EspRevizo" ' Rem 関連ファイル名。 myDicPejvo = "pejvo_s.txt" myDicPcase = "EspRevizoPcase.csv" myDicLcase = "EspRevizoLcase.csv" Rem *----*----* *----*----* *----*----* *----*----* ' Select Case myFlag Case "myTitle" ' マクロ名 myConst = myTitle Case "myDicPejvo" ' エスペラント語辞典 myConst = myDicPejvo Case "myDicPcase" ' 固有名詞辞書 myConst = myDicPcase Case "myDicLcase" ' 小文字辞書 myConst = myDicLcase Case "myAbbr" ' 専門分野略記号 myConst = "【医】【印】【運】【E】【映】【園】" myConst = myConst & "【カ】【化】【果】【菓】【貨】" myConst = myConst & "【解】【海】【貝】【学】【楽】【環】" myConst = myConst & "【キ】【機】【気】【魚】" myConst = myConst & "【空】【軍】【経】【芸】【劇】【建】" myConst = myConst & "【古地名】【語】【光】【鉱】【国名】" myConst = myConst & "【史】【詩】【写】【車】【宗】【修】" myConst = myConst & "【商】【情】【植】【織】【心】【神】【人名】" myConst = myConst & "【数】【政】【聖】【生】【声】" myConst = myConst & "【単】【地】【地名】【虫】【鳥】" myConst = myConst & "【通】【哲】【鉄】【天】【電】【統】【動】" myConst = myConst & "【日】【農】【馬】【美】【病】【服】【仏】【文】【法】" myConst = myConst & "【薬】【ユ】【遊】【理】【料】【論】【転】" Case "myFolder", "myDicCount" GoTo EspRevizoConstSubEntry Case Else myMsg = "処理できません!" & vbCrLf myMsg = myMsg & "EspRevizoConst" & vbCrLf myMsg = myMsg & "myFlag" & "未対応:" & myFlag Call MsgBox(myMsg, vbOK + vbCritical + vbDefaultButton2, myTitle) Exit Sub End Select ' Exit Sub Rem *----*----* *----*----* *----*----* *----*----* ' EspRevizoConstSubEntry: Dim myShell As Variant ' IWshShell3 Dim myFso As Variant Dim myFile As Variant ' Dim myFolder As String Dim myFullName As String Dim myDicCount As Long ' Dim myStatusBar As String ' Set myShell = CreateObject("WScript.Shell") Set myFso = CreateObject("Scripting.FileSystemObject") Rem *----*----* *----*----* *----*----* *----*----* ' Rem 関連ファイルの保存先フォルダ。 myFolder = myShell.Specialfolders("MyDocuments") ' マイドキュメント myFolder = myFolder & "\EspRevizo\PEJVO" ' マイドキュメント内のフォルダ指定 Rem *----*----* *----*----* *----*----* *----*----* ' Select Case myFlag Case "myFolder" ' 関連フォルダ。 myConst = myFolder Rem *----*----* *----*----* ' Case "myDicCount" ' 辞書の単語総数 myDicCount = 0 myFullName = myFolder & "\" & myDicPejvo With myFso.OpenTextFile(myFullName, 8) myDicCount = .Line .Close End With myFullName = myFolder & "\" & myDicPcase With myFso.OpenTextFile(myFullName, 8) myDicCount = myDicCount + .Line .Close End With myFullName = myFolder & "\" & myDicLcase With myFso.OpenTextFile(myFullName, 8) myDicCount = myDicCount + .Line .Close End With myConst = Str(myDicCount) End Select Rem *----*----* *----*----* *----*----* *----*----* ' EspRevizoConstSubExit: Set myShell = Nothing Set myFso = Nothing Set myFile = Nothing End Sub ' EspRevizoConst *----*----* *----*----* *----*----* *----*----*