Ebola777 & VB

已經有新的程式 BeepSong，點我進入文章

---

此方法是利用 API 控制電腦的 "蜂鳴器"

就是你一開機，電腦會叫兩聲或三聲的那個東西

要控制蜂鳴器發出聲音很簡單，只是鮮少有程式可以做到


其實，生活中常用的 Word 就有這種功能 (其實不一定要 Word, Excel, Powerpoint 都可以，在此以 Word 做示範)

底下是我很久以前在上電腦或電研課無聊時拿來玩的

老實說，發出聲音，沒什麼。要讓程式碼操控音樂，奏出一首音樂才是厲害！

程式碼如果哪邊有問題歡迎提出

(上課不要亂玩，小心到時候被拔蜂鳴器！)



要來奏出美妙的樂章了嗎?



(1) 打開 Word，在工具列上點右鍵選 Visual Basic

其實這種方法是利用 VBScript 來操作...



(2) 會冒出一個小視窗，請點有一個三角板與尺與筆的



(3) 按下後會再冒出一個視窗，點 有個框框有 abc 那個



(4) 一按下，會在原先滑鼠游標處新增一個元件 (文字方塊) 預設名稱會叫 TextBox1

請把大小調整一下，最好大一點，方便待會操作





(5) 滑鼠移到上面圖片的框框上點右鍵，選擇屬性

然後會有下面類似的框跳出來

把 MultiLine 設成 True

把 ScollBars 改成 2

(6) 請把滑鼠游標弄到下一行。 (可以先點 TextBox1 的右邊，然後按 Enter 一次)




(7) 再點一個灰色的圖片來新增元件(指令按鈕)，注意，元件從哪冒出來從剛調好的滑鼠游標處




(8) 新增完會有這個東西




(9) 請點上面圖片這個名稱是 CommandButton1 用滑鼠左鍵快點兩下，會有一個視窗冒出來如下




(10) 裡面會有兩行，請全部刪除，並貼上底下提供的程式碼 (請先看完待會再去底下複製程式碼)




(11) 把上面視窗關閉，回到 Word 主編輯畫面

把原先點下去的 那個三角板與尺與筆的點掉 (消除)

這樣元件才會離開編輯狀態而可以使用



 

(12) 在 TextBox1 (白色框框) 貼上歌譜後按下 CommandButton1 (那個底下灰色按鈕)

音樂開始演奏～ 如果中途要停止請再點一次即可





底下是我打的一些樂譜，格式是我設定的，

當然，如果你懂 VB/VBScript ，也可以自己設定

其實很多鋼琴都利用和弦及混音來演奏，BEEP 好像只能用一個

因此像是超級馬力 (有興趣去下載 OVE 的7首)，會發現幾乎都用和弦，因此此處只用單聲而已

另外音頻的配合鋼琴如何轉換請參考知識+ 搜尋 "Do Re Mi 音頻"，基本上就是以 La 為標準的2乘以 (X除以12次方)



格式：


(1)採用簡單符號
(2)用 / 來分隔每個單元(元素)
(3)數字為 兩碼，前碼為音階，後碼為音符，最後加 + 符號代表升調 (沒有 - 的)
(4)可用 @ 來做記號，程式碼演奏時會略過
(5)重複部份可用 #/ 符號加上重複次數 X 加上 / 加上片段群組加上 /!# 代表結尾
(6)事先宣告在最前端宣告 [STR] 名稱加上群組片段以 ; 符號代表結尾
(7)迴圈設計只有一層，並無外迴圈設計，請勿把兩個重複片段插入另外一個
(8)利用宣告部份用 %STR  代表使用預先宣告的片段，前後同樣以 / 和 / 來夾住，如果 %後面有多一個&代表同樣的一個音階項目可對應不同的長度項目 (一對全多)
(9)總共分上行與下行，此處兩個間距必須大於等於兩個換行符號(VbCrLf) (Chr(10) + Chr(13))
(10)上行為音階，是鋼琴的 Do, Re, Mi. 下行為長度，代表某個音階項目的演奏長度
(11)上行一般項目可用 1~7, + 代表鋼琴鍵盤的 Do~Si
(12)下行用 d, s, c, x, n    d 為 Dot 長度極短，s 為一般長度，c 較長仍有斷掉，x 為連續，n 為無聲，一個 n 必須對應音階符號 0。英文符號後接上長度，位元不限
(13)遇到 * 加上數字代表全部的音階層移位，例如其中一個元素 *1 代表升八度 *-1 代表降八度

 ===================== 歌譜 ，複製請把兩區塊一起複製 (匹客幫有點爛，有些很長的字會被版面壓住，就直接多行選取把它複製就可以看的到...) =======================

------------------

附註：有時候換行符號會穿插其中，如無法撥放請把隔一行的分行符號刪除

 

[生日快樂歌曲]

$2/1/1/2/1/4/3@/1/1/2/1/5/4@/1/1/$n/31/$2/6/4/3/2/0@/6+/6+/6/4/5/4@/

c4/c4/c8/c8/c8/c15@/c4/c4/c8/c8/c8/c15@/c4/c4/c8/c8/c8/c8/c15/n1@/c4/c4/c8/c8/c8/c18@/

[凍凍果] total Break = 6

$2/1/2/1/@0/1/2/1/@6/6/4/@0/5/4/5/6/6+/6+/5/5/@0/$n/26/31/$2/6/4/2/4/6+/@6/5/6/6+/$n/31/31/24@/

s4/s2/s2/n1/s4/s2/s2/s5/s5/x6/n2/x3/x2/x2/x2/s4/s4/x7/x7/c4/c4/c4/c4/s4/s5/c4/c8/c3/x2/x2/x2/s4/s4/x10@/

[超級馬莉普通關曲 LOOP] total Break = 47

$2/3/3/3@/1/3/5@/$n/0/15@/0/21/0/15/0/13@/16/17/0/16/15+/15@/$2/4/5/6/0@/4/5@/3/0/1/2/$n/17@/21/0/15/0/13@/16/17/0/16/15+/15@/$2/4/5/6/0@/4/5@/3/0/1/2/$n/17@/0/$2/4+/4/3/0/1/2/0/1/0/1@/$n/16/21/22@/0/$2/4+/4/3/0/1/2@/6/6/0/6/0@/$2/4+/4/3/0/1/2/0/1/0/1@/$n/16/21/22/0@/22+/0/22/0/21/0@/$2/1/1/0/1/0/2/3/1/$1/0/6/5/0@/$2/1/1/0/1/0/2/3/0@/1/1/0/1/0/2/3/1/$1/0/6/5/0@/

c2/s5/s4@/s2/s4/x5@/n3/x7@/n3/c4/n2/c4/n2/c6@/c3/c2/n1/s4/s3/s4@/s2/s2/c3/n1@/d2/s4@/s2/n1/s2/d4/s4@/c4/n2/c4/n2/c6@/c3/c2/n1/s4/s3/s4@/s2/s2/c3/n1@/d2/s4@/s2/n1/s2/d4/s4@/n5/c2/c2/s3/n1/c2/s3/n1/s3/n1/s4@/c2/c2/s4@/n4/c2/c2/s3/n1/c2/s4@/s4/x3/n1/s5/n5@/c2/c2/s3/n1/c2/s3/n1/s3/n1/s4@/c2/c2/s4/n3@/s4/n3/s4/n1/s6/n6@/c2/c2/n2/c2/n2/s3/c2/s3/n1/c2/c4/n3@/c2/c2/n2/c2/n2/s4/c7/n6@/c2/c2/n2/c2/n2/s3/c2/s3/n1/c2/c4/n2@/

[楓之谷魔法森林] - (這我只有做一小段而已)

$3/4/1/2/$2/6+/6/6+/5/6/6+/$3/1/2/2+/$n/26/34/32/32+/26+/31/26+/26+/26/26+/31/32/26+/31/32+/32/26/25/26/26+/24/25/26@/26+/26+/25/26/26+/$3/1/2+/1/$2/6+5/6/6+/4/5/6/6+/$3/2/1/$2//#/7/6+/!#//$3/

[N]c4/c2;/#/100/%N/!#//

[卡農]

11/25/31/33/15/25/27/32/16/23/26/31/13/23/25/27/14/21/24/26/11/21/23/25/14/22/24/26/15/22/25/27@/31/27/31/21/17/25/22/23/21/31/27/26/27/$3/3/5/6/4/3/2/4/3/2/1/$2/7/6/5/4/3/2/4/3/2/1/2/3/4/5/2/5/4/3/6/5/4/5/4/3/2/1/$n/16/26/27/31/27/26/25/24/23/22/26/25/26/25/24@/23/$3/3/4/5/3/4/5/$2/5/6/7/$3/1/2/3/4/3/1/2/3/$2/3/4/5/6/5/4/5/3/4/5/4@/6/5/4/3/2/3/2/1/2/3/4/5/4/6/5/6@/$n/27/31/25/26/27/$3/1/2/3/4/5/3/1/2/3@/$n/32/31/32/27/31/32/33/32/31/27/31@/26/27/31/$2/1/2/3/4/3/2/3/$n/31/27/31/26@/31/27/26/$2/5/4/5/4/3/4/5/6/7/$n/31/26/31/27/31@/27/26/27/31/32/31/27/31/26/27/31@@/33/33/33/34/33/32/31/0/31/31/32/31/27/26/0@/31/31/0@/25/31/26+/26/26+/25/0@/25/35/0@/$3/5/5/6/5/4/3/0/3/3/4/3/2/1/$2/6+/6/6+/5/0@/5/4/$n/31/27/31/27/31/31/0@/$1/1/3/5/$2/1/3/5/$3/1/3/5/$4/1/3/5/$5/1@/

[N]c3/s3/s3/s3;[F]s3;[R]s2;/#/8/%&N/!#@//#/64/%&F/!#@/s3/s2/s2/s3//#/9/s2/!#//s2/s4/s2/s2/s4//#/10/s2/!#//s4@/s2/s2/s4//#/8/s2/!#//s4/s4/s2/s2/s4@//#/9/s2/!#//s4/s4/s2/s2/s4@//#/10/s2/!#//s4@/s2/s2/s4//#/10/s2/!#//s4@/s2/s2/s4//#/10/s2/!#//s4/s2/s2/s4@/#/10/s2/!#/s8@@/c6//#/2/s4/c4/c4/c4/c4/c12/n1/!#//@/s4/c12/n1@/s4/c4/c4/c4/c4/s12/n1@/s4/c12/n1@/s4/c4/c4/c4/c4/c12/n1/s4//#/8/c4/!#//c12/n1@/s4/c12/c6/c1/c1/c12/s4/c16/n1@//#/4/c1/c1/c1/!#//c14@/

  


============================ VBScript 程式碼 =================================

Option Explicit

Private Declare Function Beep Lib "kernel32" (ByVal dwFreq As Long, ByVal dwDuration As Long) As Long

Dim IfRunning As Boolean
Dim StopCMD As Boolean

Private Sub CommandButton1_Click()

Dim tempS As String
Dim Arr() As String
Dim i As Long
Dim j As Long

Dim S1 As String
Dim S2 As String

On Error GoTo Err1

tempS = TextBox1.Text  'Clipboard.GetText

tempS = Replace(tempS, vbCrLf & vbCrLf & vbCrLf, vbCrLf & vbCrLf)
tempS = Replace(tempS, vbTab, "")

Arr() = Split(tempS, vbCrLf & vbCrLf)

i = 0
For j = 1 To 2

Do While Arr(i) = ""
  i = i + 1
Loop
  If j = 1 Then
    S1 = KillCrLf(Arr(i))
  Else
    S2 = KillCrLf(Arr(i))
  End If

i = i + 1

Next j

If S1 <> "" And S2 <> "" Then StartBeeping S1, S2, ""

Exit Sub
Err1:

End Sub

Public Sub StartBeeping(ByVal sd_freq As String, ByVal sd_lng As String, ByVal StartM As String)

 
  If IfRunning Then StopCMD = True: IfRunning = False: Exit Sub

IfRunning = True
StopCMD = False

Dim i As Long
Dim j As Long
Dim m As Long
Dim m2 As Long
Dim k As Long
Dim K1 As String
Dim K2 As String
Dim tempK As String
Dim tempV As Double
Dim tempS As String
Dim tempType As Integer

Dim Def_floor As String
Dim Def_floor2 As String
Dim Def_Loop As Long
Dim Def_Loop_S As String
Dim Def_Grp As String
Dim Def_Grp2 As String
Dim ArrGrp() As String
Dim ArrGrp2() As String
Dim tempGrp As String
Dim tempGrp2 As String
Dim Conti As Boolean
Dim AttainFloor As Long

Dim Arr1BindCount As Long
Dim Arr2BindCount As Long

Const NoneFreq = 25000

Const LNs = 20
Const LN1 = 30
Const LN2 = 60
Const LN_Total = 120
Const sma = 0.6
Const AdditFloor = 1

Dim Arr() As String
Dim Arr2() As String

  On Error GoTo Err1

Def_Loop = -1

  If StartM <> "" Then
    m = 0
    m2 = 0
    For i = 1 To Val(StartM)
      m = InStr(m + 1, sd_freq, "@")
      m2 = InStr(m2 + 1, sd_lng, "@")
    Next i
   
      sd_freq = Right(sd_freq, Len(sd_freq) - m + 1)
      sd_lng = Right(sd_lng, Len(sd_lng) - m2 + 1)
   
  End If

sd_freq = Replace(sd_freq, "@", "")
sd_lng = Replace(sd_lng, "@", "")

sd_freq = killHE(sd_freq)
sd_lng = killHE(sd_lng)

'------- Rep -----------

sd_freq = AddRep(sd_freq)
sd_lng = AddRep(sd_lng)

Def_Grp = AddGrp(sd_freq)
Def_Grp2 = AddGrp(sd_lng)

ArrGrp = Split(Def_Grp, vbCr)
ArrGrp2 = Split(Def_Grp2, vbCr)

sd_freq = killHE(sd_freq)
sd_lng = killHE(sd_lng)

Arr = Split(sd_freq, "/")
Arr2 = Split(sd_lng, "/")

AttainFloor = 0

j = 0
For i = 0 To UBound(Arr)

  K1 = Arr(i)
   
    If K1 = "" Then GoTo NextLoop1
 
ReStart:

  If killHE(tempGrp) <> "" Then
    m = InStr(1, tempGrp, "/")
      If m = 0 Then m = Len(tempGrp) + 1
    K1 = Left(tempGrp, m - 1)
      If Len(tempGrp) - m > 0 Then
        tempGrp = Right(tempGrp, Len(tempGrp) - m)
      Else
        tempGrp = ""
      End If
  End If

    If Left(K1, 1) = "*" Then
      AttainFloor = Right(K1, Len(K1) - 1)
      GoTo NextLoop1
    End If

   
    If Left(K1, 1) = "$" Then
      Def_floor = Right(K1, Len(K1) - 1)
      Arr1BindCount = Arr1BindCount + 1
      If Def_floor <> "n" Then GoTo NextLoop1
    End If
   
    If Left(K1, 1) = "%" Then
      tempS = UCase(Right(K1, Len(K1) - 1))
     
        For k = 0 To UBound(ArrGrp)
          If ArrGrp(k) = "%" & tempS & "%" Then
           tempGrp = killHE(ArrGrp(k + 1))
           GoTo ReStart
          End If
        Next k
     
    End If
   
   
  If Def_floor = "n" Then
    Def_floor = ""
    i = i + 1
    K1 = Arr(i)
  End If

 
  'If i > UBound(Arr2) + Arr1BindCount Then
    K2 = "s5" 'Default
  'Else
    If j > UBound(Arr2) Then
      K2 = "s5"
    Else
      K2 = Arr2(j)
    End If
  'End If
 
    If K2 = "" Then j = j + 1: GoTo NextLoop1

ReStart2:

  If killHE(tempGrp2) <> "" Then
     
    m = InStr(1, tempGrp2, "/")
      If m = 0 Then m = Len(tempGrp2) + 1
    K2 = Left(tempGrp2, m - 1)
      If Len(tempGrp2) - m > 0 Then
        tempGrp2 = Right(tempGrp2, Len(tempGrp2) - m)
       
        If Not Conti Then i = i - 1
        j = j - 1
      Else
        tempGrp2 = ""
      End If
  End If

    If Left(K2, 1) = "%" Then
      tempS = UCase(Right(K2, Len(K2) - 1))
     
      If Left(tempS, 1) = "&" Then
        Conti = True
        tempS = Right(tempS, Len(tempS) - 1)
      Else
        Conti = False
      End If
     
        For k = 0 To UBound(ArrGrp2)
          If ArrGrp2(k) = "%" & tempS & "%" Then
           tempGrp2 = ArrGrp2(k + 1)
           GoTo ReStart2
          End If
        Next k
     
    End If

  'K1
  '11/12/13/14/15/16/17
  'K2
  'd1/d2/d3/s1/s2/s3/c1/c2/c3/s

    If Def_floor <> "" Then
      tempK = Val(Def_floor)
    Else
      tempK = Left(K1, 1)
    End If
   
  If K1 <> "" Then
    If Def_floor <> "" Then
      K1 = K1
    Else
      K1 = Right(K1, Len(K1) - 1)
    End If
  End If
 
  Select Case K1
  Case "1"
    tempS = "C"
  Case "1+"
    tempS = "C#"
  Case "2"
    tempS = "D"
  Case "2+"
    tempS = "D#"
  Case "3"
    tempS = "E"
  Case "4"
    tempS = "F"
  Case "4+"
    tempS = "F#"
  Case "5"
    tempS = "G"
  Case "5+"
    tempS = "G#"
  Case "6"
    tempS = "A"
  Case "6+"
    tempS = "A#"
  Case "7"
    tempS = "B"
  End Select
 
      tempV = Cg_To_Freq(tempS, AdditFloor + AttainFloor + tempK)
     
    tempK = Left(K2, 1)
    If K2 <> "" Then K2 = Right(K2, Len(K2) - 1)
   
      If K2 = "n" Then K2 = "1"
   
    Select Case LCase(tempK)
    Case "s" 'Stop Dot (Normal)
      Beep tempV, (LN2) * K2 * sma
      Beep NoneFreq, (LN_Total - LN2) * K2 * sma
    Case "d" 'Dot, Dot
      Beep tempV, (LN1) * K2 * sma
      Beep NoneFreq, (LN_Total - LN1) * K2 * sma
    Case "c" 'Continuous + Break
      Beep tempV, (LN_Total - LNs) * K2 * sma
      Beep NoneFreq, (LNs) * K2 * sma
    Case "x" 'Continuous
      Beep tempV, LN_Total * K2 * sma
    Case "n" 'Stop >>> NO Sound
      Beep NoneFreq, (LN_Total) * K2 * sma
    End Select

If LCase(tempK) <> "x" Then DoEvents

 j = j + 1

NextLoop1:

    If StopCMD Then StopCMD = False: Exit For

 
  If killHE(tempGrp) <> "" Then GoTo ReStart
 
Next i

StopCMD = False
IfRunning = False

Exit Sub
Err1:

  MsgBox "Beep Function Error : " & vbCrLf & vbCrLf & "i=" & i & vbCrLf & "K1=" & K1 & vbCrLf & "K2=" & K2 & vbCrLf & vbCrLf & _
  "sd_freq=" & sd_freq & vbCrLf & "sd_lng=" & sd_lng & vbCrLf & vbCrLf & "* Freq-String : 1~7(+), Pre-define: $[Floor]" & vbCrLf & _
  "* Lng-String : s,d,c,x,n + [lng]" & vbCrLf & "* All Units Have To Be Separated By ""/"", when lng-str is ""n"", freq-str must be ""0""" & _
   vbCrLf, vbExclamation, "Beep Notice"

StopCMD = False
IfRunning = False

End Sub

Public Function Cg_To_Freq(ByVal S As String, ByVal f As String) As Double

'S >>> CDEFGAB ...
'C, C#, D, D#, E, F, F#, G, G#, A, A#, B
'f >>> 110,220,440 ...

Dim BaseFreq As Double
Dim tempV As Long

BaseFreq = (110 * (2 ^ (Val(f) - 1)))  '#La

Select Case S
Case "C"
  tempV = -9
Case "C#"
  tempV = -8
Case "D"
  tempV = -7
Case "D#"
  tempV = -6
Case "E"
  tempV = -5
Case "F"
  tempV = -4
Case "F#"
  tempV = -3
Case "G"
  tempV = -2
Case "G#"
  tempV = -1
Case "A"
  tempV = 0
Case "A#"
  tempV = 1
Case "B"
  tempV = 2
End Select

Cg_To_Freq = BaseFreq * (2 ^ ((tempV) / 12))

End Function

Public Function killHE(ByVal S As String) As String

If Left(S, 1) = "/" Then S = Right(S, Len(S) - 1)
If Right(S, 1) = "/" Then S = Left(S, Len(S) - 1)

S = Replace(S, " ", "")
S = Replace(S, "//", "/")

killHE = S

End Function

Public Function KillCrLf(ByVal S As String) As String

  S = Trim(S)

Do While Left(S, 2) = vbCrLf
S = Right(S, Len(S) - 2)
Loop

Do While Right(S, 2) = vbCrLf
S = Left(S, Len(S) - 2)
Loop

  KillCrLf = S

End Function

Public Function AddTer(ByVal S As String) As String

If Left(S, 1) = "/" Then S = Right(S, Len(S) - 1)
If Right(S, 1) <> "/" Then S = S & "/"

AddTer = S

End Function

Public Function AddRep(ByVal S As String) As String

Dim m As Long
Dim m2 As Long
Dim tempS As String
Dim tempS2 As String
Dim totalS As String
Dim i As Long
Dim j As Long
Dim k As Long
Dim OriLng As Long

m = 1
Do
 
 m = InStr(m, S, "#/")
  
   If m <> 0 Then
    
     m2 = InStr(m + 2, S, "/!#")
    
     If m2 <> 0 Then
      
       j = InStr(m + 2, S, "/")
         If j <> 0 Then k = Mid(S, m + 2, j - m - 2)
         tempS = AddTer(Mid(S, j + 1, m2 - j - 1))
       
        totalS = ""
        For i = 1 To k
          totalS = totalS & tempS
        Next i
       
          OriLng = Len(S)
         
          If Len(S) - m2 - 3 > 0 Then
            tempS2 = killHE(Right(S, Len(S) - m2 - 3))
          Else
            tempS2 = ""
          End If
         
        S = killHE(Left(S, m - 1)) & "/" & totalS & tempS2

       
     End If
    
   Else
     Exit Do
   End If
 
 m = m2 + 2 + Len(S) - OriLng

Loop

  AddRep = S

End Function

Public Function AddGrp(ByRef S As String) As String

Dim m As Long, m2 As Long
Dim tempS As String

'%TEST% 12/13/14 %MORE% s1/s2/s3

AddGrp = ""

Do

  m = InStr(1, S, "[")
  If m <> 0 Then
    m2 = InStr(m, S, "]")
    If m2 <> 0 Then
      tempS = Mid(S, m + 1, m2 - m - 1)
      tempS = Replace(tempS, "%", "")
     
      AddGrp = AddGrp & "%" & UCase(tempS) & "%" & vbCr
     
        m = InStr(m2, S, ";")
        If m <> 0 Then tempS = Mid(S, m2 + 1, m - m2 - 1)
       
         AddGrp = AddGrp & tempS & vbCr
     
      S = Right(S, Len(S) - m)
     
    End If
  Else
    Exit Do
  End If

Loop

End Function