文章を読み上げ

Excel VBA のトップに戻る
Excel VBA 目次

SAPIを使う
TextToSpeech と MSAgentSpeak
クリップボードからテキストデータを取得
英語字幕テキストを整形

Windows 標準で読み上げ
Microsoft Agentで読み上げ
エージェント停止
エージェント設定

音声応答ツール

索引

SAPIを使う

sapi.dll は、ファイル・パスが違う場合があるので参照設定しないほうが良い
sapi.dll は、ファイル・パスが違う場合があるので参照設定しないほうが良い
参照設定すると、F1 で、オブジェクトの構成を確認できます。
 SAPI(Speech Application Programming Interface)とは、Windowsアプリケーションで音声認識や音声合成を使うためにマイクロソフトが開発した、プログラミング言語で利用できるライブラリなどの機能の入り口です。
http://ja.wikipedia.org/wiki/Speech_Application_Programming_Interface

 sapi.dll は、その登録パスが、使っているパソコンの環境によって異なる場合があります。この場合は、参照設定を使ったマクロは、受け取ったパソコン側で設定変更しなければなりません。このため、私は、[Microsoft Speech Object Library] を参照設定しないほうが、制約が少ないので、良いと思います。

 「合成音声の情報取得」で、お持ちのパソコンに登録されているキャラクターの一覧を、見ることができます。

 WinXP 標準の英語音声は、Sam のみですが、下記で sapi51xp.msi もしくは、Sp5TTIntXP.exe をインストールすると、Mary - 女声 (English、私の推奨)と、Mike - 男声 (English)を、追加できます。
 sapi51xp.msi (XP 用。Vista や 7 では機能しません。)
http://www.transparentcorp.com/downloads/sapi51xp.msi

 Speech SDK 5.1
http://www.microsoft.com/downloads/details.aspx?FamilyId=5E86EC97-40A7-453F-B0EE-6583171B4530&displaylang=en
 の、Sp5TTIntXP.exe (XP 用。Vista や 7 では機能しません。)
http://download.microsoft.com/download/B/4/3/B4314928-7B71-4336-9DE7-6FA4CF00B7B3/Sp5TTIntXP.exe
(Vista の場合は、Speech SDK 5.3 で、そのキャラクタ Microsoft Anna-English はベストなので、追加メンバ不要です。)

 上記の日本語の説明
http://support.microsoft.com/kb/320207/ja

 参考:
 VBSでスイスイ(スピーチオブジェクトを使ってみる)
http://yayoi3gatsu.sakura.ne.jp/rd.cgi?f=vbs01
 VocExcel(単語帳) / VBA Tips (SAPI で読み上げ)
http://www.geocities.jp/dz02572i/VBA/excel_026.htm
http://msdn2.microsoft.com/en-us/library/ms723609(VS.85).aspx
http://msdn2.microsoft.com/en-us/library/ms723601(VS.85).aspx
http://msdn.microsoft.com/ja-jp/library/bb690934.aspx
 Excelで日本語・英語を読み上げるマクロ
http://www.cs.k.tsukuba-tech.ac.jp/labo/koba/software/excel.php

 以下は、TextToSpeechVBA02.xls の SAPI で読み上げさせるための、メインの部分です。

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
   
      言語 = ""
     'bフ音声を取得する。
     Set スピーチオブジェクト.Voice = スピーチオブジェクト.GetVoices().Item() '「0」オリジン
     
     'tヤ目の人物名を取得する
     人物 = スピーチオブジェクト.Voice.getdescription()
     
     '人物の言語を判定する
     If InStr(人物, "Microsoft") > 0 Then
      言語 = "英語"
     ElseIf InStr(人物, "AquesTalk") > 0 Then
      言語 = "日本語"
     ElseIf InStr(人物, " ") > 0 Then
      言語 = "日本語"
     ElseIf 全角文字数(人物) > 0 Then
      言語 = "日本語"
     Else
      言語 = "日本語"
     End If
   
     'bフ人物に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

 参考:
 Microsoft Speech API (SAPI) 5.3 (Windows Vista に同梱されたバージョン)
http://msdn.microsoft.com/en-us/library/ms723627(VS.85).aspx
 SpVoice Interface (SAPI 5.3)
http://msdn.microsoft.com/en-us/library/ms723602(VS.85).aspx

この種類の目次に戻る↑ 索引へ↓ トップページに戻る


TextToSpeech と MSAgentSpeak

 「青空文庫」の一括ダウンロード・マクロ(AozoraGetter)を知人に紹介したところ、
「いっそのこと、ダウンロードした小説を、読み上げるところまでできれば、もっと役に立つ」と言われたので、作ってみました。

 「青空文庫」は、ルビ付きテキストのため、漢字とルビを重複して読み上げてしまいます。
 このマクロでは、漢字とルビのどちらか一方を指定して消して、同じことを繰り返して読まないようにしました。

 ただ、日本語の音読では、
   1.漢字を、カナに逆変換する
   2.カナに、音の高低をつける
と、2つの大きなハードルがあって、テキスト・データそのままだと、人が読上げるようにはうまく行きません。
 しかし、英語だと、その制約が、比較的少ないので、有効です。
 このマクロは、映画の英語字幕データを、貼り付けて、読上げさせるのに使うと、それなりに実用になるかと思っています。

Windows 標準で読み上げるマクロのダウンロード→TextToSpeechVBA02.xls(実用版)
エージェントも使い分けられるマクロのダウンロード→MSAgentSpeak08.xls(遊び版)
 使い方は、MSAgentSpeak の項を参照下さい。


 【注1】:マクロを含む Excel ファイルを開くことができるように、「マクロセキュリティ」で、セキュリティレベルを「中」に設定して下さい。

 【注2】:Windows 標準で読上げるときに、Excelの「[読み上げ]」機能を使っています。
 Excelの「ツール」→「音声」→「[読み上げ] ツールバーの表示」をクリックして、読上げツールバーが、「色付き」で表示されることを、前もって確認して下さい。
 もし、「[読み上げ] ツールバー」が、色付でない場合は、下記でセットアップして下さい。
 読み上げ機能を Excel 2003 に追加セットアップする方法
http://kokodane.com/yomiage.htm
http://support.microsoft.com/kb/881773/ja
 読み上げの設定変更
http://kokoro.kir.jp/excel/reading-out-setting.html

 【注3】:エージェントを使って読み上げる場合は、
 自己満足なホームページ
http://jikoman.sin-cos.com/msa/msa.html
↑ ここの「Step 7 インストールチェック」で、「音声認識エンジン」以外が「インストール済み」と表示されることを、確認して下さい。
 Microsoft Agentインストール方法
http://software.fujitsu.com/jp/atlas/function/read/msagent.html



 このマクロのデザインと骨格は、下記を参考にさせていただきました。
 MS Agentを使った文章読み上げソフト
http://codezine.jp/a/article/aid/867.aspx
http://codezine.jp/a/article/aid/870.aspx

Microsoft Agent を使った Office アプリケーションへのアニメーション効果の設定
http://msdn.microsoft.com/ja-jp/library/aa163978(office.10).aspx

 百万人のプログラミング
http://fry.no.coocan.jp/MISC/mil/

 Agentにお話をしてもらう
http://www6.plala.or.jp/MilkHouse/menu2.html

 キャラクタアニメーション ( Microsoft Agent )
http://winofsql.jp/VA003334/smalltech051002131227.htm


 Win XP で標準機能だった、日本語のスピーチ エンジンが、Windows Vista や Windows 7 には、標準搭載されていません。
http://www.microsoft.com/japan/enable/products/windowsvista/narratorturnon.mspx
したがって、このマクロの日本語読上げを Vista や Windows 7 で使うことができません。(英語の読上げは、できます。)
Vista は、「重い」、「うざい」、ということは良く聞きますが、その上さらに、「役立たず」ということができまね。

この種類の目次に戻る↑ 索引へ↓ トップページに戻る


クリップボードからテキストデータを取得

 クリップ・ボードのテキストデータを、既定のセルに貼付けます。

 クリップボードのデータを取得する方法には、以下の 3つの方法があります。

1.MSFormsのメンバの DataObject を使用する。
 この場合は、Microsoft Forms 2.0 Object Library を参照設定する必要があります。

2.Internet Explorer のインスタンスを利用する。←VBSの場合はこちら

3.Worksheet オブジェクトの PasteSpecial メソッド を使う。←Excel VBA での私の推奨★

 以下は、下記サイトのコードを、そのまま使わせていただいています。

 Office TANAKA
 クリップボードを操作する(1)
http://officetanaka.net/excel/vba/tips/tips20.htm

 掌のおもちゃ箱
http://zaz.air-nifty.com/
http://zaz.air-nifty.com/blog/vbscript/index.html

3つのマクロ記述を比較できます。→ClipBoardVBA02.xls

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

 解説:

 DataObject オブジェクトは、データ転送操作により転送された書式付きテキスト データが格納される領域です。DataObject オブジェクトに格納されているテキストに対応するデータ フォーマットのリストも保持されます。

 DataObject オブジェクトは、クリップボード テキスト形式のテキストを 1 つと、それ以外のテキスト形式のテキスト (カスタム形式やユーザー定義形式など) を、各テキスト形式ごとに 1 つずつ保持できます。

 DataObject オブジェクトは、クリップボードとは異なります。DataObject オブジェクトは、クリップボード関連のコマンドと、テキストに対するドラッグ アンド ドロップ操作関連のコマンドをサポートしています。クリップボード関連の操作 (GetText など) やドラッグ アンド ドロップ操作を開始すると、操作対象のデータは DataObject オブジェクトに移動されます。

 DataObject オブジェクトは、クリップボードと似た働きをします。テキスト文字列を DataObject オブジェクトにコピーすると、DataObject オブジェクトにそのテキスト文字列が格納されます。2 つ目の同じ形式のテキスト文字列を DataObject オブジェクトにコピーすると、最初のテキスト文字列は破棄され、2 つ目のテキストのコピーが DataObject オブジェクトに格納されます。DataObject オブジェクトには、同一形式のテキスト文字列の場合、最後にコピーされたテキストのみが保持されます。


 IE7の場合は、Internet Explorerを使う方法では、「別のプログラムで OLE の操作が完了するまで待機を続けます。」と表示されて、マクロが止まらなくなります。
 あるいは、何も表示されなくて、マクロが止まります。

 これは、バックグラウンドで、下記のダイアログが表示されているからです。
この Web ページがクリップボードへアクセスするのを許可しますか?

 このダイアログが表示されないようにするには、IE7を以下のように設定します。
 IE7の「ツール」→「インターネット オプション」で、
「ツール」→「インターネット オプション」
 「セキュリティ」タブの「レベルのカスタマイズ」を選択します。
「セキュリティ」タブの「レベルのカスタマイズ」
「スクリプトによる貼り付け処理の許可」を「ダイアログを表示する」から「有効にする」に変更します。
きとはきいと


 WSH と VBScript 場合は、Excel VBAの DataObject のように、クリップボードを操作する機能がありません。
 この場合は、クリップボードを操作することができる、Internet Explorer に頼るしかありません。
http://www.microsoft.com/japan/technet/scriptcenter/resources/qanda/dec04/hey1215.mspx
 Internet Explorer を使って、クリップボードにデータをコピーしたり、クリップボードからデータを貼り付けたりします。

 上のコードでは、Internet Explorer のインスタンスを作成し、それを空白のページとして開いています。
 このインスタンス(instance:メモリ上に配置されたデータの集合)は実際には表示されません。Visible を TRUE に設定していないからです。すべての処理がバックグラウンドで実行されます。
 次に、clipboardData.GetData メソッドを使用してクリップボードからテキストを取得し、変数 クリップText に格納します。
 Internet Explorer のインスタンス (objIE.Quit) を解放します。

 クリップボードにデータをコピーする場合は、以下のようにします。
clipboardData.setData "text", "クリップボードに格納したい文字列"


この種類の目次に戻る↑ 索引へ↓ トップページに戻る


英語字幕テキストを整形

 洋画の字幕データは、映画の字幕データ・ダウンロード・サイトで、簡単に入手できます。
 字幕のテキストは、下の2種類の形式が有ります。

 srt 形式
1
00:04:24,438 --> 00:04:26,872
-Here we go, Nick.
-All right.

2
00:04:29,71 --> 00:04:31,644
-Good morning, Detective.
-I want a shot of the two detectives.

 sub 形式
{6438}{6494}- Here we go, Nick.|- All right
{6565}{6609}- Good morning, Detective.|- I want a shot of the two detectives.

 ここでは、読み上げるためのセリフの部分だけを抽出して、読み上げに不要な部分を削除する「整形」をします。

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      '行bヘ待避させる
         行 = Val(文字列)
         文字列 = ""
         Range("C1").Cells(行, 1).Value = 文字列
      ElseIf 正規表現オブジェクト.Test(文字列) Then '正規表現検索して時間データを削除
         文字列 = ""
         Range("C1").Cells(行, 1).Value = 文字列
      ElseIf 行 <> 0 Then                       '行bフセル位置を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

この種類の目次に戻る↑ 索引へ↓ トップページに戻る


Windows 標準で読み上げ

'========================================
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

 解説:

 Speech.Speak メソッド は、引数として渡されたテキスト文字列を再生します。

expression.Speak(Text, SpeakAsync, SpeakXML, Purge)

expression 必ず指定します。対象となる Speech オブジェクトを返すオブジェクト式を指定します。

 Text 必ず指定します。文字列型 (String) の値を使用します。読み上げるテキストを指定します。

 SpeakAsync 省略可能です。バリアント型 (Variant) の値を使用します。True の場合、Text は非同期で読み上げられ、Text の読み上げが終わるのを待たずに次の処理に進みます。False の場合、Text は同期して読み上げられ、Text の読み上げが終わってから次の処理に進みます。既定値は False です。
 SpeakXML 省略可能です。ブール型 (Boolean) の値を使用します。True の場合、Text は XML として解釈されます。False の場合、Text は XML として解釈されないので、XML タグも解釈されずに読み上げられます。既定値は False です。
 Purge 省略可能です。バリアント型 (Variant) の値を使用します。True の場合、Text を読み上げる前に、現在の読み上げを終了させ、バッファに残っているテキストを取り除きます。? False の場合、Text を読み上げる前に、現在の読み上げを終了させず、バッファに残っているテキストも取り除きません。既定値は False です。

 次の使用例は、"こんにちは" を読み上げます。

Sub UseSpeech()
    Application.Speech.Speak "こんにちは"
End Sub

この種類の目次に戻る↑ 索引へ↓ トップページに戻る


エージェントで読み上げ


 注意:Agent のアニメーション機能を使い始める前に、
Microsoft Agent Control 2.0 への参照設定を追加する必要があります

 Agent の Request の Status プロパティで、動作終了のイベントを取得して、Excel のセル操作と同期させています。
http://msdn.microsoft.com/en-us/library/aa227647(VS.60).aspx

表 14.14: Request オブジェクト Status コード
Status 内容
0 要求はうまくいった。
1 要求は失敗した。
2 要求は保留中である。
3 要求は中断された。
4 要求は進行している。
 Request オブジェクトを使うとき、下の2つのイベントも利用できます。
 RequestStart と RequestComplete
 特定のメソッドの状態を追跡するために、グローバルな Request オブジェクトを作ると、これらのイベントが、発生します。
 このイベントは、要求しているクライアント・オブジェクトの中でのみ引き起こされます。

'========================================
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

 解説:

 SmallScroll メソッド は、指定された行数分または列数分だけ、ウィンドウの文字列をスクロールします。

expression.SmallScroll(Down, Up, ToRight, ToLeft)

 expression   必ず指定します。Window オブジェクトを返すオブジェクト式を指定します。
 Down   省略可能です。バリアント型 (Variant) の値を使用します。指定した行数分だけ、ウィンドウの文字列が下にスクロールします。
 Up   省略可能です。バリアント型 (Variant) の値を使用します。指定した行数分だけ、ウィンドウの文字列が上にスクロールします。
 ToRight   省略可能です。バリアント型 (Variant) の値を使用します。指定した列数分だけ、ウィンドウの文字列が右にスクロールします。
 ToLeft   省略可能です。バリアント型 (Variant) の値を使用します。指定した列数分だけ、ウィンドウの文字列が左にスクロールします。

 説明:
 引数 DownUp を共に指定すると、ウィンドウの文字列は 2 つの引数の差だけスクロールします。たとえば、引数 Down に 3、Up に 6 を指定すると、ウィンドウの文字列は上に 3 行分スクロールします。
 引数 ToLeftToRight を共に指定すると、ウィンドウの文字列は 2 つの引数の差だけスクロールします。たとえば、引数 ToLeft に 3、ToRight に 6 を指定すると、ウィンドウの文字列は右に 3 列分スクロールします。
 いずれの引数にも、負の数を指定できます。

 使用例
 次の使用例は、シート 1 のアクティブ ウィンドウの文字列を下に 3 行分スクロールします。

Worksheets("Sheet1").Activate
ActiveWindow.SmallScroll down:=3

 ScrollRow プロパティは、ウィンドウ枠 (ペイン) 内またはウィンドウ内で上端に表示される行の番号の値を設定します。値の取得および設定が可能です。長整数型 (Long) の値を使用します。
 解説

ウィンドウを分割表示している場合、Window オブジェクトの ScrollRow プロパティは左上のウィンドウ枠を対象とします。ウィンドウ枠を固定している場合、Window オブジェクトの固定領域は対象外とされます。
 使用例

次の使用例は、行 10 が上端になるようにウィンドウをスクロールします。

Worksheets("Sheet1").Activate
ActiveWindow.ScrollRow = 10

この種類の目次に戻る↑ 索引へ↓ トップページに戻る


エージェント停止

Sub 停止()

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

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

 解説:

 SendKeys ステートメント は、キーストロークまたはキーストロークの組み合わせを、キーボードから入力したときと同様にアクティブ ウィンドウに渡します。

構文  SendKeys string[, wait]

 SendKeys ステートメントの構文は、次の名前付き引数から構成されます。
項目 内容
string 必ず指定します。転送するキー コードを表す文字列式を指定します。
wait 省略可能です。名前付き引数 string の転送によって行われる処理が終了するまで、実行を一時中断するかどうかを次に示すブール型 (Boolean) の値で指定します。  (既定値) Falseプロシージャの終了を待たずに次の行に制御を移します。
 True処理が終了するまで実行を一時中断します。

 キーボードの各キーは 1 つ以上の文字で表されます。キーボード上の文字を渡すには、キーの指定にその文字を使います。たとえば、キーボード上の文字 A を表すには、名前付き引数 string "A" を指定します。複数の文字を表すには、文字を連続して設定します。たとえば、文字 A、B、C を表すには、名前付き引数 string"ABC" と指定します。
 プラス記号 (+)、キャレット (^)、パーセント記号 (%)、チルダ (~)、かっこ (( )) はそれぞれ SendKeys ステートメントで特別な意味を持っています。これらの文字を渡すには、文字を中かっこ ({ }) で囲んで指定します。たとえば、プラス記号は {+} のように指定します。角かっこ ([ ]) は SendKeys ステートメントでは特別な意味を持ちませんが、Microsoft Windows の他のアプリケーションで特別な意味を持つ場合があるので、中かっこで囲みます。これは、ダイナミック データ エクスチェンジ (DDE) を行うときに角かっこが重要になることがあるためです。文字として中かっこを渡すには、{{} または {}} を使います。
 キーを押したときに表示されない文字 または、文字ではなく動作を表すキーを指定するには、例えば、Enter キーは、{ENTER}または {~}、や Tab キーは{TAB}などのコードを使います。

 Shift キー、Ctrl キー、または Alt キーと他のキーとの組み合わせを指定するには、通常のキー コードの前に次のコードを単独、または組み合わせて記述します。
キー コード
Shift +
Ctrl ^
Alt %

 Shift キー、Ctrl キー、Alt キーを押しながら他のキーを押す操作を指定するには、キーのコードをかっこで囲みます。たとえば、Shift キーを押しながら EC を押す操作を指定するには、"+(EC)" を使います。Shift キーを押しながら E を押し、その後 Shift キーを離して C を押す操作を指定するには、"+EC" を使います。
 同じキー ストロークの繰り返しを指定するには、{key number} という形式を使います。keynumber の間には必ず半角のスペースが必要です。たとえば、{LEFT 42}キーを 42 回押すことを意味します。また {h 10} は、H キーを 10 回押すことを意味します。
 SendKeys ステートメントは、Microsoft Windows 上で動作するように設計されたアプリケーション以外にはキー ストロークを渡せません。また Sendkeys ステートメントは、アプリケーションに Copy キーを渡せません。


 SendKeys ステートメントの使用例
 次の例は、Shell 関数を使って、電卓アプリケーションを実行します。
 SendKeys ステートメントでキーストロークを転送して、数値の加算を行ってから電卓アプリケーションを終了します。このプログラムを実行するには、コードを任意のプロシージャに貼り付けてから、そのプロシージャを実行してください。
 AppActivate ステートメントによって、フォーカスが電卓アプリケーションに移動するため、このコードをシングル ステップで実行することはできません。

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 キーを転送して電卓を終了します。


 AppActivate ステートメント は、アプリケーション ウィンドウをアクティブにします。

構文  AppActivate title[, wait]

項目 内容
title 必ず指定します。アクティブにするアプリケーション ウィンドウのタイトル バーのタイトルを表す文字列式を指定します。名前付き引数 titleShell 関数によって返されるタスク ID を指定して、アプリケーションをアクティブにすることもできます。
wait 省略可能です。名前付き引数 title で指定したアプリケーションをアクティブにする前に呼び出し側のアプリケーションにフォーカスを持たせるかどうかを、次に示すブール型 (Boolean) の値を使って設定します。

(既定値) False呼び出し側のアプリケーションがフォーカスを持っていなくても、指定したアプリケーションをアクティブにします。

True呼び出し側のアプリケーションがフォーカスを持つまで待機し、指定したアプリケーションをアクティブにします。



 AppActivate ステートメントは、指定したアプリケーションやウィンドウにフォーカスを移します。
このとき、フォーカスが移っても指定したウィンドウの状態は変化しません。たとえば、最小化されているウィンドウにフォーカスを移しても、そのウィンドウは最小化されたままです。
ユーザーがフォーカスを変更するか、またはウィンドウを閉じると、他のウィンドウへフォーカスが移ります。
アプリケーションを実行するには、Shell 関数を使用します。また、ウィンドウ スタイルの設定をする場合にも Shell 関数を使用します。

 アプリケーション ウィンドウのタイトル バーの文字列と名前付き引数 title が完全に一致しているかどうかを比較することによって、どのアプリケーションをアクティブにするかが判別されます。
完全に一致するものが見つからないときは、アプリケーション ウィンドウのタイトル バーの文字列が名前付き引数 title で始まるアプリケーションをアクティブにします。
名前付き引数 title と一致するアプリケーション ウィンドウが複数ある場合も、その中の 1 つが任意に選択されてアクティブになります。

 AppActivate ステートメントの使用例
 次の例は、AppActivate ステートメントを使って、アプリケーション ウィンドウをアクティブにします。
アプリケーションの実行に Shell ステートメントを使っていますが、指定されたパスにアプリケーションの実行プログラムが保存されていなければ、アプリケーションを実行することはできません。

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 をアクティブにします。


 名前付き引数 とは、オブジェクト ライブラリにあらかじめ定義された名前を持つ引数。
名前付き引数を使用すると、構文どおりに指定された順序で各引数に値を指定しなくても、任意の順序で値を設定することができます。
たとえば、3 つの引数を取得できる次のようなメソッドがあるとします。
 DoSomeThing namedarg1, namedarg2, namedarg3
 名前付き引数を使うと、次のように引数を指定することができます。
DoSomeThing namedarg3 := 4, namedarg2 := 5, namedarg1 := 20
 名前付き引数は、構文の標準的な配置順序で指定する必要はありません。

この種類の目次に戻る↑ 索引へ↓ トップページに戻る


エージェント設定

 プロパティシート(設定ダイアログ)を開きます。

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

この種類の目次に戻る↑ 索引へ↓ トップページに戻る


音声応答ツール

 声が出にくいときに、使えるかなと思って、作ってみました。

 特長:
 お使いのパソコンに、合成音声が登録されていれば、男声・女声を、Excel 側で指定して発声させることができます。
 また、日本語・英語を自動判定します。

このExcelマクロをダウンロードできます。→ResponderVBA03.xls

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

この種類の目次に戻る↑ 索引へ↓ トップページに戻る




ホームページのトップに戻る