Excel VBAで女の子が褒めてくれるタスク管理システムをつくった話

はじめに
VBAで音声を再生する
VBAで画像を表示する
VBAでシート内の画像をすべて消す
おわりに
音声と画像の参照元

はじめに

先日、Excel VBAでモーニングルーティンの手順書、もといタスク管理システムをつくりました。
platon.hatenablog.jp

その文末で、次のように書いています。

将来的には、チェックボックスにチェックを入れたら好きなキャラクターの画像が表示されるとともに、キャラクターが褒めてくれる音声を再生するような機能を実装したいと思っています。

あれから色々と調べ、何とか形にすることができました。
youtu.be

試行錯誤の記録として、ブログにも書いておこうと思います。
タスク管理表をつくるところまでは前回の記事に詳しく書いているので、よろしければそちらもご覧くださいませ。

VBAで音声を再生する

まず音声の再生ですが、これは「mciSendString」というコマンドを使用します。
冒頭のmciは「Media Control Interface」の略であり、このAPIによってファイルの形式によらず再生することが可能になるようです。
「SendString」はそのまま「文字列の送信」を表し、文字列で命令を送るよ、くらいの意味です。

また1つの音声だけだったり、音声が流れる順番がいつも一緒だと飽きてしまうので、Rnd関数で乱数を発生させることでランダムな音声が流れるようにしました。
方法として、Diceという変数を整数型で定義、範囲を1～7までの整数とし、発生した1～7までの乱数にそれぞれ7つのファイルの場所及びファイル名を指定する文字列を対応させました。
その後、音声を再生するmciSendStringのPlayコマンドで、発生した乱数に対応した文字列=ファイル名を参照して音声が流れる仕組みにしています。

詳しくは後述のコードをご参照ください。

VBAで画像を表示する

次に画像を表示する方法です。

画像を表示させるには「ActiveSheet.Pictures.Insert(ファイルの場所と名前)」を使い、現在使用しているシートに指定した画像を挿入します。
画像の表示場所はTopやLeftで指定でき、表示範囲はWidthとHeightで調整できます。

こちらもランダム表示にするため、音声と同様まずDice_picという変数を1～9までの乱数としてから各々9つのファイルの場所及びファイル名を指定する文字列を対応させました。

実際のコードも載せておきます。
コピペする際は、「\---\」となっているファイルの場所とファイル名を適宜書き換えてご利用ください。

'サウンド再生用の儀式（定義文）
Private Declare PtrSafe Function mciSendString Lib "winmm.dll" Alias "mciSendStringA" _
(ByVal lpstrCommand As String, ByVal lpstrReturnString As String, _
ByVal uReturnLength As Long, ByVal hwndCallback As Long) As Long

Private Sub sound_Click()

'サウンド再生の準備
Dim Dice As Integer, Menu As String
'1から7までの整数で乱数を発生させる
Dice = Int(7 * Rnd + 1)
'乱数に応じて再生するファイルを変える
Select Case Dice
    Case Is = 1
        Menu = "C:\Users\---\excellent.mp3"
    Case Is = 2
        Menu = "C:\Users\---\ganbattane.mp3"
    Case Is = 3
        Menu = "C:\Users\---\good.mp3"
    Case Is = 4
        Menu = "C:\Users\---\goukakudesu.mp3"
    Case Is = 5
        Menu = "C:\Users\---\sugoisugoi.mp3"
    Case Is = 6
        Menu = "C:\Users\---\yokudekimashita.mp3"
    Case Is = 7
        Menu = "C:\Users\---\marvelous.mp3"
End Select
'サウンドを再生する
rc = mciSendString("Play " & Menu, "", 0, 0)

'画像表示の準備
Dim Dice_pic As Integer, Pic As String
'1から9までの整数で乱数を発生させる
Dice_pic = Int(9 * Rnd + 1)
'乱数に応じて表示する画像を変える
Select Case Dice_pic
    Case Is = 1
        Pic = "C:\Users\---\sugoi1_s2.jpg"
    Case Is = 2
        Pic = "C:\Users\---\sugoi2_s2.jpg"
    Case Is = 3
        Pic = "C:\Users\---\sugoi3_s2.jpg"
    Case Is = 4
        Pic = "C:\Users\---\sugoi4_s2.jpg"
    Case Is = 5
        Pic = "C:\Users\---\sugoi5_s2.jpg"
    Case Is = 6
        Pic = "C:\Users\---\sugoi6_s2.jpg"
    Case Is = 7
        Pic = "C:\Users\---\sugoi7_s2.jpg"
    Case Is = 8
        Pic = "C:\Users\---\sugoi8_s2.jpg"
    Case Is = 9
        Pic = "C:\Users\---\sugoi9_s2.jpg"
End Select

'画像の表示位置と大きさを指定
'H2のセルを左上とし、幅はH2からK2、高さはH2からH12までにする
    With ActiveSheet.Pictures.Insert(Pic)
        .Top = Range("H2").Top
        .Left = Range("H2").Left
        With ActiveSheet.Shapes
            .item(.Count).LockAspectRatio = msoFalse
        End With
        .Width = Range("H2:K2").Width
        .Height = Range("H2:H12").Height
    End With

'時間の記録

XOffset = 3
YOffset = 0
On Error Resume Next
    If ActiveSheet.CheckBoxes(Application.Caller).Value = Checked Then
    Range(ActiveSheet.Shapes(Application.Caller).TopLeftCell.Address).Offset(YOffset, XOffset).Value = Now
    End If

End Sub

VBAでシート内の画像をすべて消す

これで画像は表示できるようになりましたが、繰り返し使う場合、このままでは次にファイルを開いた際にタスクを完了する前からすでに画像が表示されてしまい、プログラムによって機械的に褒められている感が強くなってしまいます。（実際そうなんですが）

毎回新鮮な気分で褒めてもらいたいので、画像を消しておきたいところです。
ファイルを保存せず閉じてもいいのですが、毎回保存するか聞かれるのもわずらわしいですし、修正を加えたりした場合はバージョン管理が面倒です。

せっかくチェックボックスのチェックをすべて消す機能を搭載しているので、ついでにシート内の画像を全て消す機能も追加しちゃいましょう。
範囲を指定してmyRngという変数に入れ、spという変数で指定した画像がmyRngの範囲内にあればそれをDeleteで消していき、For Eachで範囲内の画像が消えるまで繰り返します。

実際のコードは以下の通りです。
コピペする際は例によって例のごとく、適宜セルの範囲を調整してご利用ください。

Sub check_all()

'特定のボックスにチェックを入れたらすべてのチェックを入れる
If Range("A32").Value = True Then
    Range("A3:A30").Value = True

'特定のボックスからチェックを外したらすべてのチェックを外す
ElseIf Range("A32").Value = False Then
    Range("A3:A30").Value = False

    'Time列の削除
    Range("E3:E30").ClearContents

    'H2からK12の範囲内の画像を全て削除
    Dim myRng As Range
    Dim sp As Variant
    Set myRng = Range("H2:K12")
    For Each sp In ActiveSheet.Shapes
        If Not Intersect(Range(sp.TopLeftCell, sp.BottomRightCell), myRng) Is Nothing Then
        sp.Delete
        End If
    Next
    Set myRng = Nothing
  
End If
End Sub