Visual Basic for Applications/VBA 中可變蜂鳴聲
此 VBA 程式碼模組檢查了 Beep() API 的各種用途。其引數為頻率和持續時間。它沒有等待引數，因此無法產生和絃，只能產生單音。據稱該程式碼在 Windows 7 及更高版本中執行良好，但在更早版本中可能會忽略引數。除了摩爾斯電碼文字傳送器外，還演示了簡單的音樂音階和旋律。.
過去，在使用 Beep API 時發現了許多問題。從 Windows 7 開始，微軟對 Beep API 進行了重新編碼，使其能夠與計算機音效卡一起工作。在 Windows 7 之前，API 只能與內建音效卡一起工作。不幸的是，在從音效卡到音效卡的過渡過程中，一些計算機制造商仍然使用音效卡，而另一些製造商則使用音效卡。這是舊版 Windows 版本出現問題的根源。在使用最新版本的 Beep API 時，不應該遇到任何問題。
模組中提供了幾個過程。將整個程式碼複製到標準模組中進行測試。過程如下
- Beeper() 是函式的基本形式。 執行它將在計算機的揚聲器中發出簡單的音調。注意，它不涉及 Windows 中內建的警報器，而是用於收聽媒體的揚聲器。聲音的頻率和持續時間都可以調整，雖然輸出的一致性，設計用於選擇的頻率使用，不是很好。
- TestNotes() 擴充套件了基本格式。 執行此程式將產生向上和向下的音階。有兩種方法可以訪問頻率
- 第一個方法是簡單地輸入每個音符的精確頻率，以一系列程式碼行表示； 這就是do re me 音階的情況，即所謂的自然音，例如，C,D,E,F,G,A,B,C...。
- 另一個方法，當精確頻率未知時，是使用公式根據音符相對於參考點的相對位置來計算頻率。（參見圖 1 和 2）。本例中的參考點是音符 A = 440 Hz。圖 1 顯示了圍繞 440Hz 的三個八度音階，圖 2 顯示了簡譜中的音符如何與音符距離相關。音符距離值可用於計算任何其他音符的頻率。例如，在圖 2 中，請注意G 音符的距離為10；此距離以及所有其他音符距離都列在圖 1 的表格中。當了解G 音符始終佔據高音譜號的第二行時，可以使用音符和距離來標記簡譜，以便於編碼。
- SendMorse() 發出引數字串的摩爾斯電碼。 該過程提供基本的輸出，頻率 (Hz) 和點長 (毫秒) 可調。
- 延時使用Delay() 來實現元素間 (一個點)、字元間 (三個點) 和單詞間 (七個點) 間隔，此外還有點和劃的 1:3 比例。所有時間都來自一個短點元素的長度。可以在 Random() 中為所有時間新增隨機元素，其中可以設定最大誤差百分比；據說這更像人手而不是過於完美的程式。
- 慣例是用每分鐘字數 來估計點持續時間，T = 1200 / W，其中T 是點持續時間（毫秒），W 是生成的每分鐘字數。國際摩爾斯電碼作為參考在圖 3 中給出。
- 2018 年 12 月 24 日修改，為 SendMorse() 中的所有時間新增隨機性
- 2018 年 12 月 24 日修改，在 SendMorse() 中添加了省略的 sCode 宣告
- 2018 年 12 月 23 日修改，更正了 SendMorse() 陣列 vSN 中的資料
- 2018 年 12 月 22 日修改，展示了在曲調中使用音符距離。
- 2018 年 12 月 21 日修改，更正了摩爾斯電碼過程的時間錯誤。
執行TestBeeper()、TestNotes() 或 testSendMorse() 以執行各種過程。
Option Explicit
Public Declare PtrSafe Function BeepAPI Lib "kernel32" Alias "Beep" _
(ByVal Frequency As Long, ByVal Milliseconds As Long) As Long
Sub TestBeeper()
'run this to test beeper
Dim nFreq As Long, nDur As Long
nFreq = 800 'frequency (Hertz)
nDur = 500 'duration (milliseconds)
'call beeper function
Beeper nFreq, nDur
End Sub
Function Beeper(nF As Long, nD As Long) As Boolean
'makes a beep sound of selected frequency and duration
'This works for NT/2000/XP and beyond.
'Before that, frequency and duration ignored.
BeepAPI nF, nD
Beeper = True
End Function
Sub TestNotes()
'music notes played using known frequencies and those
'calculated from knowlege of their relative positions'
Dim vAN As Variant, vOTJ As Variant, vOTJD As Variant
Dim i As Long, nFreq As Long
Dim nDur As Long, nLen As Long
'sets the basic note duration
nDur = 500
'store the specific frequencies in array - zero based...
'these frequencies are for do,re,me,fa,so,la,te,do based on middle C =261.63Hz (262)
'CDEFGABC
vAN = Array(262, 294, 330, 349, 392, 440, 494, 523)
'or store a jingle in note difference notation. Ode To Joy on beeper.
vOTJ = Array(7, 7, 8, 10, 10, 8, 7, 5, 3, 3, 5, 7, 7, 5, 5) 'note positions from 440Hz
vOTJD = Array(1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 2) 'durations
'scales up
'CDEFGABC
'do re me fa so la te do
For i = 0 To 7
nFreq = vAN(i)
BeepAPI nFreq, nDur
Next i
Delay 1000 'delay one second
'scales down
'CBAGFEDC
'do te la so fa me re do
For i = 7 To 0 Step -1
nFreq = vAN(i)
BeepAPI nFreq, nDur
Next i
Delay 1000 'delay one second
'34 notes, naturals, sharps and flats
'played using note position from 440Hz
For i = -5 To 28
nFreq = CInt(440 * 2 ^ (i / 12))
BeepAPI nFreq, nDur
Next i
Delay 1000 'delay one second
'Ode to Joy - albeit crude, using note distance only
For i = 0 To 14
nFreq = CInt(440 * 2 ^ (vOTJ(i) / 12))
BeepAPI nFreq, 400 * vOTJD(i)
Next i
Delay 1000 'delay one second
'or use direct entries to make a custom sound
BeepAPI 262 * 2, 200
BeepAPI 494 * 2, 200
BeepAPI 494 * 2, 200
BeepAPI 262 * 2, 500
End Sub
Sub testSendMorse()
'run this to test the Morse code sender
'integers and simple alphabet only
Dim sIn As String
Dim start As Single, ends As Single
sIn = "The quick brown fox jumps over the lazy dog 0123456789 times"
'start = Timer
SendMorse sIn, 440, 120 'string,freq (Hz),dot length (mS)
'ends = Timer - start
'MsgBox ends
End Sub
Sub SendMorse(ByVal sIn As String, nUF As Single, nUL As Single)
'Sounds out Morse code for input string sIn
'Parmeters frequency(Hz) and dot length(mS)
Dim vSL As Variant, vSN As Variant, vM As Variant
Dim i As Long, j As Long, nAsc As Integer
Dim sWord As String, sCode As String
'check that there is a decent string input
If Trim(sIn) = "" Then
MsgBox "Illegal characters in input string - closing"
Exit Sub
End If
'load letter array with morse code- 1 for dot and 3 for dah
vSL = Array("13", "3111", "3131", "311", "1", "1131", "331", "1111", "11", _
"1333", "313", "1311", "33", "31", "333", "1331", "3313", "131", _
"111", "3", "113", "1113", "133", "3113", "3133", "3311") 'a,b,c,...z
'load number array with morse code- 1 for dot and 3 for dah
vSN = Array("33333", "13333", "11333", "11133", "11113", _
"11111", "31111", "33111", "33311", "33331") '0,1,2,...9
'split the input string into words
vM = Split(Trim(sIn), " ") 'zero based
For i = LBound(vM) To UBound(vM) 'step through words
'get one word at a time
sWord = LCase(vM(i)) 'current word
'get one chara at a time
For j = 1 To Len(sWord)
'look up chara asci code
nAsc = Asc(Mid(sWord, j, 1))
'get morse sequence from array
Select Case nAsc
Case 97 To 122 'a letter
sCode = vSL(nAsc - 97)
MakeBeeps sCode, nUL, nUF
If j <> Len(sWord) Then
Delay (nUL * 3) 'add 3 spaces between letters
End If
Case 48 To 57 'an integer
sCode = vSN(nAsc - 48)
MakeBeeps sCode, nUL, nUF
If j <> Len(sWord) Then
Delay (nUL * 3) 'add 3 spaces between letters
End If
Case Else
MsgBox "Illegal character in input" & vbCrLf & _
"Only A-Z and 0-9 permitted."
End Select
Next j
If i <> UBound(vM) Then Delay (nUL * 7) 'add 7 spaces between words
Next i
End Sub
Function MakeBeeps(ByVal sIn As String, ByVal nUL As Single, ByVal nUF As Single) As Boolean
'makes beep sounds for one character based on coded input string
Dim i As Long, j As Long, nLen As Long
Dim nT As Single, nE As Single
For i = 1 To Len(sIn)
'get character element
nLen = CInt(Mid(sIn, i, 1))
Select Case nLen
Case 1
BeepAPI nUF, nUL + Random(nUL)
If i <> Len(sIn) Then Delay nUL
Case 3
BeepAPI nUF, (3 * nUL) + Random(3 * nUL)
If i <> Len(sIn) Then Delay nUL
Case Else
MsgBox "error"
End Select
Next i
MakeBeeps = True
End Function
Function Random(nDot As Single) As Single
'adds a random variation to the timing
'used to better hide machine code signature
'nRand = Int((upperbound - lowerbound + 1) * Rnd + lowerbound)
Dim nRand As Long, nPercent As Single
Dim nU As Long, nL As Long
'set a number here for max error percentage
'eg; 10 for ten percent error, 0 for none.
nPercent = 10 'max percent plus and minus
'initialize the random generator
Randomize
'generate small random number as the timing error
nRand = Int((nDot * nPercent / 100 + nDot * nPercent / 100 + 1) * Rnd - nDot * nPercent / 100)
Random = nRand
End Function
Sub Delay(nD As Single)
'delays for nD milliseconds
'randomness set in Random()
Dim start As Single
nD = nD + Random(nD) 'add randomness to intention
start = Timer ' Set start time.
Do While Timer < start + nD / 1000
DoEvents ' Yield to other processes.
Loop
End Sub