Excel VBAのBeep音で簡単なメロディを鳴らす

　Excel VBAのBeep音とドレミファソラシドと言う記事を書きました。それならば、簡単なメロディーもならせるなと思ったので、作りました。
　ピアノなら左端の一番低い「ラ」を「A0」として、「ラ,ラ#,シ,ド,ド#,レ…」を「A0,A#0,B0,C1,C#1,D1,…」と呼ぶようなので、それを使って音程を指定します。
　音の長さは、８分音符の長さを1として、４分音符なら2、２分音符なら4と指定します。さらにその1の長さが何ミリ秒なのかも指定します。
　そういうデータを作ってプロシジャー（BeepSound）に渡すと、どうにかこうにかビープ音でメロディが鳴らせます。単音です。和音はできません。コードの説明は省きます。すいません。
　以下のtestTraumerei()を実行すると、「トロイメライ」の最初の４小節がビープ音で鳴ります。
　ご興味のある方、お時間のある方はお試しください。なお、最初はパソコンの音量を小さくしてください。

Public Declare Function Beep Lib "kernel32.dll" (ByVal dwFreq As Long, ByVal dwDuration As Long) As Long

Public Sub testTraumerei()
'音階データ
'低いドは「C1」,そこそこのソ＃は「G#4」。 または、ド1,ソ#4などと音階を指定。
'シャープは、「＃」,「#」 フラットは「♭」,「b」
Const scl = "C4,F4,E4,F4,A4,C5,F5,F5,E5,D5,C5,F5,G4,A4,Bb4,D5,F4,G4,A4,C5,G4"
'音長データ
'音階に対応させて、音の長さを指定。
'８分音符を1として、長さを指定。２分音符なら4。
Const dur = " 2, 3, 1, 1, 1, 1, 1, 4, 1, 1, 1, 1, 1, 1,  1, 1, 1, 1, 1, 1, 5"
'８分音符を1とした時のミリ秒数
Const rate = 300
BeepSound scl, dur, rate
End Sub

Public Sub BeepSound(scl As String, dur As String, rate As Double)
    Dim s As Variant
    Dim d As Variant
    s = Split(scl, ",")
    d = Split(dur, ",")
    Dim i As Long
    Dim f As Double
    For i = 0 To UBound(s)
        f = CalcFreq(CStr(s(i)))
        Debug.Print s(i), f
        Beep f, CDbl(d(i)) * rate
        DoEvents
    Next
End Sub

Private Function CalcFreq(ScaleName As String) As Double
Const BaseF = 32.70319564 '基準音階C1の周波数
Dim ABC As String
Dim SF As String
Dim OCT As String
Dim scl As String
scl = ScaleName

If Len(scl) >= 2 And Len(scl) <= 3 Then
    ABC = Ra2A(Left(scl, 1))
    OCT = StrConv(Right(scl, 1), vbNarrow)
    If Len(scl) = 3 Then
        SF = Mid(scl, 2, 1)
    End If
    
    'ドレミファの乗数
    Dim kABC As Long
    kABC = InStr(1, "C.D.EF.G.A.B", ABC) - 1
    
    'シャープ、フラットの乗数
    Dim kSF As Long
    If SF = "#" Or SF = "＃" Then
        kSF = 1
    ElseIf SF = "b" Or SF = "♭" Then
        kSF = -1
    Else
        kSF = 0
    End If
    
    'オクターブの乗数
    Dim kOCT As Long
    kOCT = 12 * (CDbl(OCT) - 1)
    
    Dim k As Long '基準音階C1からの総合乗数
    k = kABC + kSF + kOCT
    
    Dim freq As Double '音階の周波数
    freq = BaseF * (2 ^ (1 / 12)) ^ k
    CalcFreq = freq
Else
    CalcFreq = 0
End If
End Function

'カナ音階をアルファベットに変換
Private Function Ra2A(s As String) As String
Const DoReMiFa = "ド,レ,ミ,ファ,ソ,ラ,シ"
Const ABCD = "C,D,E,F,G,A,B"
Dim ret As String
ret = ""
If InStr(1, ABCD, s) > 0 Then
    ret = s
ElseIf InStr(1, DoReMiFa, s) > 0 Then
    Dim d As Variant
    Dim A As Variant
    d = Split(DoReMiFa, ",")
    A = Split(ABCD, ",")
    Dim i As Long
    For i = 0 To UBound(d)
        If d(i) = s Then
            ret = A(i)
            Exit For
        End If
    Next
End If
Ra2A = ret
End Function

参考：音階の周波数、https://tomari.org/main/java/oto.html、2022.4.11閲覧

#Excel , #VBA , #Beep音 , #トロイメライ