Авторские программы, библиотеки, надстройки и шаблоны

'Процедура Qb_PLAY проигрывает музыку из символьных строк стандарта АВС
'аналогично оператору QBASIC PLAY
'http//ru.wikipedia.org/wiki/ABC_(%D0%BD%D0%BE%D1%82%D0%BD%D0%B0%D1%8F_%D0%B7%D0%B0%D0%BF%D0%B8%D1%81%D1%8C)
Option Explicit
Private Declare Function Beep Lib "kernel32" (ByVal dwFreq As Long, ByVal dwDuration As Long) As Long
Private Declare Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As Long)
Private freq%(0 To 6, 0 To 11)
Dim freq_Flag As Boolean
 
Public Sub Qb_PLAY(MuzStr As String)
  If Not freq_Flag Then Call freq_Init
  Dim Muz$, Muz2$
  Static generalOktava%
  Dim oktava%
  Static tempo%   ' Задание темпа или четвертных нот, которые исполняются в минуту. n от 32 до 255.
  If tempo = 0 Then tempo% = 120 '  По умолчанию 120
  Dim Nota%, curPosition%, curNota4%
  Dim currentNotaPauseDuration&, currentNotaDuration&, pauseDuration&
  Static takt%
  If takt = 0 Then takt = 240000 / tempo
  Dim isNota As Boolean
  Dim isPause As Boolean
  Dim pointsNum%
  Static generalNotaMultipl!
  If generalNotaMultipl = 0 Then generalNotaMultipl = 0.875
  Static NotaLong!
  Dim curMultipl!, tempFlo!, curPause!
  Dim tempLong&
  Dim i%, j%, LenMuzStr%
  LenMuzStr = Len(MuzStr)
  For i = 1 To LenMuzStr
   Muz = Mid(MuzStr, i, 1)
   If i < LenMuzStr Then Muz2 = Mid(MuzStr, i + 1, 1)
   isNota = False
   isPause = False
   oktava = generalOktava
   curNota4 = 0
   Select Case Muz
         Case "C"
             Nota = 0
             isNota = True
         Case "D"
             Nota = 2
             isNota = True
         Case "E"
             Nota = 4
             isNota = True
         Case "F"
             Nota = 5
             isNota = True
         Case "G"
             Nota = 7
             isNota = True
         Case "A"
             Nota = 9
             isNota = True
         Case "B"
             Nota = 11
             isNota = True
         Case "N" ' Nнота Играет определенную ноту (0 - 84) в диапазоне семи октав (0 - пауза)."
                 curPosition = i + 1
                 If extractNumber(curNota4, MuzStr, curPosition) Then
                     i = curPosition - 1
                     If (curNota4) Then
                         curNota4 = curNota4 - 1
                         oktava = curNota4 \ 12
                         Nota = curNota4 Mod 12
                         isNota = True
                     Else
                         isPause = True
                     End If
                 End If
         Case "O" 'Oоктава   Задает текущую октаву (0 - 6).
             curPosition = i + 1
             If extractNumber(oktava, MuzStr, curPosition) Then
                 i = curPosition - 1
                 generalOktava = oktava
             End If
         Case ">"
             generalOktava = generalOktava + 1
         Case "<"
             generalOktava = generalOktava - 1
         Case "M"
              Select Case Muz2
                 Case "N" 'MN    Нормаль. Каждая нота звучит 7/8 времени, заданного в команде L
                     generalNotaMultipl = 0.875 '  =7/8
                     i = i + 1
                 Case "L" 'ML    Легато. Каждая нота звучит полный интервал времени, заданного в команде L
                     generalNotaMultipl = 1
                     i = i + 1
                 Case "S" 'MS    Стаккато. Каждая нота звучит 3/4 времени, заданного в команде L
                     generalNotaMultipl = 0.75 ' =3/4
                     i = i + 1
                 Case "F" 'MF Режим непосредственного исполнения. Т.е. на время проигрывания ноты программа приостанавливается. Используется по умолчанию
                     i = i + 1 'Сдвигаем точку чтения и ничего не делаем."
                 Case "B" 'MB проигрывние в буффер
                     i = i + 1 'Сдвигаем точку чтения и ничего не делаем."
               End Select
         Case "L" 'Lразмер   Задает длительность каждой ноты (1 - 64). L1 - целая нота, L2 - 1/2 ноты и т.д.
             curPosition = i + 1
             If extractNumber(curNota4, MuzStr, curPosition) Then
                 i = curPosition - 1
                 tempFlo = curNota4
                 NotaLong = 1 / tempFlo
             End If
         Case "T" 'Tтемп Задает темп исполнения в четвертях в минуту (32-255).По умолчанию 120
             curPosition = i + 1
             If extractNumber(tempo, MuzStr, curPosition) Then
                i = curPosition - 1
                takt = 240000 / tempo ' миллисекунд на 1 целую ноту. 240000= 60 сек * 1000 мсек/сек *4 четвертей в ноте
             End If
         Case "P" 'Pпауза    Задает паузу (1 - 64). P1 - пауза в целую ноту, P2 - пауза в 1/2 ноты и т.д.
             curPosition = i + 1
             If extractNumber(curNota4, MuzStr, curPosition) Then
                 tempFlo = curNota4
                 curPause = 1 / tempFlo
                 i = curPosition - 1
                 isPause = True
             End If
         Case " " 'Есть в некоторых текстах. Вероятно это пауза длительностью в текущую ноту
             curPause = NotaLong
             isPause = True
    End Select
    If isNota Then
      Select Case Muz2
         Case "#" ' диез
             Nota = Nota + 1
             i = i + 1
         Case "+" ' диез
             Nota = Nota + 1
             i = i + 1
         Case "-" ' бемоль
            Nota = Nota - 1
            i = i + 1
       End Select
       curPosition = i + 1
       If extractNumber(curNota4, MuzStr, curPosition) Then
         currentNotaDuration = takt / curNota4
         i = curPosition - 1
       End If
     End If
     If oktava < 0 Then oktava = 0
     If oktava > 6 Then oktava = 6
     If isNota Or isPause Then
       curPosition = i + 1
       pointsNum = pointsCount(MuzStr, curPosition)
       If pointsNum > 0 Then i = curPosition - 1
       curMultipl = 1
       For j = 1 To pointsNum
            curMultipl = curMultipl * 1.5
       Next
       currentNotaPauseDuration = takt * NotaLong
     End If
     If isNota Then
        curMultipl = curMultipl * generalNotaMultipl
        currentNotaDuration = currentNotaPauseDuration * curMultipl
        If curMultipl > 1 Then
          pauseDuration = 0
        
        Else
          pauseDuration = currentNotaPauseDuration - currentNotaDuration
        End If
        If Nota < 0 Then Nota = 0
        If Nota > 11 Then Nota = 11
        tempLong = freq(oktava, Nota)
        Beep tempLong, currentNotaDuration
        Sleep (pauseDuration) ' API Sleep
        'Sleep (currentNotaPauseDuration) ' API Sleep
     End If
     If isPause Then
         pauseDuration = takt * curPause * curMultipl
         Sleep (pauseDuration)
     End If
    '=====================
'    If isNota Then
'        Debug.Print "Muz= " & Muz;
'        Debug.Print " Nota= " & Nota;
'        Debug.Print " oktava= " & oktava;
'        Debug.Print " NotaLong= " & NotaLong;
'    '    Debug.Print " tempo= " & tempo;
'    '    Debug.Print " takt= " & takt;
'        Debug.Print " currentNotaDuration= " & currentNotaDuration;
'        Debug.Print " pauseDuration= " & pauseDuration;
'    '    Debug.Print " currentNotaPauseDuration= " & currentNotaPauseDuration;
'    '    Debug.Print " curMultipl= " & curMultipl;
'        Debug.Print
'    End If
    '=====================
   Next
End Sub
 
Private Sub freq_Init()
    Dim TT$, i%, M As Variant
    'Нота  0  1       2   3       4   5   6       7   8       9   10      11
    'Нота  C  C#/D-   D   D#/E-   E   F   F#/G-   G   G#/A-   A   A#/B?   B
    TT = "65,69,73,78,82,87,92,98,104,110,117,123"                     '0 = Большая октава
    M = Split(TT, ",")
    For i = 0 To 11: freq(0, i) = Val(M(i)): Next
    TT = "131,139,147,156,165,175,185,196,208,220,233,247"             '1 = Малая октава
    M = Split(TT, ",")
    For i = 0 To 11: freq(1, i) = Val(M(i)): Next
    TT = "262,277,294,311,330,349,370,392,415,440,466,494"             '2 = 1-я октава
    M = Split(TT, ",")
    For i = 0 To 11: freq(2, i) = Val(M(i)): Next
    TT = "523,554,587,622,659,698,740,784,831,880,932,988"             '3 = 2-я октава
    M = Split(TT, ",")
    For i = 0 To 11: freq(3, i) = Val(M(i)): Next
    TT = "1047,1109,1175,1245,1319,1397,1480,1568,1661,1760,1865,1976" '4 = 3-я октава
    M = Split(TT, ",")
    For i = 0 To 11: freq(4, i) = Val(M(i)): Next
    TT = "2093,2218,2349,2489,2637,2794,2960,3136,3322,3520,3729,3951" '5 = 4-я октава
    M = Split(TT, ",")
    For i = 0 To 11: freq(5, i) = Val(M(i)): Next
    TT = "4186,4435,4699,4978,5274,5588,5920,6272,6645,7040,7459,7902" '6 = 5-я октава
    M = Split(TT, ",")
    For i = 0 To 11: freq(6, i) = Val(M(i)): Next
    freq_Flag = True
'    Dim j
'    For i = 0 To 6
'        For j = 0 To 11
'            Debug.Print freq(i, j);
'        Next
'        Debug.Print
'    Next
End Sub
 
Private Function extractNumber%(ByRef myNumber%, MuzStr$, ByRef curPosition%)
    Dim i%, digitsNumber%, curDigit%, Muz$, AscMuz%
    myNumber = 0
    For i = curPosition To Len(MuzStr)
        Muz = Mid(MuzStr, i, 1)
        AscMuz = Asc(Muz)
        If AscMuz > 47 And AscMuz < 58 Then ' Коды ASCII цифр '0' = 48 , '9' = 57
            curDigit = AscMuz - 48
            digitsNumber = digitsNumber + 1
            myNumber = myNumber * 10 + curDigit
        Else
            extractNumber = digitsNumber
            Exit Function
        End If
        curPosition = curPosition + 1
    Next
    extractNumber = digitsNumber
End Function
 
Private Function pointsCount%(MuzStr$, ByRef curPosition%)
    Dim pointsNumber%, i%, Muz$
    For i = curPosition To Len(MuzStr)
        Muz = Mid(MuzStr, i, 1)
        If Muz = "." Then
            pointsNumber = pointsNumber + 1
        Else
            pointsCount = pointsNumber
            curPosition = curPosition + 1
            Exit Function
        End If
    Next
    pointsCount = pointsNumber
End Function
 
Sub main_Qb_PLAY()
Rem Theme from The Godfather
    Qb_PLAY "MNT150L4O2EA>C<BA>C<ABAFGL2E.P4L4EA>C<BA>C<ABAFEL2D.P4"
    Qb_PLAY "L4DFAL2B.P4L4DFAL2A.P4L4EGFFEGFEDC<BL2A"
    
    ' Jingle Bells
'    Qb_PLAY ("MNT255L4O2DBAGL2D.L8DDL4DBAGL2E.L4EE>C<BAL1F+L4>DDC<A")
'    Qb_PLAY ("L1BL4DBAGL2D.L8DDL4DBAGL2E.L4EE>C<BA>DDDDEDC<AL2G.P4L4B")
'    Qb_PLAY ("BL2BL4BBL2BL4B>D<G.L8AL1BL4>CCC.L8CL4C<BBL8BBL4BAABL2A")
'    Qb_PLAY (">DL4<BBL2BL4BBL2BL4B>D<G.L8AL1BL4>CCC.L8CL4C<BBL8BBL4>D")
'    Qb_PLAY ("DC<AL1G")
'    'Sleep (5000)
'    '  KATIUSHA
'    Qb_PLAY ("MST255L2O2E.L4F+L2G.L4EGGF+EL2F+L4<BP4L2>F+.L4GL2A.L4F+")
'    Qb_PLAY ("AAGF+L1EL2B>EDL4EDCC<BAL2BEP4>CL4<AL2B.L4GF+<B>GF+L1E")
'    Qb_PLAY ("L2B>EDL4EDCC<BAL2BEP4>CL4<AL2B.L4GF+<B>GF+L1E")
'    'Sleep (5000)
'    ' Bach 1
'    Qb_PLAY ("MNT150L8O3AL16>C<AL8EL16AEL8CL16ECL4<AL16EA>C<ABABAG+")
'    Qb_PLAY ("B>D<B>C<B>C<AL8>AL16>C<AL8EL16AEL8CL16ECL4<AL16>C<BL8>C")
'    Qb_PLAY ("L16C<BL8>CAL16C.L32DL8C<BL16>ED+L8EL16ED+L8E>CL16<E.L32F")
'    Qb_PLAY ("L8ED+L16<B>EGEF+EF+ED+F+AF+GF+GF+EGED+EAED+EBED+E>C<E")
'    Qb_PLAY ("D+E>C<BABGF+EL8GL32F+GL16F+L4EL8AL16>C<AL8EL16AEL8CL16E")
'    Qb_PLAY ("CL4<AL16EA>C<ABABAG+B>D<B>C<B>C<AL8>AL16>C<AL8EL16AEL8C")
'    Qb_PLAY ("L16ECL4<AL16>C<BL8>CL16C<BL8>CAL16C.L32DL8C<BL16>ED+L8E")
'    Qb_PLAY ("L16ED+L8E>CL16<E.L32FL8ED+L16<B>EGEF+EF+ED+F+AF+GF+GF+")
'    Qb_PLAY ("EGED+EAED+EBED+E>C<ED+E>C<BABGF+EL8GL32F+GL16F+L4EL8E")
'    Qb_PLAY ("L16GEL8<BL16>E<BL8GL16BGL4EL8AG+>DC+GL16FEL8FDFL16AFL8D")
'    Qb_PLAY ("L16FDL8<BL16>D<BL4GL8>CL16ECDCDC<B>DFDEDEDCEC<B>CFC<B")
'    Qb_PLAY (">CGC<B>CAC<B>CAGFGEDCL8EL32DEL16DL4CL16EDL8EL16EDL8E>C")
'    Qb_PLAY ("<EL64FL8EDL16DCL8DL16DCL8DBDL64EL8DCAL16>C<AGL4F.L16A")
'    Qb_PLAY ("FEL4D.L16FDCL4<A+L16A+AA+AL4G+L8FEAG+>DL16C<B>C<A>CEL8A")
'    Qb_PLAY ("EL16DC<B>CL4<AL8>EL16GEL8<BL16>E<BL8GL16BGL4EL8AG+>DC+")
'    Qb_PLAY ("GL16FEL8FDFL16AFL8DL16FDL8<BL16>D<BL4GL8>CL16ECDCDC<B")
'    Qb_PLAY (">DFDEDEDCEC<B>CFC<B>CGC<B>CAC<B>CAGFGEDCL8EL32DEL16DL4C")
'    Qb_PLAY ("L16EDL8EL16EDL8E>C<EL64FL8EDL16DCL8DL16DCL8DBDL64EL8D")
'    Qb_PLAY ("CAL16>C<AGL4F.L16AFEL4D.L16FDCL4<A+L16A+AA+AL4G+L8FEA")
'    Qb_PLAY ("G+>DL16C<B>C<A>CEL8AEL16DC<B>CL4<A")
 
End Sub