Sub EspIndexXe()
Rem *----*----* *----*----* *----*----* *----*----*
Rem 蛍光ペン書式文字列 索引登録処理（エスペラント文字並び順対応）
Rem 作譜：Hitrock Camellia Shinopy
Rem 言語：Word VBA
Rem 機能...
Rem 1. 文書内にある蛍光ペン書式の文字列を検索し、
Rem 検索した文字列の索引登録する。
Rem 2. 索引を文書に挿入する場合、正しい順に並べるため、
Rem 音声符号付き文字の代用表記を[索引登録]の[読み]に設定する。
Rem 3. 半角以外の文字列について、索引項目の[読み]を入力する。
Rem 注記...
Rem 1. [索引登録処理]で、音声符号付き文字の代用表記を[索引登録]の[読み]に設定する。
Rem [索引登録処理]の実行後、蛍光ペン書式は解除される。
Rem 2. [読み入力処理（半角以外の文字列）]で、半角以外の文字列について、
Rem 登録した索引項目に応じて（特に漢字の読みについて）、ひらがなで読みを入力する。
Rem 3. [読み入力処理（半角以外の文字列）]が済んだ後、[後処理]を実行すること。
Rem （[後処理]ではIndexEntryフィールドから「 \t 」を削る。）
Rem 4. [後処理]実行後は、読み入力が再度できないので、
Rem 読みを設定する必要が後で生した場合は、[読み再入力 前処理]を実行した後、
Rem [読み入力処理（半角以外の文字列）]を実行する。（読み入力が済んだら、[後処理]を実行すること。）
Rem 5. [後処理]後に、[参考資料]タブの[索引の挿入]で索引を文書に挿入する。
Rem 6. 「;<=>?@」の各文字は、索引の見出し語に指定困難と思われる（見出し語として表示されない）。
Rem 7. 代用表記未対応の場合、[読み再入力 前処理]を実行することにより、
Rem その後に[読み入力処理 （半角以外の文字列）]で呼び出して、読みを入力することができる。
Rem 「EspIndexXeSurrogate」に対応する文字を追加して、最終的に解決すること。
Rem 履歴...
Rem 第01版：2010/03/25：作成。
Rem 第02版：2013/05/10：VariantをLongに変更。
Rem 第03版：2013/11/01：全角文字と半角文字が混在する索引項目が文字化けすることに対応。
Rem 第04版：2013/11/10：ショートカットメニューの処理選択の制御を変更。
Rem *----*----* *----*----* *----*----* *----*----*
Dim myTitle As String
Dim myOnAction As String
Dim myCmmdBar As CommandBar
Dim x As Long
Dim y As Long
Rem *----*----* *----*----* *----*----* *----*----*
'
myTitle = "EspIndexXe"
Call EspIndexXeShowPopupXy(False, -1, -1)
'
Call EspIndexXeCmmdBarMenu(myTitle & "Menu")
Set myCmmdBar = CommandBars(myTitle & "Menu")
Rem *----*----* *----*----* *----*----* *----*----*
'
EspIndexXeSubEntry:
Do
Beep
Call EspIndexXeOnAction(False, vbNullString)
Call EspIndexXeShowPopupXy(True, x, y)
'
If x = -1 Then
myCmmdBar.ShowPopup
Else
myCmmdBar.ShowPopup x, y
End If
DoEvents
'
Call EspIndexXeOnAction(True, myOnAction)
Call EspIndexXeShowPopupXy(False, myCmmdBar.Left, myCmmdBar.Top)
'
Select Case myOnAction
Case "索引登録処理"
Call EspIndexXeAuto(myTitle)
Case "読み入力処理（半角以外の文字列）"
Call EspIndexXeYomi(myTitle)
Case "後処理"
Call EspIndexXeTerm(myTitle)
Case "読み再入力 前処理"
Call EspIndexXeUndo(myTitle)
Case "閉じる"
GoTo EspIndexXeSubExit
Case Else
Call EspIndexXeShowPopupXy(False, -1, -1)
End Select
Loop
Rem *----*----* *----*----* *----*----* *----*----*
'
EspIndexXeSubExit:
On Error Resume Next
Set myCmmdBar = Nothing
myCmmdBar.Delete
On Error GoTo 0
End Sub ' EspIndexXe *----*----* *----*----* *----*----* *----*----*
Sub EspIndexXeAuto(myTitle As String)
Rem *----*----* *----*----* *----*----* *----*----*
Rem 蛍光ペン書式文字列索引登録処理
Rem *----*----* *----*----* *----*----* *----*----*
Dim myCount As Long
Dim myReading As String
Rem *----*----* *----*----* *----*----* *----*----*
'
myCount = 0
Selection.HomeKey Unit:=wdStory, Extend:=wdMove ' カーソル位置を文書の先頭まで移動。
'
With Selection.Find
.ClearFormatting
.Highlight = True
.Text = ""
End With
With Selection.Find.Replacement
.ClearFormatting
.Text = "^&"
End With
'
With Selection.Find
.Forward = True
.Wrap = wdFindStop
.Format = True
.MatchCase = False
.MatchWholeWord = False
.MatchByte = False
.MatchAllWordForms = False
.MatchSoundsLike = False
.MatchFuzzy = False
.MatchWildcards = True
End With
Rem *----*----* *----*----* *----*----* *----*----*
'
Application.ScreenUpdating = False
Do While Selection.Find.Execute(Replace:=wdReplaceOne)
ActiveWindow.ActivePane.View.ShowAll = True ' フィールドを表示する。
Selection.Range.HighlightColorIndex = wdNoHighlight ' 蛍光ペン書式を解除。
'
Rem 検索した文字列の指定範囲の後に、XE(索引登録)フィールドを挿入。
Rem 但し、編集記号等（ChrW(9)〜ChrW(13)）は取り込まない。
If Selection.Range.Text Like "[" & ChrW(9) & "-" & ChrW(13) & "]" Then
Selection.Collapse wdCollapseEnd
Else
If Selection.Range.Characters.Last Like "[" & ChrW(9) & "-" & ChrW(13) & "]" Then
Selection.MoveEnd Unit:=wdCharacter, Count:=-1
End If
'
Select Case Selection.Range.CharacterWidth
Case wdWidthHalfWidth ' 半角文字だけの文字列
myReading = Trim(Selection.Range.Text) ' [読み]に設定する文字列から先頭・末尾の空白を除外。
Call EspIndexXeReading(myReading) ' 音声符号付き文字の対処。
'
ActiveDocument.Indexes.MarkEntry Range:=Selection.Range, Entry:=Selection.Range.Text, _
EntryAutoText:=Selection.Range.Text, CrossReference:="", CrossReferenceAutoText:="", _
BookmarkName:="", Bold:=False, Italic:=False, Reading:=myReading
'
ActiveWindow.ActivePane.View.ShowAll = False ' フィールドを非表示にする。
Selection.MoveRight Unit:=wdCharacter, Count:=2, Extend:=wdMove
myCount = myCount + 1
'
Case wdWidthFullWidth ' 全角文字だけの文字列
With Dialogs(wdDialogMarkIndexEntry)
.Entry = StrConv(Selection.Range.Text, vbHiragana) ' [読み]のカタカナをひらがなに変換。
.CrossReference = ""
.EntryAutoText = Selection.Range.Text
.Show (1)
.Execute
End With
myCount = myCount + 1
'
Case Else ' 半角文字と全角文字が混在している文字列
myReading = Trim(Selection.Range.Text) ' [読み]に設定する文字列から先頭・末尾の空白を除外。
Call EspIndexXeReading(myReading) ' 音声符号付き文字の対処。
Rem myReading = StrConv(myReading, vbHiragana)
Rem ↑[読み]のカタカナをひらがなに変換をコメントアウト。
Rem 音声符号付き文字（ASCII範囲外の文字）が文字化けする（「?」表示になる）ため。
Rem 後日に、音声符号も文字化けすることが判明した。1文字ずつ対処することで解決。
'
ActiveDocument.Indexes.MarkEntry Range:=Selection.Range, Entry:=Selection.Range.Text, _
EntryAutoText:=Selection.Range.Text, CrossReference:="→ ", CrossReferenceAutoText:="", _
BookmarkName:="", Bold:=False, Italic:=False, Reading:=myReading
'
Selection.MoveRight Unit:=wdCharacter, Count:=2, Extend:=wdMove
myCount = myCount + 1
End Select
End If
'
ActiveWindow.ActivePane.View.ShowAll = False ' フィールドを非表示にする。
Application.StatusBar = myTitle & "：処理中..." & myCount & "件"
DoEvents
Loop
Application.ScreenUpdating = True
Rem *----*----* *----*----* *----*----* *----*----*
'
ActiveWindow.ActivePane.View.ShowAll = True ' フィールドを表示する。
Selection.HomeKey Unit:=wdStory, Extend:=wdMove ' カーソル位置を文書の先頭まで移動。
Beep
If myCount = 0 Then
MsgBox "該当する文字列がありません！", vbExclamation + vbOKOnly, "蛍光ペン書式文字列 索引登録処理"
ActiveWindow.ActivePane.View.ShowAll = False
End If
Application.StatusBar = myTitle & "：処理終了..." & myCount & "件"
End Sub ' EspIndexXeAuto *----*----* *----*----* *----*----* *----*----*
Sub EspIndexXeYomi(myTitle As String)
Rem *----*----* *----*----* *----*----* *----*----*
Rem 読み入力処理（半角以外の文字列）
Rem *----*----* *----*----* *----*----* *----*----*
Dim myCmmdBar As CommandBar
Dim x As Long
Dim y As Long
Dim myOnAction As String
Dim myMssg As String
'
Dim myCount As Long
Dim myMax As Long
Dim i As Long
Dim p As Long
Dim c As Long
Dim myField As Field
Dim myFields As Fields
Dim myText As String
Rem *----*----* *----*----* *----*----* *----*----*
'
Set myFields = ActiveDocument.Fields
myCount = 0
myMax = myFields.Count
'
For i = 1 To myMax
If myFields(i).Type = wdFieldIndexEntry Then
If InStr(myFields(i).Code.Text, " \t " & ChrW(34)) > 0 Then
myCount = myCount + 1
Else
Select Case True
Case InStr(myFields(i).Code.Text, " \y " & ChrW(34)) <= 0
Rem \yがない場合
myText = myFields(i).Code.Text
myText = myText & " \y " & ChrW(34) & ChrW(34)
myText = myText & " \t " & ChrW(34) & "→ " & ChrW(34) & " "
myFields(i).Code.Text = Replace(myText, " ", " ")
myCount = myCount + 1
Case InStr(myFields(i).Code.Text, " \y " & ChrW(34) & ChrW(34)) > 0
Rem \yに読みの指定がない場合
myText = myFields(i).Code.Text
myText = myText & " \t " & ChrW(34) & "→ " & ChrW(34) & " "
myFields(i).Code.Text = Replace(myText, " ", " ")
myCount = myCount + 1
End Select
End If
End If
Application.StatusBar = myTitle & "：処理中..." & (i * 100 \ myMax) & "% " & i & "／" & myMax & "件"
DoEvents
Next ' i
'
Beep
Application.StatusBar = myTitle & "：索引項目..." & myCount & "件"
If myCount = 0 Then
MsgBox "該当する索引項目がありません！", vbExclamation + vbOKOnly, "蛍光ペン書式文字列 索引登録処理"
GoTo EspIndexXeYomiSubExit
End If
Rem *----*----* *----*----* *----*----* *----*----*
'
On Error Resume Next
CommandBars(myTitle & "Yomi").Delete
On Error GoTo 0
'
Call EspIndexXeCmmdBarYomi(myTitle & "Yomi")
Set myCmmdBar = CommandBars(myTitle & "Yomi")
'
p = 1: c = 0
Rem *----*----* *----*----* *----*----* *----*----*
'
EspIndexXeYomiSubEntry:
If c >= myCount Then GoTo EspIndexXeYomiSubExit
'
For i = p To myFields.Count
If myFields(i).Type = wdFieldIndexEntry Then
If InStr(myFields(i).Code.Text, " \t " & ChrW(34)) > 0 Then
Exit For
End If
End If
Application.StatusBar = myTitle & "：検索中..." & (i * 100 \ myMax) & "% " & i & "／" & myMax & "件"
DoEvents
Next ' i
p = i
c = c + 1
'
Rem [XE: 索引項目]
myMssg = myFields.Item(i).Code
myMssg = Mid(myMssg, InStr(myMssg, " XE " & ChrW(34)) + 5)
myMssg = Left(myMssg, InStr(myMssg, ChrW(34)) - 1)
myCmmdBar.Controls(2).Caption = String(4, " ") & myMssg
'
Rem [\y: 読み]
myText = myFields.Item(i).Code
myText = Mid(myText, InStr(myText, " \y " & ChrW(34)) + 5)
myText = Left(myText, InStr(myText, ChrW(34)) - 1)
myCmmdBar.Controls("読み").Text = myText
'
Rem [次へ][戻る]
Select Case True
Case c = 1
If myCount > 1 Then
myCmmdBar.Controls("次へ").Enabled = True
Else
myCmmdBar.Controls("次へ").Enabled = False
End If
myCmmdBar.Controls("戻る").Enabled = False
Case c = myCount
myCmmdBar.Controls("次へ").Enabled = False
myCmmdBar.Controls("戻る").Enabled = True
Case Else
myCmmdBar.Controls("次へ").Enabled = True
myCmmdBar.Controls("戻る").Enabled = True
End Select
Rem *----*----* *----*----* *----*----* *----*----*
'
Application.StatusBar = myTitle & "：読み入力..." & c & "／" & myCount & "件"
Do
Call EspIndexXeOnAction(False, vbNullString)
Call EspIndexXeShowPopupXy(True, x, y)
'
If x = -1 Then
myCmmdBar.ShowPopup
Else
myCmmdBar.ShowPopup x, y
End If
DoEvents
'
Call EspIndexXeOnAction(True, myOnAction)
Call EspIndexXeShowPopupXy(False, myCmmdBar.Left, myCmmdBar.Top)
'
Select Case myOnAction
Case "索引項目"
Rem ショートカットメニューを同位置に表示させるだけで、特に何もしない。
' *----*----* *----*----* *----*----* *----*----*
Case "読み"
myText = myFields(i).Code.Text
myText = Left(myText, InStr(myText, " \y " & ChrW(34)) + 4)
myText = myText & CommandBars("EspIndexXeYomi").Controls("読み").Text & ChrW(34)
myText = myText & " \t " & ChrW(34) & "→ " & ChrW(34) & " "
myFields(i).Code.Text = myText
'
p = p + 1
Application.ScreenRefresh
GoTo EspIndexXeYomiSubEntry
' *----*----* *----*----* *----*----* *----*----*
Case "次へ"
p = p + 1
GoTo EspIndexXeYomiSubEntry
' *----*----* *----*----* *----*----* *----*----*
Case "戻る"
For i = p - 1 To 1 Step -1
Application.StatusBar = myTitle & "：検索中..." & i & "／" & myMax & "件"
If myFields(i).Type = wdFieldIndexEntry Then
If InStr(myFields(i).Code.Text, " \t " & ChrW(34)) > 0 Then
Exit For
End If
End If
DoEvents
Next ' i
'
p = i
c = c - 2
GoTo EspIndexXeYomiSubEntry
' *----*----* *----*----* *----*----* *----*----*
Case "閉じる"
GoTo EspIndexXeYomiSubExit
' *----*----* *----*----* *----*----* *----*----*
Case Else
Call EspIndexXeShowPopupXy(False, -1, -1)
End Select
Loop
Rem *----*----* *----*----* *----*----* *----*----*
'
EspIndexXeYomiSubExit:
On Error Resume Next
Set myFields = Nothing
Set myCmmdBar = Nothing
myCmmdBar.Delete
On Error GoTo 0
End Sub ' EspIndexXeYomi *----*----* *----*----* *----*----* *----*----*
Sub EspIndexXeTerm(myTitle As String)
Rem *----*----* *----*----* *----*----* *----*----*
Rem 後処理
Rem 1. XE(索引登録)フィールド内の余分な項目（相互参照設定：\t）を削除する。
Rem 2. 文書全体の蛍光ペン書式を解除する。
Rem 3. フィールドを非表示にする。
Rem *----*----* *----*----* *----*----* *----*----*
Dim myAns As Integer
Dim myField As Field
Dim myCount As Long
Rem *----*----* *----*----* *----*----* *----*----*
'
myAns = MsgBox("後処理を実行しますか？", vbExclamation + vbYesNo + vbDefaultButton2)
If myAns = vbNo Then Exit Sub
'
myCount = 0
For Each myField In ActiveDocument.Fields
If myField.Type = wdFieldIndexEntry Then
Rem 余分な項目[相互参照]の指定を削除する。（この場合、半角以外の文字列を含む索引項目）
If InStr(myField.Code.Text, " \t " & ChrW(34)) > 0 Then
myField.Code.Text = Left(myField.Code.Text, InStr(myField.Code.Text, "\t " & ChrW(34)) - 1)
myCount = myCount + 1
Application.StatusBar = myTitle & "：処理中..." & myCount & "件"
End If
End If
DoEvents
Next ' myField
'
ActiveDocument.Range.HighlightColorIndex = wdNoHighlight ' 文書全体の蛍光ペン書式を解除。
ActiveWindow.ActivePane.View.ShowAll = False ' フィールドを非表示にする。
Application.StatusBar = myTitle & "：処理終了..." & myCount & "件"
Beep
If myCount = 0 Then
MsgBox "該当する索引項目がありません！", vbExclamation + vbOKOnly, "蛍光ペン書式文字列 索引登録処理"
Exit Sub
End If
End Sub ' EspIndexXeTerm *----*----* *----*----* *----*----* *----*----*
Sub EspIndexXeUndo(myTitle As String)
Rem *----*----* *----*----* *----*----* *----*----*
Rem 読み再入力前処理
Rem XE(索引登録)フィールドの半角以外の文字列を含む索引項目に、
Rem あるいは[読み]の入力が必要なものに、
Rem [相互参照]の指定「\t "→ "」を追加する。
Rem *----*----* *----*----* *----*----* *----*----*
Dim myAns As Integer
Dim myFields As Fields
Dim i As Long
Dim myMax As Long
Dim myCount As Long
Dim myText As String
Dim myFlag As Boolean
Rem *----*----* *----*----* *----*----* *----*----*
'
myAns = MsgBox("読み再入力前処理を実行しますか？", vbExclamation + vbYesNo + vbDefaultButton2)
If myAns = vbNo Then Exit Sub
'
Set myFields = ActiveDocument.Fields
myCount = 0
myMax = myFields.Count
For i = 1 To myMax
If myFields.Item(i).Type = wdFieldIndexEntry Then
Rem [相互参照]の指定「\t "→ "」を追加する。
Rem 半角以外の文字列を含む索引項目あるいは[読み]の入力が必要なものを対象に処理する。
If InStr(myFields(i).Code.Text, " \t " & ChrW(34)) <= 0 Then
Select Case True
Case InStr(myFields(i).Code.Text, " \y " & ChrW(34)) <= 0
Rem \yがない場合
myText = myFields(i).Code.Text
myText = myText & " \y " & ChrW(34) & ChrW(34)
myText = myText & " \t " & ChrW(34) & "→ " & ChrW(34) & " "
myFields(i).Code.Text = Replace(myText, " ", " ")
myCount = myCount + 1
Case InStr(myFields(i).Code.Text, " \y " & ChrW(34) & ChrW(34)) > 0
Rem \yに読みの指定がない場合
myText = myFields(i).Code.Text
myText = myText & " \t " & ChrW(34) & "→ " & ChrW(34) & " "
myFields(i).Code.Text = Replace(myText, " ", " ")
myCount = myCount + 1
Case InStr(myFields(i).Code.Text, " \y " & ChrW(34)) > 0
Rem \yに読みの指定がある場合
myText = myFields.Item(i).Code
myText = Mid(myText, InStr(myText, " \y " & ChrW(34)) + 5)
myText = Left(myText, InStr(myText, ChrW(34)) - 1)
Call EspIndexXeUndoReading(myFlag, myText)
If myFlag = True Then
myText = myFields(i).Code.Text
myText = myText & " \t " & ChrW(34) & "→ " & ChrW(34) & " "
myFields(i).Code.Text = Replace(myText, " ", " ")
myCount = myCount + 1
End If
End Select
End If
End If
Application.StatusBar = myTitle & "：処理中..." & (i * 100 \ myMax) & "% " & i & "／" & myMax & "件"
DoEvents
Next ' i
'
ActiveWindow.ActivePane.View.ShowAll = True ' フィールドを表示する。
Application.StatusBar = myTitle & "：索引項目..." & myCount & "件"
Beep
If myCount = 0 Then
MsgBox "該当する索引項目がありません！", vbExclamation + vbOKOnly, "蛍光ペン書式文字列 索引登録処理"
ActiveWindow.ActivePane.View.ShowAll = False
Exit Sub
End If
End Sub ' EspIndexXeUndo *----*----* *----*----* *----*----* *----*----*
Sub EspIndexXeReading(myReading As String)
Rem *----*----* *----*----* *----*----* *----*----*
Dim i As Integer
Dim c As String
Dim myLength As Integer
Dim myString As String
Dim myChar As String
Rem *----*----* *----*----* *----*----* *----*----*
'
myString = ""
myLength = Len(myReading)
'
For i = 1 To myLength
myChar = Mid(myReading, i, 1)
Select Case myChar
Case " " To "~" ' ASCII（10進）32〜126
myString = myString & myChar & " "
Case ChrW(12449) To ChrW(12799) ' カタカナ・カタカナふりがな拡張（10進）12449〜12799
myString = myString & StrConv(myChar, vbHiragana)
Case Else
Call EspIndexXeSurrogate(myChar)
myString = myString & myChar
End Select
DoEvents
Next ' i
'
myReading = myString
End Sub ' EspIndexXeReading *----*----* *----*----* *----*----* *----*----*
Sub EspIndexXeSurrogate(myChar As String)
Rem *----*----* *----*----* *----*----* *----*----*
Rem 音声符号付き文字の対処
Rem 代用表記の設定（親字の後ろに指定。下記は一応の目安。）
Rem ` 0060 ( 96 ) Grave Accent
Rem ^ 005E ( 94 ) Circumflex Accent ( hat sign )
Rem ~ 007E ( 126 ) Tilda
Rem ¨00A8 ( 168 ) Diaeresis ( trema / umlaut )
Rem ? 00AF ( 175 ) Macron
Rem ´00B4 ( 180 ) Acute Accent
Rem ? 00B8 ( 184 ) Cedilla
Rem ? 02C7 ( 711 ) Caron ( Wedge / Hacek )
Rem ? 02D8 ( 728 ) Breve
Rem *----*----* *----*----* *----*----* *----*----*
Dim myMssg As String
Rem *----*----* *----*----* *----*----* *----*----*
'
Select Case myChar
Case ChrW(265): myChar = "c^"
Case ChrW(285): myChar = "g^"
Case ChrW(293): myChar = "h^"
Case ChrW(309): myChar = "j^"
Case ChrW(349): myChar = "s^"
Case ChrW(365): myChar = "u" & ChrW(728)
'
Case ChrW(264): myChar = "C^"
Case ChrW(284): myChar = "G^"
Case ChrW(292): myChar = "H^"
Case ChrW(308): myChar = "J^"
Case ChrW(348): myChar = "S^"
Case ChrW(364): myChar = "U" & ChrW(728)
' *----*----* *----*----* *----*----* *----*----*
Case ChrW(226): myChar = "a^"
Case ChrW(234): myChar = "e^"
Case ChrW(238): myChar = "i^"
Case ChrW(244): myChar = "o^"
Case ChrW(251): myChar = "u^"
'
Case ChrW(194): myChar = "A^"
Case ChrW(202): myChar = "E^"
Case ChrW(206): myChar = "I^"
Case ChrW(212): myChar = "O^"
Case ChrW(219): myChar = "U^"
' *----*----* *----*----* *----*----* *----*----*
Case ChrW(228): myChar = "a¨"
Case ChrW(246): myChar = "o¨"
Case ChrW(252): myChar = "u¨"
Case ChrW(223): myChar = "ss"
'
Case ChrW(196): myChar = "A¨"
Case ChrW(214): myChar = "O¨"
Case ChrW(220): myChar = "U¨"
' *----*----* *----*----* *----*----* *----*----*
Case ChrW(231): myChar = "c" & ChrW(184)
Case ChrW(199): myChar = "C" & ChrW(184)
' *----*----* *----*----* *----*----* *----*----*
Case ChrW(241): myChar = "n~"
Case ChrW(209): myChar = "N~"
' *----*----* *----*----* *----*----* *----*----*
Case Else:
If myChar <> StrConv(myChar, vbWide) Then
Rem 半角文字なら、代用表記の未対応の文字と見なす。
Rem 未対応の場合、StrConv(myChar, vbWide)は「？」になる。（大抵の場合、ASCII範囲外の文字）
myMssg = "代用表記が未対応です！" & vbCrLf & myChar & "：" & AscW(myChar)
MsgBox myMssg, vbCritical + vbOKOnly, "蛍光ペン書式文字列 索引登録処理"
Debug.Print "代用表記が未対応です！：" & AscW(myChar)
Rem ↓意図的に全角の「＠」を指定しておき、[読み再入力 前処理]で呼び出せるようにする。
myChar = myChar & "＠"
End If
End Select
End Sub ' EspIndexXeSurrogate *----*----* *----*----* *----*----* *----*----*
Sub EspIndexXeUndoReading(myFlag As Boolean, myReading As String)
Rem *----*----* *----*----* *----*----* *----*----*
Dim i As Integer
Dim c As String
Dim myLength As Integer
Dim myString As String
Dim myChar As String
Rem *----*----* *----*----* *----*----* *----*----*
'
myFlag = False
myLength = Len(myReading)
'
For i = 1 To myLength
myChar = Mid(myReading, i, 1)
Select Case myChar
Case " " To "~", ChrW(168), ChrW(175), ChrW(180), ChrW(184), ChrW(711), ChrW(728)
Rem
Case Else
myFlag = True
Exit For
End Select
DoEvents
Next ' i
End Sub ' EspIndexXeUndoReading *----*----* *----*----* *----*----* *----*----*
Sub EspIndexXeCmmdBarMenu(myTitle As String)
Rem *----*----* *----*----* *----*----* *----*----*
Rem 蛍光ペン書式文字列索引登録処理ショートカットメニュー
Rem *----*----* *----*----* *----*----* *----*----*
Dim myCmmdBar As CommandBar
Dim myCtrlBttnMenu As CommandBarControl
Dim myCtrlBttnAuto As CommandBarControl
Dim myCtrlBttnYomi As CommandBarControl
Dim myCtrlBttnTerm As CommandBarControl
Dim myCtrlBttnUndo As CommandBarControl
Dim myCtrlBttnClose As CommandBarControl
'
Dim myOnAction As String
Dim myMssg As String
Rem *----*----* *----*----* *----*----* *----*----*
'
On Error Resume Next
CommandBars(myTitle).Delete
On Error GoTo 0
'
Set myCmmdBar = CommandBars.Add(Name:=myTitle, Position:=msoBarPopup, Temporary:=True)
Set myCtrlBttnMenu = myCmmdBar.Controls.Add(Type:=msoControlButton, Before:=1, Temporary:=True)
Set myCtrlBttnAuto = myCmmdBar.Controls.Add(Type:=msoControlButton, Before:=2, Temporary:=True)
Set myCtrlBttnYomi = myCmmdBar.Controls.Add(Type:=msoControlButton, Before:=3, Temporary:=True)
Set myCtrlBttnTerm = myCmmdBar.Controls.Add(Type:=msoControlButton, Before:=4, Temporary:=True)
Set myCtrlBttnUndo = myCmmdBar.Controls.Add(Type:=msoControlButton, Before:=5, Temporary:=True)
Set myCtrlBttnClose = myCmmdBar.Controls.Add(Type:=msoControlButton, Before:=6, Temporary:=True)
'
myMssg = "蛍光ペン書式文字列 索引登録処理" & vbCrLf & vbCrLf
'
With myCtrlBttnMenu
.DescriptionText = "蛍光ペン書式文字列索引登録処理ショートカット"
.Style = msoButtonIconAndWrapCaption
.Caption = myMssg & "処理を選択して下さい。"
.TooltipText = "下記の処理を一つ選択して下さい。"
.FaceId = 1089
End With
'
With myCtrlBttnAuto
.DescriptionText = "[索引登録処理]ボタン"
.BeginGroup = True
.Style = msoButtonIconAndCaption
.Caption = "索引登録処理"
.TooltipText = "文書内にある蛍光ペン書式[ピンク色]の文字列を検索し、索引項目を挿入します。"
.FaceId = 2659
.OnAction = myTitle & "Auto"
End With
'
With myCtrlBttnYomi
.DescriptionText = "[読み入力処理（半角以外の文字列）]ボタン"
.BeginGroup = True
.Style = msoButtonIconAndCaption
.Caption = "読み入力処理 （半角以外の文字列）"
.TooltipText = "文書内にある半角以外の文字列に設定された索引項目の読みを手作業します。"
.FaceId = 2658
.OnAction = myTitle & "Yomi"
End With
'
With myCtrlBttnTerm
.DescriptionText = "[索引登録 後処理]ボタン"
.BeginGroup = True
.Style = msoButtonIconAndCaption
.Caption = "後処理"
.TooltipText = "後処理をします。"
.FaceId = 2646
.OnAction = myTitle & "Term"
End With
'
With myCtrlBttnUndo
.DescriptionText = "[読み再入力 前処理]ボタン"
.BeginGroup = True
.Style = msoButtonIconAndCaption
.Caption = "読み再入力 前処理"
.TooltipText = "読みを再入力するための前処理をします。"
.FaceId = 1105
.OnAction = myTitle & "Undo"
End With
'
With myCtrlBttnClose
.DescriptionText = "[閉じる]ボタン"
.BeginGroup = True
.Style = msoButtonIconAndCaption
.Caption = "閉じる"
.TooltipText = "ショートカットメニューを閉じます。"
.FaceId = 840
.OnAction = myTitle & "Close"
End With
End Sub ' EspIndexXeCmmdBarMenu *----*----* *----*----* *----*----* *----*----*
Sub EspIndexXeMenuAuto(Optional myDummy As Boolean)
Call EspIndexXeOnAction(False, "索引登録処理")
End Sub ' EspIndexXeMenuAuto *----*----* *----*----* *----*----* *----*----*
Sub EspIndexXeMenuYomi(Optional myDummy As Boolean)
Call EspIndexXeOnAction(False, "読み入力処理（半角以外の文字列）")
End Sub ' EspIndexXeMenuYomi *----*----* *----*----* *----*----* *----*----*
Sub EspIndexXeMenuTerm(Optional myDummy As Boolean)
Call EspIndexXeOnAction(False, "後処理")
End Sub ' EspIndexXeMenuTerm *----*----* *----*----* *----*----* *----*----*
Sub EspIndexXeMenuUndo(Optional myDummy As Boolean)
Call EspIndexXeOnAction(False, "読み再入力 前処理")
End Sub ' EspIndexXeMenuTerm *----*----* *----*----* *----*----* *----*----*
Sub EspIndexXeMenuClose(Optional myDummy As Boolean)
Call EspIndexXeOnAction(False, "閉じる")
End Sub ' EspIndexXeMenuClose *----*----* *----*----* *----*----* *----*----*
Sub EspIndexXeCmmdBarYomi(myTitle As String)
Rem *----*----* *----*----* *----*----* *----*----*
Rem [索引項目 読み入力処理 （半角以外文字列 ）]ショートカットメニュー
Rem *----*----* *----*----* *----*----* *----*----*
Dim myCmmdBar As CommandBar
Dim myCtrlBttnMenu As CommandBarControl
Dim myCtrlBttnXe As CommandBarControl
Dim myCtrlEditBox As CommandBarControl
Dim myCtrlBttnNext As CommandBarControl
Dim myCtrlBttnBack As CommandBarControl
Dim myCtrlBttnClose As CommandBarControl
'
Dim myMssg As String
Rem *----*----* *----*----* *----*----* *----*----*
'
On Error Resume Next
CommandBars(myTitle).Delete
On Error GoTo 0
'
Set myCmmdBar = CommandBars.Add(Name:=myTitle, Position:=msoBarPopup, Temporary:=True)
Set myCtrlBttnMenu = myCmmdBar.Controls.Add(Type:=msoControlButton, Before:=1, Temporary:=True)
Set myCtrlBttnXe = myCmmdBar.Controls.Add(Type:=msoControlButton, Before:=2, Temporary:=True)
Set myCtrlEditBox = myCmmdBar.Controls.Add(Type:=msoControlEdit, Before:=3, Temporary:=True)
Set myCtrlBttnNext = myCmmdBar.Controls.Add(Type:=msoControlButton, Before:=4, Temporary:=True)
Set myCtrlBttnBack = myCmmdBar.Controls.Add(Type:=msoControlButton, Before:=5, Temporary:=True)
Set myCtrlBttnClose = myCmmdBar.Controls.Add(Type:=msoControlButton, Before:=6, Temporary:=True)
'
myMssg = "蛍光ペン書式文字列 索引登録処理" & " "
myMssg = myMssg & "[ " & "読み入力処理" & " ]" & vbCrLf & vbCrLf
myMssg = myMssg & "読みを入力して下さい。" & vbCrLf
'
With myCtrlBttnMenu
.DescriptionText = "[索引項目 読み入力処理 （半角以外文字列 ）]ショートカットメニュー"
.Style = msoButtonIconAndWrapCaption
.Caption = myMssg
.TooltipText = "[読み]を入力して下さい。"
.FaceId = 1089
End With
'
With myCtrlBttnXe
.DescriptionText = "[索引項目]ボタン"
.BeginGroup = True
.Style = msoButtonIconAndWrapCaption
.Caption = ""
.TooltipText = "索引項目"
.FaceId = 2293
.OnAction = myTitle & "Xe"
End With
'
With myCtrlEditBox
.DescriptionText = "[読み]エディットボックス"
.BeginGroup = True
.Caption = "読み"
.Text = ""
.TooltipText = "[読み]を入力します。"
.OnAction = myTitle & "EditBox"
End With
'
With myCtrlBttnNext
.DescriptionText = "[次へ]ボタン"
.BeginGroup = True
.Style = msoButtonIconAndCaption
.Caption = "次へ"
.TooltipText = "次へ"
.FaceId = 157
.OnAction = myTitle & "Next"
End With
'
With myCtrlBttnBack
.DescriptionText = "[戻る]ボタン"
.BeginGroup = True
.Style = msoButtonIconAndCaption
.Caption = "戻る"
.TooltipText = "戻る"
.FaceId = 154
.OnAction = myTitle & "Back"
End With
'
With myCtrlBttnClose
.DescriptionText = "[閉じる]ボタン"
.BeginGroup = True
.Style = msoButtonIconAndCaption
.Caption = "閉じる"
.TooltipText = "[読み入力処理]を閉じます。"
.FaceId = 1019
.OnAction = myTitle & "Close"
End With
End Sub ' EspIndexXeCmmdBarYomi ' *----*----* *----*----* *----*----* *----*----*
Sub EspIndexXeYomiXe(Optional myDummy As Boolean)
Call EspIndexXeOnAction(False, "索引項目")
End Sub ' EspIndexXeYomiEditBox *----*----* *----*----* *----*----* *----*----*
Sub EspIndexXeYomiEditBox(Optional myDummy As Boolean)
Call EspIndexXeOnAction(False, "読み")
End Sub ' EspIndexXeYomiEditBox *----*----* *----*----* *----*----* *----*----*
Sub EspIndexXeYomiNext(Optional myDummy As Boolean)
Call EspIndexXeOnAction(False, "次へ")
End Sub ' EspIndexXeYomiNext *----*----* *----*----* *----*----* *----*----*
Sub EspIndexXeYomiBack(Optional myDummy As Boolean)
Call EspIndexXeOnAction(False, "戻る")
End Sub ' EspIndexXeYomiBack *----*----* *----*----* *----*----* *----*----*
Sub EspIndexXeYomiClose(Optional myDummy As Boolean)
Call EspIndexXeOnAction(False, "閉じる")
End Sub ' EspIndexXeYomiClose *----*----* *----*----* *----*----* *----*----*
Sub EspIndexXeOnAction(myFlag As Boolean, myOnAction As String)
Rem *----*----* *----*----* *----*----* *----*----*
Rem ショートカットメニューの入力項目
Rem *----*----* *----*----* *----*----* *----*----*
Static myOnActionStatic As String
'
If myFlag = False Then
myOnActionStatic = myOnAction
Else
myOnAction = myOnActionStatic
End If
End Sub ' EspIndexXeOnAction *----*----* *----*----* *----*----* *----*----*
Sub EspIndexXeShowPopupXy(myFlag As Boolean, x As Long, y As Long)
Rem *----*----* *----*----* *----*----* *----*----*
Rem ショートカットメニューの座標処理
Rem *----*----* *----*----* *----*----* *----*----*
Static myX As Long
Static myY As Long
'
If myFlag = False Then
myX = x
myY = y
Else
x = myX
y = myY
End If
End Sub ' EspIndexXeShowPopupXy *----*----* *----*----* *----*----* *----*----*
