Sub myStrNum()
  Rem *----*----*    *----*----*    *----*----*    *----*----*
  Rem 漢数字検索 洋数字置換 半自動処理
  Rem 記録者:Hitrock Camellia Shinopy
  Rem 言語:Word VBA
  Rem 機能:漢数字を検索し、蛍光ペン書式を設定して、洋数字に置換する。
  Rem 注記...
  Rem  「myStrNum」を起動して使用。
  Rem   兆単位までの漢数字を検索。
  Rem   蛍光ペン書式:25%灰色・水色を使用。
  Rem 第1版:2004/11/30:作成。
  Rem 第2版:2004/12/02:不具合修正。
  Rem *----*----*    *----*----*    *----*----*    *----*----*
  '
  Rem カーソルが文章の途中あると、不都合が起こるので、
  Rem 文章の先頭に移動する。
  Selection.Sentences(1).Select
  Selection.Collapse wdCollapseStart
  '
  Assistant.Visible = True
  '
  With Assistant.NewBalloon
    .Animation = msoAnimationIdle
    .BalloonType = msoBalloonTypeButtons
    .Icon = msoIconAlertQuery
    .Button = msoButtonSetSearchClose
    .Heading = "漢数字検索" & vbCr & "洋数字置換" & vbCr & "半自動処理"
    .Text = "[検索]してから、" & vbCr & "選択して下さい。"
    .Labels(1).Text = "洋数字に置換"
    .Labels(2).Text = "次へ"
    .Labels(3).Text = "[元に戻す]"
    .Labels(4).Text = ""
    .Labels(5).Text = "蛍光ペン書式を解除"
    .Mode = msoModeModeless
    .Callback = "myStrNumExec"
    .Show
  End With
End Sub  ' myStrNum *----*----*    *----*----*    *----*----*    *----*----*

Sub myStrNumExec(blln As Balloon, bttn As Long, bllnID As Long)
  Dim myCmmdBar As CommandBar
  Dim myCtrl As CommandBarControl
  '
  Set myCmmdBar = Application.CommandBars("Standard") ' 標準
  Set myCtrl = myCmmdBar.FindControl(ID:=128) ' 元に戻す
  '
  Select Case bttn
    Case 1
      If Selection.Range.Text = "" Then
        Call myStrNumFind
      Else
        Call myStrNumReplace
      End If
    Case 3
      Selection.Collapse wdCollapseStart
      Rem If myCtrl.TooltipText = "元に戻す VBA - Range.Text (Ctrl+Z)" Then
      Rem   Application.GoBack
      Rem End If
      myCtrl.Execute
    Case 5
      If MsgBox("蛍光ペン書式を解除しますか?", vbExclamation + vbYesNo + vbDefaultButton2, "蛍光ペン書式を解除") = vbNo Then
        Exit Sub
      End If
      Call myStrNumNoHighlight
    Case 2, -10 ' [検索]ボタン時
      Call myStrNumFind
    Case -12 ' [閉じる]ボタン時
      blln.Close
      Assistant.Animation = msoAnimationIdle
      Assistant.Visible = False
      Exit Sub
  End Select
  '
  Assistant.Animation = msoAnimationIdle
  If Tasks.Exists(Name:="Microsoft Word") = True Then
    Tasks("Microsoft Word").Activate
  End If
End Sub ' myStrNumExec *----*----*    *----*----*    *----*----*    *----*----*

Sub myStrNumFind()
  Rem *----*----*    *----*----*    *----*----*    *----*----*
  Rem 漢数字を検索し、蛍光ペン書式25%灰色を設定する。
  Rem *----*----*    *----*----*    *----*----*    *----*----*
  With Selection.Find
    .ClearFormatting
    .Text = "[〇一二三四五六七八九十百千万億兆]{1,}"
    .Replacement.Text = ""
    .Forward = True
    .Wrap = wdFindStop
    .Format = False
    .MatchCase = False
    .MatchWholeWord = False
    .MatchByte = False
    .MatchAllWordForms = False
    .MatchSoundsLike = False
    .MatchFuzzy = False
    .MatchWildcards = True
  End With
  '
myStrNumFindSubEntry:
  Selection.Find.Execute
  If Not Selection.Find.Found Then
    Rem 検索した文字列がない場合。
    GoTo myStrNumFindSubExit
  End If
  '
  Rem 検索した文字列がある場合。
  Select Case Selection.Range.HighlightColorIndex
    Case wdNoHighlight
      Selection.Range.HighlightColorIndex = wdGray25
    Case wdTurquoise, wdGray25
      Rem 既に蛍光ペン書式が設定されている場合。
      Selection.Words(1).Select
      Selection.Collapse wdCollapseEnd
      GoTo myStrNumFindSubEntry
  End Select
  '
  Exit Sub
myStrNumFindSubExit:
  Selection.Collapse wdCollapseEnd
  MsgBox "検索終了!"
End Sub ' myStrNumFind *----*----*    *----*----*    *----*----*    *----*----*

Sub myStrNumReplace()
  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 myTextCount As Long
  Dim myDigit As String
  Dim i As Integer
  Dim j As Integer
  '
  Rem 選択範囲に蛍光ペン書式を設定する。
  Selection.Range.HighlightColorIndex = wdTurquoise ' 水色
  '
  Rem 数値判断用の表を準備する。
  myArray = Array("〇", "一", "二", "三", "四", "五", "六", "七", "八", "九", "十", "百", "千", "万", "億", "兆", "京")
  '
  Rem 位取りする漢数字の有無を調べる。
  myTextCount = 0
  myTextCount = myTextCount + InStr(Selection.Range.Text, "千")
  myTextCount = myTextCount + InStr(Selection.Range.Text, "百")
  myTextCount = myTextCount + InStr(Selection.Range.Text, "十")
  '
myStrNumReplaceSubEntry:
  Rem 位取りがない場合、漢数字から洋数字へ単純置換する。
  If myTextCount = 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:=wdMove
    Exit Sub
  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 上の位が漢数字でない場合は、右へ1文字分戻り、繰り返しを抜ける。
      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 位取りを4桁ごとに文字列に挿入する。
  If myFlagUnit < 5 Then
    Selection.MoveRight Unit:=wdCharacter, Count:=myFlagDigit + 1, Extend:=wdMove
  Else
    Selection.Collapse wdCollapseStart
    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 *----*----*    *----*----*    *----*----*    *----*----*

Sub myStrNumNoHighlight()
  Rem *----*----*    *----*----*    *----*----*    *----*----*
  Rem 蛍光ペン書式解除
  Rem 漢数字を検索し、文書から蛍光ペン書式25%灰色・水色を解除する。
  Rem *----*----*    *----*----*    *----*----*    *----*----*
  Dim myStartMarker As Word.Range
  '
  Rem 検索開始点の取得。
  Rem カーソルが文章の途中あると、不都合が起こるので、
  Rem 文章の先頭に移動する。
  Set myStartMarker = Selection.Range
  Selection.Sentences(1).Select
  Selection.Collapse wdCollapseStart
  '
  Rem 洋数字・漢数字を1文字ずつ検索することを指定。
  With Selection.Find
    .ClearFormatting
    .Text = "[0-9〇一二三四五六七八九十百千万億兆]{1,1}"
    .Replacement.Text = ""
    .Forward = True
    .Wrap = wdFindStop
    .Format = False
    .MatchCase = False
    .MatchWholeWord = False
    .MatchByte = False
    .MatchAllWordForms = False
    .MatchSoundsLike = False
    .MatchFuzzy = False
    .MatchWildcards = True
  End With
  '
myStrNumNoHighlightSubEntry:
  Selection.Find.Execute
  If Not Selection.Find.Found Then
    Rem 検索した文字列がない場合。
    GoTo myStrNumNoHighlightSubExit
  End If
  '
  Rem 検索した文字列がある場合。
  Select Case Selection.Range.HighlightColorIndex
    Case wdGray25, wdTurquoise
      Selection.Range.HighlightColorIndex = wdNoHighlight
  End Select
  Selection.Collapse wdCollapseEnd
  '
  GoTo myStrNumNoHighlightSubEntry
myStrNumNoHighlightSubExit:
  Selection.Collapse wdCollapseEnd
  MsgBox "検索終了!"
  myStartMarker.Select ' 検索後、開始点に戻る。
End Sub ' myStrNumNoHighlight *----*----*    *----*----*    *----*----*    *----*----*
inserted by FC2 system