Sub MyStrNum()
  Rem *----*----*    *----*----*    *----*----*    *----*----*
  Rem 漢数字検索 洋数字置換 逐次 半自動処理
  Rem 記録者：Hitrock Camellia Shinopy
  Rem 言語：Word VBA
  Rem 機能：カーソル位置から後の漢数字を検索し、洋数字に置換する。
  Rem 参照設定する場合...
  Rem     Microsoft VBScript Regular Expressions 5.5
  Rem 注記...
  Rem  「myStrNum」を起動して使用｡
  Rem   兆単位までの漢数字を検索。
  Rem   蛍光ペン書式の設定にwdTurquoise（水色）を使用。
  Rem 履歴...
  Rem   第1版：2004/11/30：作成。
  Rem   第2版：2004/12/02：不具合修正。
  Rem   第3版：2006/05/03：逐次置換処理・モーダル処理に変更。
  Rem   第4版：2006/05/22：位取りがない場合に、単純置換する処理を追加。
  Rem *----*----*    *----*----*    *----*----*    *----*----*
  Dim myTitle As String
  Dim myHead As String
  Dim myMsg As String
  Dim myAns As Long
  Dim myCbox(5) As Boolean
  Dim myCboxFlag As Boolean
  Dim i As Integer
  Dim j As Integer
  '
  Dim myRange As Range
  Dim myChrs As Characters
  Dim myStartMarker As Word.Range
  Dim myText As String
  Dim myCount As Long
  Dim myCountRep As Long
  Dim myMoveRight As Integer
  '
  Dim myRegExp As Variant ' VBScript_RegExp_55.RegExp
  Dim myMatches As Variant ' MatchCollection
  Dim myMatch As Variant ' Match
  Dim myPttn As String
  Dim myDigit As String
  Dim myUnit As String
  Rem *----*----*    *----*----*    *----*----*    *----*----*
  '
  myTitle = "MyStrNum"
  myHead = "漢数字 検索" & vbCr & "洋数字 置換" & vbCr & "逐次 半自動 処理"
  Assistant.Visible = True
  '
  myMsg = "[検索]ボタンを押して、" & vbCr & "処理を開始して下さい。"
  myMsg = myMsg & "　" & vbCr
  myMsg = myMsg & "カーソル位置から後を検索します。"
  Application.StatusBar = myTitle & "：" & Replace(myMsg, vbCr, "")
  With Assistant.NewBalloon
    .Animation = msoAnimationIdle
    .BalloonType = msoBalloonTypeButtons
    .Icon = msoIconAlertInfo
    .Button = msoButtonSetCancel
    .Heading = myTitle & vbCr & myHead
    .Text = myMsg
    .Labels(1).Text = "[検索]"
    .Checkboxes(1).Text = "２字以上"
    .Checkboxes(2).Text = "〜円"
    .Checkboxes(3).Text = "〜m/km/g/kg"
    .Checkboxes(4).Text = ""
    .Checkboxes(5).Text = ""
    .Mode = msoModeModal
    myAns = .Show
    myCbox(0) = False
    myUnit = ""
    For i = 1 To 5
      myCbox(i) = .Checkboxes(i).Checked
      Select Case i
        Case 2, 3
          If myCbox(i) = True Then
            myCbox(0) = True
            myUnit = myUnit & .Checkboxes(i).Text & "/"
            myUnit = Replace(myUnit, "〜", "")
          End If
      End Select
    Next ' i
    If myCbox(0) = True Then
      myUnit = Left(myUnit, Len(myUnit) - 1)
      myUnit = Replace(myUnit, "/", "|")
    End If
  End With
  '
  If myAns = msoBalloonButtonCancel Then
    Assistant.NewBalloon.Close
    Assistant.Visible = False
    Exit Sub
  End If
  Rem *----*----*    *----*----*    *----*----*    *----*----*
  '
  myDigit = "〇一二三四五六七八九十百千万億兆"
  '
  myPttn = "[" & myDigit & "]"
  If myCbox(1) = True Then
    myPttn = myPttn & "{2,}"
    Rem 十以上の場合： "(" & myPttn & "{2,})|([十百千]{1})"
  Else
    myPttn = myPttn & "{1,}"
  End If
  '
  If myCbox(0) = True Then
    myPttn = myPttn & "(" & myUnit & ")"
  End If
  '
  Rem カーソルが文章の途中あると、不都合が起こるので、
  Rem 文章の先頭に移動する。
  Selection.Sentences(1).Select
  Selection.Collapse wdCollapseStart
  Rem カーソル位置から文書の末尾までの範囲を選択する。
  Selection.EndKey Unit:=wdStory, Extend:=wdExtend
  Set myRange = Selection.Range
  Set myChrs = myRange.Characters
  myRange.Select
  '
  Set myRegExp = CreateObject("VBScript.RegExp") ' New VBScript_RegExp_55.RegExp
  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
  myCountRep = 0
  '
  If myMatches.Count = 0 Then
    myMsg = "検索終了：" & vbCr & "該当する漢数字がありません。"
    Application.StatusBar = myTitle & "：" & Replace(myMsg, vbCr, "")
    With Assistant.NewBalloon
      .Animation = msoAnimationIdle
      .BalloonType = msoBalloonTypeButtons
      .Icon = msoIconAlertInfo
      .Button = msoButtonSetOK
      .Heading = myTitle & vbCr & myHead
      .Text = myMsg
      .Mode = msoModeModal
      .Show
    End With
    '
    GoTo MyStrNumSubExit
  End If
  '
  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 *----*----*    *----*----*
      '
      Rem 円／m／km／g／kgを選択範囲からはずす。
      myMoveRight = 0
      If myCbox(0) = True Then
        For j = 1 To 2 ' ←単位の最大文字数 Len("km")
          Select Case True
            Case Selection.Characters.Last.Text Like "[" & myDigit & "]"
              Rem 漢数字の場合は、何もしない。
            Case Else
              Rem 選択範囲を1文字狭める。
              Call Selection.MoveLeft(wdCharacter, 1, wdExtend)
              myMoveRight = myMoveRight + 1
          End Select
        Next ' j
      End If
      Call MyStrNumScroll
      Rem 検索した文字列を蛍光ペン書式にする。
      Selection.Range.HighlightColorIndex = wdTurquoise ' 水色
      DoEvents ' 画面更新のため、瞬間停止。
      myText = Selection.Range.Text
      '
      myCount = myCount + 1
      myMsg = "洋数字に置換しますか？"
      Application.StatusBar = myTitle & "：" & myMsg & " " & myCount & "/" & myMatches.Count
      '
      With Assistant.NewBalloon
        .Animation = msoAnimationIdle
        .BalloonType = msoBalloonTypeButtons
        .Icon = msoIconAlertQuery
        .Button = msoButtonSetCancel
        .Heading = myTitle & vbCr & myHead
        .Text = myMsg
        .Labels(1).Text = "はい"
        .Labels(2).Text = "いいえ"
        Rem 位取りがない漢数字の場合
        If (InStr(myText, "千") + InStr(myText, "百") + InStr(myText, "十")) = 0 Then
          If Len(myText) >= 5 Then
            .Checkboxes(1).Text = "単純置換"
          End If
        End If
        .Mode = msoModeModal
        myAns = .Show
        myCboxFlag = .Checkboxes(1).Checked
      End With
      '
      Selection.Range.HighlightColorIndex = wdNoHighlight ' 蛍光ペン書式解除
      If myAns = msoBalloonButtonCancel Then
        Rem [キャンセル]
        GoTo MyStrNumSubExit
      End If
      If myAns = 1 Then
        Set myChrs = Selection.Range.Characters
        Rem 選択範囲の文字列を洋数字に置換する。
        Call MyStrNumReplace(myCboxFlag)
        myCountRep = myCountRep + 1
        Rem 時間待ち処理
        Call MyStrNumDoEvents(3000)
      Else
        Rem 選択範囲を解除する。（カーソルは文字列の後）
        Selection.Collapse wdCollapseEnd
        Rem 時間待ち処理
        Call MyStrNumDoEvents(3000)
      End If
      Call Selection.MoveRight(wdCharacter, myMoveRight, wdMove)
    Next ' i
  End With
  '
  myMsg = "検索終了：" & vbCr
  myMsg = myMsg & "全部で、" & myCount & "件 検索しました。"
  myMsg = myMsg & "　" & vbCr
  myMsg = myMsg & "その内、" & myCountRep & "件 置換しました。"
  Application.StatusBar = myTitle & "：" & Replace(myMsg, vbCr, "")
  With Assistant.NewBalloon
    .Animation = msoAnimationIdle
    .BalloonType = msoBalloonTypeButtons
    .Icon = msoIconAlertInfo
    .Button = msoButtonSetOK
    .Heading = myTitle & vbCr & myHead
    .Text = myMsg
    .Mode = msoModeModal
    .Show
  End With
  Rem *----*----*    *----*----*    *----*----*    *----*----*
  '
MyStrNumSubExit:
  myStartMarker.Select
  Assistant.NewBalloon.Close
  Assistant.Visible = False
  '
  Set myRange = Nothing
  Set myRegExp = Nothing
  Set myStartMarker = Nothing
  Set myChrs = Nothing
End Sub ' MyStrNum *----*----*    *----*----*    *----*----*    *----*----*

Sub MyStrNumScroll()
  Rem *----*----*    *----*----*    *----*----*    *----*----*
  Rem 現在の選択範囲が文書ウィンドウに表示されるように、
  Rem 作業中の文書をスクロールする。
  Rem *----*----*    *----*----*    *----*----*    *----*----*
  On Error Resume Next
  '
  Application.ScreenUpdating = False
  '
  ActiveDocument.ActiveWindow.PageScroll Up:=1
  ActiveWindow.ScrollIntoView Selection.Range, True
  '
  Application.ScreenUpdating = True
End Sub ' MyStrNumScroll *----*----*    *----*----*    *----*----*    *----*----*

Sub MyStrNumDoEvents(myMax As Long)
  Rem *----*----*    *----*----*    *----*----*    *----*----*
  Rem 時間待ち処理
  Rem *----*----*    *----*----*    *----*----*    *----*----*
  Dim i As Long
  '
  For i = 1 To myMax
    DoEvents: DoEvents: DoEvents: DoEvents: DoEvents
    DoEvents: DoEvents: DoEvents: DoEvents: DoEvents
    DoEvents: DoEvents: DoEvents: DoEvents: DoEvents
    DoEvents: DoEvents: DoEvents: DoEvents: DoEvents
    DoEvents: DoEvents: DoEvents: DoEvents: DoEvents
  Next ' i
End Sub ' MyStrNumDoEvents *----*----*    *----*----*    *----*----*    *----*----*

Sub MyStrNumReplace(myCboxFlag As Boolean)
  Rem *----*----*    *----*----*    *----*----*    *----*----*
  Rem 選択範囲の文字列を洋数字に置換する。
  Rem *----*----*    *----*----*    *----*----*    *----*----*
  Dim myArray As Variant
  Dim myArrayDigitRev(1 To 20) As Variant
  Dim myFlagIsNumeric As Boolean
  Dim myFlagDigit As Integer
  Dim myFlagUnit As Integer
  Dim myText As String
  Dim myTextCount As Long
  Dim myDigit As String
  Dim i As Integer
  Dim j As Integer
  '
  Rem 数値判断用の表を準備する。
  myArray = Array("〇", "一", "二", "三", "四", "五", "六", "七", "八", "九", "十", "百", "千", "万", "億", "兆", "京")
  myText = Selection.Range.Text
  '
myStrNumReplaceSubEntry:
  Rem 位取りがない場合、漢数字から洋数字へ単純置換する。
  If (InStr(myText, "千") + InStr(myText, "百") + InStr(myText, "十")) = 0 Then
    myDigit = Selection.Range.Text
    myDigit = Replace(myDigit, "〇", "0")
    myDigit = Replace(myDigit, "一", "1")
    myDigit = Replace(myDigit, "二", "2")
    myDigit = Replace(myDigit, "三", "3")
    myDigit = Replace(myDigit, "四", "4")
    myDigit = Replace(myDigit, "五", "5")
    myDigit = Replace(myDigit, "六", "6")
    myDigit = Replace(myDigit, "七", "7")
    myDigit = Replace(myDigit, "八", "8")
    myDigit = Replace(myDigit, "九", "9")
    Selection.Range.Text = myDigit
    Selection.MoveRight Unit:=wdCharacter, Count:=Len(myDigit), Extend:=wdExtend
    
    Select Case Len(myDigit)
      Case 1 To 4
        myFlagDigit = Len(myDigit) - 1
        myFlagUnit = 1
      Case Else
        myFlagUnit = Len(myDigit) \ 4
        myFlagUnit = myFlagUnit * 4 + 1
        myFlagDigit = Len(myDigit) - myFlagUnit
    End Select
    '
    If myCboxFlag = True Then
      Selection.Collapse wdCollapseEnd
      Exit Sub
    Else
      GoTo myStrNumReplaceSubExit
    End If
  End If
  '
  Rem 以下、位取りがある場合の漢数字から洋数字へ置換処理。
  Rem 逆順表を準備する。
  Selection.Collapse wdCollapseEnd
  For i = 1 To UBound(myArrayDigitRev)
    myArrayDigitRev(i) = "〇"
  Next i
  '
  myFlagUnit = 1 ' 一の位
  myFlagDigit = 0
  With Selection.Range
    Do
      Rem 下の位から順に文字列を選択する。
      myTextCount = Selection.MoveLeft(wdCharacter, 1, wdExtend)
      If myTextCount = 0 Then
        Exit Do
      End If
      '
      Rem 選択した文字列が漢数字かどうか調べて、
      Rem 逆順表に数値を転記する。
      For i = 0 To UBound(myArray)
        If Left(Selection.Range.Text, 1) = myArray(i) Then
          myFlagIsNumeric = True
          Select Case myArray(i)
            Case "十"
              myFlagDigit = 1
            Case "百"
              myFlagDigit = 2
            Case "千"
              myFlagDigit = 3
            Case "万"
              myFlagUnit = 5
            Case "億"
              myFlagUnit = 9
            Case "兆"
              myFlagUnit = 13
            Case "京"
              myFlagUnit = 17
          End Select
          Select Case myArray(i)
            Case "〇", "一", "二", "三", "四", "五", "六", "七", "八", "九"
              myArrayDigitRev(myFlagUnit + myFlagDigit) = myArray(i)
            Case "十", "百", "千"
              myArrayDigitRev(myFlagUnit + myFlagDigit) = "一"
            Case Else
              myArrayDigitRev(myFlagUnit) = "一"
              myFlagDigit = 0
          End Select
          Exit For
        Else
          myFlagIsNumeric = False
        End If
      Next i
      '
      Rem 上の位が漢数字でない場合は、右へ１文字分戻り、繰り返しを抜ける。
      If myFlagIsNumeric = False Then
        Selection.MoveRight Unit:=wdCharacter, Count:=1, Extend:=wdExtend
        Exit Do
      End If
    Loop
    '
    Rem 逆順表を元に洋数字に置換し、選択範囲の文字列を置換する。
    myDigit = Join(myArrayDigitRev(), "")
    myDigit = Left(myDigit, myFlagUnit + myFlagDigit)
    myDigit = StrReverse(myDigit)
    myDigit = Replace(myDigit, "〇", "0")
    myDigit = Replace(myDigit, "一", "1")
    myDigit = Replace(myDigit, "二", "2")
    myDigit = Replace(myDigit, "三", "3")
    myDigit = Replace(myDigit, "四", "4")
    myDigit = Replace(myDigit, "五", "5")
    myDigit = Replace(myDigit, "六", "6")
    myDigit = Replace(myDigit, "七", "7")
    myDigit = Replace(myDigit, "八", "8")
    myDigit = Replace(myDigit, "九", "9")
  End With
  Selection.Range.Text = myDigit
  '
myStrNumReplaceSubExit:
  Rem 位取りを４桁ごとに文字列に挿入する。
  Selection.Collapse wdCollapseStart
  If myFlagUnit < 5 Then
    Selection.MoveRight Unit:=wdCharacter, Count:=myFlagDigit + 1, Extend:=wdMove
  Else
    Select Case myFlagUnit
      Case 5   '  万
        j = 13
      Case 9   '  億
        j = 14
      Case 13  '  兆
        j = 15
      Case 17  '  京
        j = 16
    End Select
    Selection.MoveRight Unit:=wdCharacter, Count:=myFlagDigit + 1, Extend:=wdMove
    For i = 1 To ((myFlagUnit - 1) / 4)
      Selection.InsertBefore (myArray(j))
      j = j - 1
      Selection.MoveRight Unit:=wdCharacter, Count:=5, Extend:=wdMove
    Next ' i
  End If
End Sub ' myStrNumReplace *----*----*    *----*----*    *----*----*    *----*----*