文章を読み上げ

Option Explicit

Sub 合成音声の情報取得()

'VocExcel（単語帳） / VBA Tips の 「SAPI で読み上げ」 を使わせていただいています。
'http://www.geocities.jp/dz02572i/VBA/excel_026.htm
'速度変更の方法は、牛のつれづれなるままに2.0 で教えていただきました。
'http://d.hatena.ne.jp/inopie/20080712/1215847602

   Dim スピーチオブジェクト As Object
   Dim 音声認識の人物数 As Integer
   Dim �� As Integer
   Dim 人物 As String
   Dim 人物リスト As String
   Dim 言語 As String
   Dim 自己紹介 As String
   Dim 速度 As Integer

  'Windows XP / Vistaで動作します。
  'Windows 2000では、コントロールパネルに「音声認識」がある場合に動作します。
  'コントロールパネル　--> 音声認識　--> 音声合成 タブ　-->「音声の選択」の設定に依存します。

  '-----------------------------------------
'　コントロールパネルの音声認識を取得する
  '-----------------------------------------

  'セットする
  Set スピーチオブジェクト = CreateObject("SAPI.SpVoice")

  '音声認識の人物の総数をカウントする
  音声認識の人物数 = スピーチオブジェクト.GetVoices.Count

   '速度を設定
   速度 = Range("B2").Value
   スピーチオブジェクト.Rate = 速度
   
   For �� = 0 To 音声認識の人物数 - 1
   
      言語 = ""
     '�ｂﾌ音声を取得する。
     Set スピーチオブジェクト.Voice = スピーチオブジェクト.GetVoices().Item(��) '「0」オリジン
     
     '�ｔﾔ目の人物名を取得する
     人物 = スピーチオブジェクト.Voice.getdescription()
     
     '人物の言語を判定する
     If InStr(人物, "Microsoft") > 0 Then
      言語 = "英語"
     ElseIf InStr(人物, "AquesTalk") > 0 Then
      言語 = "日本語"
     ElseIf InStr(人物, " ") > 0 Then
      言語 = "日本語"
     ElseIf 全角文字数(人物) > 0 Then
      言語 = "日本語"
     Else
      言語 = "日本語"
     End If
   
     '�ｂﾌ人物にspeakさせる
     Set スピーチオブジェクト.Voice = スピーチオブジェクト.GetVoices().Item(��)
     スピーチオブジェクト.Speak "TextBox1.Text"
     
     If 言語 = "日本語" Then
         スピーチオブジェクト.Speak "私の名前は、" & 人物 & "です。"
     Else
         スピーチオブジェクト.Speak "My name is " & 人物
     End If
     
     MsgBox "今しゃべったのは、" & 人物
       人物リスト = 人物リスト & CStr(��) & ":" & 人物 & vbNewLine
   Next ��
   
   MsgBox 人物リスト

End Sub

'========================================
Sub Win標準で読み上げ()
'========================================

    Dim I As Integer           ' カウンター用変数
    Dim 読み上げ用文字列 As String
    Dim 読上げ文字列配列    ' 読み上げ用文字列配列
    Dim 正規表現オブジェクト As RegExp
    
    Dim 処理対象文字列 As String
    Dim 文字 As Integer
    Dim 重複削除方法 As String
    Dim 開始行 As Integer

    Dim 言語 As String
    
       Set スピーチオブジェクト = CreateObject("Sapi.SpVoice")
   If Err Then Err.Clear: MsgBox "SAPIがインストールされていません": End

***********************************

            スピーチオブジェクト.Speak 読み上げ用文字列  ' 読み上げる

Private Sub 音声設定()

   If 言語 = "" Then
   
      Select Case Range("E2").Value
         Case 1
            音声 = "name = " & Range("D1").Value
         Case Else
            音声 = "name = " & Range("D2").Value
      End Select
   Else
      Select Case Range("E5").Value
         Case 1
            音声 = "name = " & Range("D4").Value
         Case Else
            音声 = "name = " & Range("D5").Value
      End Select
   End If

   On Error Resume Next
   Set スピーチオブジェクト.Voice = スピーチオブジェクト.GetVoices(音声).Item(0)

End Sub

Sub クリップテキストを貼付けPasteSpecial()

    Dim 最終行 As Long
    Dim 行 As Long

    ThisWorkbook.Worksheets("Sheet1").Activate
    最終行 = Cells(ActiveSheet.Rows.Count, 3).End(xlUp).Row
    
   If 最終行 > 6 Then
      Rows("7:" & CStr(最終行)).Delete Shift:=xlUp
   End If

    Columns("C:C").Select
    With Selection
        .VerticalAlignment = xlTop '縦位置を上詰めにします。
        .WrapText = True           '列幅で折り返します。
    End With
    Columns("A:A").Select
    With Selection
        .WrapText = False
    End With
    
   Range("C7").Select   '形式を選択して貼付けで、テキスト貼付け
   On Error GoTo 終了処理
   ActiveSheet.PasteSpecial Format:="テキスト" _
   , Link:=False, DisplayAsIcon:=False

    最終行 = Cells(ActiveSheet.Rows.Count, 3).End(xlUp).Row
   'セル内で折り返し表示させるため、再入力
    For 行 = 7 To 最終行
      Range("C1").Cells(行, 1).Value = Trim(Range("C1").Cells(行, 1).Value)
    Next 行
    
終了処理:
    Range("A1").Select
   End
End Sub

Dim 行 As Integer
Dim 最終行 As Integer
Dim 正規表現オブジェクト As RegExp
Dim 文字列 As String
Dim 行�� As Integer

Sub 字幕整形()

   ThisWorkbook.Worksheets("Sheet1").Activate
   最終行 = Cells(ActiveSheet.Rows.Count, 3).End(xlUp).Row
   
   ' 処理を高速化するため、画面描画停止､自動計算停止
   Application.ScreenUpdating = False
   Application.Calculation = xlCalculationManual
   
   Call 時間データ削除
   Call 空白行削除
   
    ' 画面描画再開､自動計算停止解除
    Application.ScreenUpdating = True
    Application.Calculation = xlCalculationAutomatic

   MsgBox "字幕整形を終わりました。"

End Sub

Private Sub 時間データ削除()

   Set 正規表現オブジェクト = New RegExp

   '★★ srt 形式のテキスト処理★★
   行�� = 0
   For 行 = 7 To 最終行
      文字列 = Range("C1").Cells(行, 1).Value

      正規表現オブジェクト.Pattern = ".* --> .*$" '時間データ
   
      If 文字列 = "" Then                         '空白セルは読み飛ばし
      
      ElseIf CStr(Val(文字列)) = 文字列 Then      '行�ｂﾍ待避させる
         行�� = Val(文字列)
         文字列 = ""
         Range("C1").Cells(行, 1).Value = 文字列
      ElseIf 正規表現オブジェクト.Test(文字列) Then '正規表現検索して時間データを削除
         文字列 = ""
         Range("C1").Cells(行, 1).Value = 文字列
      ElseIf 行�� <> 0 Then                       '行�ｂﾌセル位置をC列からB列に変更
         Range("B1").Cells(行, 1).Value = 行��
         行�� = 0
      End If
      
      正規表現オブジェクト.Pattern = "<.*?>"      'イタリック指定のタグ<i></i>

      If 文字列 <> "" Then                        '文字列が有る場合
         If Left(文字列, 1) = "-" Then            '行頭の - を削除(読み上げ時に誤読しないよう)
         文字列 = Trim(Right(文字列, Len(文字列) - 1))
         End If
         Do While 正規表現オブジェクト.Test(文字列) = True
            文字列 = 正規表現オブジェクト.Replace(文字列, "")  'イタリック指定のタグ<i></i>を削除
         Loop
         Range("C1").Cells(行, 1).Value = 文字列
      End If
      
   Next 行
   
   '★★ sub 形式のテキスト処理★★
   正規表現オブジェクト.Pattern = "\{.*\}"          '時間データ
   
   For 行 = 7 To 最終行
      文字列 = Range("C1").Cells(行, 1).Value

      If 文字列 = "" Then                         '空白セルは読み飛ばし
      
      ElseIf 正規表現オブジェクト.Test(文字列) Then '正規表現を使って、ワイルドカード検索。
         文字列 = 正規表現オブジェクト.Replace(文字列, "") '正規表現で時間データを削除
         If Left(文字列, 1) = "-" Then              '行頭の - を削除(読み上げ時に誤読しないよう)
            文字列 = Trim(Right(文字列, Len(文字列) - 1))
         End If
         文字列 = Replace(文字列, "|-", "")       'Replace関数で、改行文字を削除
         文字列 = Replace(文字列, "|", " ")       'Replace関数で、改行文字を削除
         Range("C1").Cells(行, 1).Value = 文字列
      End If
   Next 行

   Set 正規表現オブジェクト = Nothing

End Sub


Private Sub 空白行削除()

   行 = 7
   Do While 行 <= 最終行
      文字列 = Range("C1").Cells(行, 1).Value

      If 文字列 = "" Then
          Range("C1").Cells(行, 1).EntireRow.Delete
          最終行 = 最終行 - 1
      Else
         行 = 行 + 1
      End If
   Loop
   
End Sub

'========================================
Sub Win標準で読み上げ()
'========================================
    Dim i As Integer           ' カウンター用変数
    Dim 読み上げ用文字列 As String
    Dim 読上げ文字列配列    ' 読み上げ用文字列配列
    Dim 正規表現オブジェクト As RegExp
    
    Dim 処理対象文字列 As String
    Dim 文字 As Integer
    Dim 重複削除方法 As String
    Dim 開始行 As Integer
    Dim 終了行 As Integer
    Dim 言語 As String
    
    
    言語 = ""
    ThisWorkbook.Worksheets("Sheet1").Activate
    
    If CStr(Range("B2")) = "1" Then
        重複削除方法 = "ルビ優先(漢字削除)"
    Else
        重複削除方法 = ""
    End If
    デバッグ = Range("A1").Value
    
    
    Set 正規表現オブジェクト = New RegExp
    正規表現オブジェクト.Global = True
    

    開始行 = Cells(ActiveSheet.Rows.Count, 1).End(xlUp).Row 'しおりの行を検出
    If 開始行 < 7 Then 開始行 = 7
    終了行 = Cells(ActiveSheet.Rows.Count, 3).End(xlUp).Row + 1
    

    '言語判定
    If Trim(Range("C7").Value) = "英語" Then
            言語 = ""
    Else
      Select Case 終了行
      Case 8
        If 全角文字数(CStr(Range("C7").Value)) > 0 Then        '全角文字数
              言語 = "日本語"
        End If
      Case 9
        If (全角文字数(CStr(Range("C7").Value)) > 0) _
        Or (全角文字数(CStr(Range("C8").Value)) > 0) Then      '全角文字数
              言語 = "日本語"
        End If
      Case Is > 9
        If (全角文字数(CStr(Range("C7").Value)) > 0) _
        Or (全角文字数(CStr(Range("C8").Value)) > 0) _
        Or (全角文字数(CStr(Range("C9").Value)) > 0) Then      '全角文字数
              言語 = "日本語"
        End If
      Case Else
        言語 = "日本語"
      End Select
    End If

    
    行 = 開始行

    While 行 <= 終了行

         '読み上げ済みの行をたたむ
         If (行 > 開始行 + 1) And (行 > 8) Then ActiveWindow.ScrollRow = 行 - 1

         '読み上げ中のセルを着色
          If 行 > 7 Then
              Range("C1").Cells(行 - 1, 1).Interior.ColorIndex = xlNone
              Range("C1").Cells(行 - 1, 1).Font.ColorIndex = 0
              Range("A1").Cells(行 - 1, 1).Clear
          End If
          Range("C1").Cells(行, 1).Interior.ColorIndex = 1
          Range("C1").Cells(行, 1).Font.ColorIndex = 2
          'しおりセット
          Range("A1").Cells(行, 1).Value = "★" & CStr(Now)


        '==== 文字列取得 ===============================================
        
        読み上げ用文字列 = Range("C1").Cells(行, 1).Value

        If 読み上げ用文字列 <> "" _
         And Mid(読み上げ用文字列, 2, 3) <> "***" Then 'セルに有効文字列がある場合
      
        '==== 読み上げ 日本語 ==========================================
        '
         If 言語 = "日本語" Then
            読み上げ用文字列 = Replace(読み上げ用文字列, "」", "」。")
            読上げ文字列配列 = Split(読み上げ用文字列, "。")
              For i = 0 To UBound(読上げ文字列配列)
                If 読上げ文字列配列(i) <> "" Then   ' 空白以外を
                
                  正規表現オブジェクト.Pattern = "［＃.*?］" '［＃］入力者注を削除
                  読上げ文字列配列(i) = 正規表現オブジェクト.Replace(読上げ文字列配列(i), "")
      
                  If 重複削除方法 = "ルビ優先(漢字削除)" Then
                      GoTo 漢字削除
                  Else
                      GoTo ルビ削除
                  End If
                
重複削除後:
                  On Error GoTo 終了処理
                  Application.Speech.Speak 読上げ文字列配列(i)  ' 読み上げる
                  
                End If
              Next i
              
        '==== 読み上げ 英語 ============================================
        
         Else '英語
            On Error GoTo 終了処理
            Application.Speech.Speak 読み上げ用文字列  ' 読み上げる
         End If
        
      End If
      行 = 行 + 1
    Wend
    

    Exit Sub
    
ルビ削除:
        読上げ文字列配列(i) = Replace(読上げ文字列配列(i), "―", "ー")
        読上げ文字列配列(i) = Replace(読上げ文字列配列(i), "｜", "")
        
        正規表現オブジェクト.Pattern = "（.*?）" ' 正規表現パターン
        読上げ文字列配列(i) = 正規表現オブジェクト.Replace(読上げ文字列配列(i), "")
    
        正規表現オブジェクト.Pattern = "《.*?》"
        読上げ文字列配列(i) = 正規表現オブジェクト.Replace(読上げ文字列配列(i), "")

    GoTo 重複削除後

漢字削除:
        読上げ文字列配列(i) = Replace(読上げ文字列配列(i), "―", "ー")

        読上げ文字列配列(i) = 正規表現オブジェクト.Replace(読上げ文字列配列(i), "")
        処理対象文字列 = 読上げ文字列配列(i)
        
        If Len(処理対象文字列) > 3 Then
            読上げ文字列配列(i) = 傍点削除(処理対象文字列)
            読上げ文字列配列(i) = 漢字削除(読上げ文字列配列(i))
        End If
        
    GoTo 重複削除後
    
終了処理:

   If デバッグ = True Then Range("A1").Cells(行 + 1, 1).Value = _
   "▲エラー番号 " & Str(Err.Number) & Err.Source & _
    " でエラーが発生しました。" & Chr(13) & Err.Description
    On Error Resume Next
    
   End

End Sub

'========================================
Sub エージェントで読み上げ()
    '========================================
    '  引数　：なし
    '  返り値：なし
    '  仕様　：Microsoft Agentを使って、テキストを読み上げる。
    
    '==== 変数の初期化 ===========================================
    '
    Dim i As Integer           ' カウンター用変数
    Dim 読み上げ用文字列 As String
    Dim 読上げ文字列配列    ' 読み上げ用文字列配列
    Dim 行 As Integer
    Dim 正規表現オブジェクト As RegExp
    
    Dim 処理対象文字列 As String
    Dim 文字 As Integer
    Dim 重複削除方法 As String
    Dim 開始行 As Integer
    Dim 終了行 As Integer
    Dim リクエスト As Object
    Dim 言語 As String
    Dim 読み上げ対象 As String
    Dim 文字数 As Integer
    Dim 句点位置 As Integer

    言語 = ""
    ThisWorkbook.Worksheets("Sheet1").Activate
    
    If CStr(Range("B2")) = "1" Then
        重複削除方法 = "ルビ優先(漢字削除)"
    Else
        重複削除方法 = ""
    End If
    
    Set 正規表現オブジェクト = New RegExp
    正規表現オブジェクト.Global = True
    
      Set エージェント = CreateObject("Agent.Control")
      エージェント.Connected = True

   'エージェント・キャラクターを選択切り替え
   Select Case Range("E2").Value
      Case 1
         エージェント.Characters.Load "Merlin", "C:\Windows\MSAgent\chars\Merlin.acs"
         Set キャラクタ = エージェント.Characters.Character("Merlin")
      Case 2
         エージェント.Characters.Load "Genie", "C:\Windows\MSAgent\chars\Genie.acs"
         Set キャラクタ = エージェント.Characters.Character("Genie")
      Case 3
         エージェント.Characters.Load "Peedy", "C:\Windows\MSAgent\chars\Peedy.acs"
         Set キャラクタ = エージェント.Characters.Character("Peedy")
      Case Else
         エージェント.Characters.Load "Robby", "C:\Windows\MSAgent\chars\Robby.acs"
         Set キャラクタ = エージェント.Characters.Character("Robby")
   End Select

      
      キャラクタ.Show  ' 表示
      キャラクタ.MoveTo 70, 300
      キャラクタ.Play "Greet" ' "おじぎします"
      キャラクタ.Play Animation:="Restpose"
      
    開始行 = Cells(ActiveSheet.Rows.Count, 1).End(xlUp).Row 'しおりの行を検出
    If 開始行 < 7 Then 開始行 = 7
    終了行 = Cells(ActiveSheet.Rows.Count, 3).End(xlUp).Row + 1


    '言語判定
    If Trim(Range("C7").Value) = "英語" Then
            言語 = ""
    Else
      Select Case 終了行
      Case 8
        If 全角文字数(CStr(Range("C7").Value)) > 0 Then        '全角文字数
              言語 = "日本語"
        End If
      Case 9
        If (全角文字数(CStr(Range("C7").Value)) > 0) _
        Or (全角文字数(CStr(Range("C8").Value)) > 0) Then      '全角文字数
              言語 = "日本語"
        End If
      Case Is > 9
        If (全角文字数(CStr(Range("C7").Value)) > 0) _
        Or (全角文字数(CStr(Range("C8").Value)) > 0) _
        Or (全角文字数(CStr(Range("C9").Value)) > 0) Then      '全角文字数
              言語 = "日本語"
        End If
      Case Else
        言語 = "日本語"
      End Select
    End If
    
    If 言語 = "日本語" Then
       キャラクタ.LanguageID = &H411
    Else
       キャラクタ.LanguageID = &H409
    End If


    行 = 開始行
    
    While 行 <= 終了行

         '読み上げ済みの行をたたむ
'         If 行 > 10 Then ActiveWindow.SmallScroll Down:=1
         If (行 > 開始行 + 1) And (行 > 8) Then ActiveWindow.ScrollRow = 行 - 1

         '読み上げ中のセルを着色
          If 行 > 7 Then
              Range("C1").Cells(行 - 1, 1).Interior.ColorIndex = xlNone
              Range("C1").Cells(行 - 1, 1).Font.ColorIndex = 0
              Range("A1").Cells(行 - 1, 1).Clear
          End If
          Range("C1").Cells(行, 1).Interior.ColorIndex = 1
          Range("C1").Cells(行, 1).Font.ColorIndex = 2
          'しおりセット
          Range("A1").Cells(行, 1).Value = "★" & CStr(Now)


        '==== 文字列取得 ===============================================
        
        読み上げ用文字列 = Range("C1").Cells(行, 1).Value
        読み上げ用文字列 = Replace(読み上げ用文字列, "」", "」。")

        If 読み上げ用文字列 = "" Then
            Set リクエスト = キャラクタ.Play(Animation:="Restpose") '休憩
            GoTo リクエスト終了を待つ
        End If


        読上げ文字列配列 = Split(読み上げ用文字列, "。")
    
        '==== 読み上げ ===============================================
        '
       If 言語 = "日本語" Then
        For i = 0 To UBound(読上げ文字列配列)
          If 読上げ文字列配列(i) <> "" Then   ' 空白以外を
          
            正規表現オブジェクト.Pattern = "［.*?］" '入力者注を削除
            読上げ文字列配列(i) = 正規表現オブジェクト.Replace(読上げ文字列配列(i), "")

            If 重複削除方法 = "ルビ優先(漢字削除)" Then
                GoTo 漢字削除
            Else
                GoTo ルビ削除
            End If
          
重複削除後:

                  文字数 = Len(読上げ文字列配列(i))
                  
                  If 文字数 > 100 Then 'エージェントが一度に100文字までしか読めないため分割
                     Do While 文字数 > 100
                        句点位置 = InStrRev(読上げ文字列配列(i), "、", 100)
                        If 句点位置 > 0 Then
                           読み上げ対象 = Left(読上げ文字列配列(i), 句点位置)
                        Else
                           句点位置 = 90 '100文字の中に句点がない場合は、強制的に90字で切る
                           読み上げ対象 = Left(読上げ文字列配列(i), 句点位置)
                        End If
                           On Error GoTo 終了処理
                           Set リクエスト = キャラクタ.Speak(読み上げ対象)  ' 読み上げる
                           読上げ文字列配列(i) = Right(読上げ文字列配列(i), 文字数 - 句点位置)
                           文字数 = Len(読上げ文字列配列(i))
                     Loop
                     '句点以下の残りを読む。
                     On Error GoTo 終了処理
                     Set リクエスト = キャラクタ.Speak(読上げ文字列配列(i))  ' 読み上げる
                     
                  Else '読点までの範囲が100文字以内なら、そのまま読む。
                     On Error GoTo 終了処理
                     Set リクエスト = キャラクタ.Speak(読上げ文字列配列(i))  ' 読み上げる
                  End If
                End If
              Next i
        
        Else '英語
            On Error GoTo 終了処理
           Set リクエスト = キャラクタ.Speak(読み上げ用文字列)  ' 読み上げる
        End If

'         If UBound(読上げ文字列配列) = -1 Then                            '空白セルの場合
'            Set リクエスト = キャラクタ.Play(Animation:="Restpose") '休憩
'         End If
         
リクエスト終了を待つ:

         If リクエスト.Status = "0" Then
            'リクエスト.Status=2は、動作中
            行 = 行 + 1
         Else
             Call 指定秒待つ(2)
             GoTo リクエスト終了を待つ
         End If
    
        Set リクエスト = Nothing
    Wend
    
    キャラクタ.Play "Greet"
    キャラクタ.Play Animation:="Pleased"
    キャラクタ.Play Animation:="Wave"
    キャラクタ.Hide ' 隠す

    Exit Sub
    
ルビ削除:
        読上げ文字列配列(i) = Replace(読上げ文字列配列(i), "―", "ー")
        読上げ文字列配列(i) = Replace(読上げ文字列配列(i), "｜", "")
        
        正規表現オブジェクト.Pattern = "（.*?）"
        読上げ文字列配列(i) = 正規表現オブジェクト.Replace(読上げ文字列配列(i), "")
    
        正規表現オブジェクト.Pattern = "《.*?》"
        読上げ文字列配列(i) = 正規表現オブジェクト.Replace(読上げ文字列配列(i), "")

    GoTo 重複削除後

漢字削除:
        読上げ文字列配列(i) = Replace(読上げ文字列配列(i), "―", "ー")

        読上げ文字列配列(i) = 正規表現オブジェクト.Replace(読上げ文字列配列(i), "")
        処理対象文字列 = 読上げ文字列配列(i)
        
        If Len(処理対象文字列) > 3 Then
            読上げ文字列配列(i) = 傍点削除(処理対象文字列)
            読上げ文字列配列(i) = 漢字削除(読上げ文字列配列(i))
        End If
        
'        MsgBox 処理対象文字列 & String(2, vbNewLine) _
'        & 読上げ文字列配列(i)
        
    GoTo 重複削除後
    
終了処理:

   If デバッグ = True Then Range("A1").Cells(行 + 1, 1).Value = _
   "▲エラー番号 " & Str(Err.Number) & Err.Source & _
    " でエラーが発生しました。" & Chr(13) & Err.Description
    On Error Resume Next
    キャラクタ.Stop  ' 停止する
    キャラクタ.Hide  ' 隠す
'    エージェント.Characters.Unload CharacterID:="Merlin"
    
   Set リクエスト = Nothing
   Set キャラクタ = Nothing
   Set エージェント = Nothing
   End

End Sub

'===============================================================

'★★★★★★★★★★★★★★★★★★★★★★★★★★★★
Private Function 傍点削除(ByVal 処理対象文字列 As String)
Dim 出力文字数 As Integer
Dim 傍点終了位置 As Integer
Dim 傍点開始位置 As Integer
Dim 傍点数 As Integer
Dim 出力文字列 As String
Dim 入力行文字数 As Integer
Dim 検索文字目 As Integer
Dim 終了文字 As String
Dim 開始文字 As String

    出力文字数 = 0
    出力文字列 = ""
       
    入力行文字数 = Len(処理対象文字列)
    
    If InStr(処理対象文字列, "》") > 0 Then
        終了文字 = "》"
        開始文字 = "《"
    ElseIf InStr(処理対象文字列, "）") > 0 Then
        終了文字 = "）"
        開始文字 = "（"
    Else
        傍点削除 = 処理対象文字列 '★ルビ記号が文字列中にない場合は、変更無し
        GoTo 処理終わり
    End If
    
    For 検索文字目 = 入力行文字数 To 2 Step -1
        出力文字数 = 出力文字数 + 1
    
        '傍点の部分を摘出
        If Mid(処理対象文字列, 検索文字目, 1) = 終了文字 _
        And Mid(処理対象文字列, 検索文字目 - 1, 1) = "・" Then
        
        
            出力文字列 = Mid(処理対象文字列, 検索文字目 + 1, 出力文字数) _
            & 出力文字列 '★ルビ記号終了の右側を、出力対象として確定
            
            出力文字数 = 0

            傍点終了位置 = 検索文字目
            傍点開始位置 = InStrRev(処理対象文字列, 開始文字, 傍点終了位置)
            
            If 傍点開始位置 > 0 Then
                傍点数 = 傍点終了位置 - 傍点開始位置 - 1
                
                出力文字列 = Mid(処理対象文字列, 傍点開始位置 - 傍点数, 傍点数) _
                & 出力文字列 '★傍点の左側を、傍点数だけ、出力対象として確定
                検索文字目 = 傍点開始位置 - 傍点数
                
'                MsgBox Mid(処理対象文字列, 検索文字目 - 1, 1)

                If Mid(処理対象文字列, 検索文字目 - 1, 1) = "｜" Then
                    検索文字目 = 検索文字目 - 2
                    出力文字数 = 0
                End If
            End If
        End If
        
    Next 検索文字目 '文字列の先頭まで繰返し
    
    傍点削除 = Left(処理対象文字列, 出力文字数 + 2) & 出力文字列
    
処理終わり:
End Function

'★★★★★★★★★★★★★★★★★★★★★★★★★★★★
Private Function 漢字削除(ByVal 処理対象文字列 As String)

Dim 出力文字数 As Integer
Dim 出力文字列 As String
Dim 入力行文字数 As Integer
Dim 検索文字目 As Integer
Dim 漢字文字数 As Integer
Dim ルビ終了位置 As Integer
Dim ルビ開始位置 As Integer
Dim ルビ文字数 As Integer
Dim 漢字開始位置 As Integer
Dim 終了文字 As String
Dim 開始文字 As String
Dim ルビ部分 As String
Dim 文字 As String

    出力文字数 = 0
    出力文字列 = ""
       
    入力行文字数 = Len(処理対象文字列)
    
    If InStr(処理対象文字列, "》") > 0 Then
        終了文字 = "》"
        開始文字 = "《"
    ElseIf InStr(処理対象文字列, "）") > 0 Then
        終了文字 = "）"
        開始文字 = "（"
    Else
        漢字削除 = 処理対象文字列 '★ルビ記号が文字列中にない場合は、変更無し
        GoTo 処理終わり
    End If
    
    For 検索文字目 = 入力行文字数 To 1 Step -1
    
        出力文字数 = 出力文字数 + 1
        
        文字 = Mid(処理対象文字列, 検索文字目, 1)
        
'        MsgBox "最後の文字から：「" & 文字 & "」 文字コード=" & Asc(文字) '★デバッグ用★★★★★

        'ルビの部分を摘出
        If 文字 = 終了文字 Then                                            '終了文字 = "》" or "）"
        
            出力文字列 = Mid(処理対象文字列, 検索文字目 + 1, 出力文字数) _
            & 出力文字列 '★ルビ記号終了の右側を、出力対象として確定

            出力文字数 = 0

            ルビ終了位置 = 検索文字目
            ルビ開始位置 = InStrRev(処理対象文字列, 開始文字, ルビ終了位置) '開始文字 = "《" or "（"

            If ルビ開始位置 > 0 Then
                ルビ文字数 = ルビ終了位置 - ルビ開始位置
                ルビ部分 = Mid(処理対象文字列, ルビ開始位置 + 1, ルビ文字数 - 1)
                'ルビ記号に囲まれた範囲を、ルビ部分として確定
            Else
                Exit For
            End If
            
            漢字開始位置 = InStrRev(処理対象文字列, "｜", ルビ開始位置)
            If 漢字開始位置 > 0 Then
            '漢字部分が明示されている場合は、
                漢字文字数 = ルビ開始位置 - 漢字開始位置 - 1

                If 漢字文字数 > 0 And 漢字文字数 <= ルビ文字数 Then
                '漢字部分が明示されている場合は、漢字数が、ルビ数以下の場合にルビ部分を削除
                    出力文字列 = ルビ部分 & 出力文字列
                    検索文字目 = 漢字開始位置 - 1

                    GoTo 次の文字へ
                End If
            End If
            
            文字 = Mid(処理対象文字列, ルビ開始位置 - 1, 1)
'            MsgBox 文字 & " 文字コード=" & Asc(文字) '★デバッグ用★★★★★
            
            If Asc(文字) > -31850 Or 文字 = "々" Then '漢字 と「々」Asc(文字) = -32424
            '漢字部分が明示されていない場合は、ルビ開始の直前が漢字の場合は、
            
            '一文字ずつ､ルビ文字数分まで､漢字が続くまで前方を探す
                For 漢字文字数 = 1 To ルビ文字数
                                
                    If ルビ開始位置 > 漢字文字数 Then
                        文字 = Mid(処理対象文字列, ルビ開始位置 - 漢字文字数, 1)
'                        MsgBox 文字 & " 文字コード=" & Asc(文字) '★デバッグ用★★★★★

                        If Asc(文字) <= -31850 And 文字 <> "々" Then   'かなカナ
                        'ルビ部分の文字数まで遡る間に、かな文字に出会ったら、
                        '漢字数を確定して、漢字部分を削除
                            出力文字列 = ルビ部分 & 出力文字列
                            出力文字数 = 0
                            検索文字目 = ルビ開始位置 - 漢字文字数
                            
                            If 文字 = "》" Or 文字 = "）" Then
                                検索文字目 = 検索文字目 + 1
                                出力文字数 = -1
                            End If

                            GoTo 次の文字へ
                        End If
                    Else
                        漢字削除 = ルビ部分 & 出力文字列

                        GoTo 処理終わり
                    End If
                    
                Next 漢字文字数
                
                '漢字数が多い場合は、ルビ側を捨てる。
                検索文字目 = ルビ開始位置 - 1
                                
            End If

        End If
        
次の文字へ:
    Next 検索文字目 '文字列の先頭まで繰返し

    漢字削除 = Left(処理対象文字列, 出力文字数 + 1) & 出力文字列
処理終わり:
End Function

Sub 停止()

   On Error GoTo 終了処理
    キャラクタ.Stop  ' 停止する
    キャラクタ.Hide  ' 隠す
終了処理:

   SendKeys "{ESC}", True
   End 'エージェントを終了させる。
    
End Sub

Dim ReturnValue, I
ReturnValue = Shell("CALC.EXE", 1)        ' 電卓を実行します。
AppActivate ReturnValue                   ' 電卓をアクティブにします。
For I = 1 To 20                           ' ループ カウンタを設定します。
    SendKeys I & "{+}", True              ' 電卓にキー コードを転送して、
Next I                                    ' I の値に 1 を加算します。
SendKeys "=", True                        ' 和を求めます。
SendKeys "%{F4}", True                    ' Alt + F4 キーを転送して電卓を終了します。

Dim MyAppID, ReturnValue
AppActivate "Microsoft Word"    ' Microsoft Word をアクティブにします。

' AppActivate ステートメントでは Shell 関数の戻り値を使うこともできます。
MyAppID = Shell("C:\Program Files\Microsoft Office\Office\WINWORD.EXE", 1)    ' Microsoft Word を実行します。
AppActivate MyAppID            ' Microsoft Word をアクティブにします。



' Shell 関数の戻り値を使うこともできます。
ReturnValue = Shell("c:\Program Files\Microsoft Office\Office\EXCEL.EXE",1)    ' Microsoft Excel を実行します。
AppActivate ReturnValue        ' Microsoft Excel をアクティブにします。

Sub 設定()

    Set エージェント = CreateObject("Agent.Control")
    エージェント.Connected = True
    エージェント.Characters.Load "Merlin", "C:\Windows\MSAgent\chars\Merlin.acs"
    
    Set キャラクタ = エージェント.Characters.Character("Merlin")

    エージェント.PropertySheet.Visible = 1
    
End Sub

Option Explicit
Option Base 1

Public Declare Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As Long)
'これで Sleepを使ってミリ秒単位で処理にウェイトを入れることができます｡

   Dim スピーチオブジェクト As Object
   Dim 音声 As String
   Dim 速度 As Integer
   Dim 列 As Integer
   Dim 前列 As Integer

'========================================
Sub Win標準で読み上げ()
'========================================
   Dim 読み上げ用文字列 As String
   Dim キャラクタ(2, 2)
   Dim 行 As Integer
   Dim 前行 As Integer

   Set スピーチオブジェクト = CreateObject("Sapi.SpVoice")
   If Err Then Err.Clear: MsgBox "SAPIがインストールされていません": End

   ThisWorkbook.Worksheets("Sheet1").Activate
   'キャラクタの取得
   If Range("F2").Value = 1 Then
      キャラクタ(1, 1) = Range("E2").Value
   Else
      キャラクタ(1, 1) = Range("E3").Value
   End If
   If Range("H2").Value = 1 Then
      キャラクタ(1, 2) = Range("G2").Value
   Else
      キャラクタ(1, 2) = Range("G3").Value
   End If
   If Range("F5").Value = 1 Then
      キャラクタ(2, 1) = Range("E5").Value
   Else
      キャラクタ(2, 1) = Range("E6").Value
   End If
   If Range("H5").Value = 1 Then
      キャラクタ(2, 2) = Range("G5").Value
   Else
      キャラクタ(2, 2) = Range("G6").Value
   End If
   
   '速度を設定
   速度 = Range("B9").Value
   スピーチオブジェクト.Rate = 速度
   
   Do
      列 = ActiveCell.Column '選択中の列セル位置を取得
      If 列 <> 2 And 列 <> 3 Then Exit Do
      
      行 = ActiveCell.Row    '選択中の行セル位置を取得
      If 行 < 11 Then Exit Do
      
      読み上げ用文字列 = Range("C1").Cells(行, 1).Value
         
      If (行 <> 前行 Or 列 <> 前列) And Len(読み上げ用文字列) > 0 Then
         音声 = Range("B1").Cells(行, 1).Value

         If 全角文字数(読み上げ用文字列) > 0 Then     '読み上げ文字が日本語
            If 音声 = "男" Then
               音声 = "name = " & キャラクタ(1, 1)
            Else
               音声 = "name = " & キャラクタ(1, 2)
            End If
         Else                                         '読み上げ文字が英語
            If Left(音声, 1) = "m" Then
               音声 = "name = " & キャラクタ(2, 1)
            Else
               音声 = "name = " & キャラクタ(2, 2)
            End If
         End If
         
         On Error Resume Next
         Set スピーチオブジェクト.Voice = スピーチオブジェクト.GetVoices(音声).Item(0)
         スピーチオブジェクト.Speak 読み上げ用文字列  '読み上げる
         前行 = 行
         前列 = 列
      Else
         DoEvents
         Sleep (100)
      End If
   Loop
   
   MsgBox "マクロを終了しました。"
   Exit Sub
   
End Sub