2003-10-03 10:45

     $OPTION EXPLICIT
     $INCLUDE "Rapidq.inc"
     DECLARE SUB SomeMusic()
     DECLARE SUB SetReg (Reg AS INTEGER, Value AS INTEGER)
     DECLARE SUB SetRegister()
     DECLARE SUB Exit_Tune()

     REM -----
     REM ----- This program DO'nt works on XP System --------
     REM -----



     CONST BaseAddr = &H220 'Change if your sound card uses another base address

     CONST RegAddr = BaseAddr + 8
     CONST  DataAddr = BaseAddr + 9
     DIM I AS INTEGER
     DIM J AS INTEGER
     DIM time AS DOUBLE
     DIM NoOfNotes AS INTEGER
     DIM duration AS DOUBLE
     DIM octave AS INTEGER
     DIM note$
     DIM Performance AS INTEGER


     CREATE TuneIt AS QFORM
      Center
      CAPTION = "Tune Player by B Figaro"
      Icon="THEHOOK.ICO"
      Width = 230
      Height = 80
      COLOR = &hABFFFF
      onClose = Exit_Tune
      CREATE PlayBtn AS QBUTTON
       Left = 2
       Top = 10
       Width = 100
       Height = 28
       OnClick = SomeMusic
       BMP = "TunePlay.Bmp"
       Hint = "Play"
       ShowHint = 1
      END CREATE
      CREATE ExitMe AS QBUTTON
       Left = 120
       Top = 10
       Width = 100
       Height = 28
       OnClick = Exit_Tune
       BMP     = "TuneExit.Bmp"
       Hint = "Exit Program file"
       ShowHint = 1
      END CREATE
     END CREATE

     TuneIt.SHOWMODAL

     DATA 68
     DATA  3 ,C, 2 ,A, 2 ,F, 2 ,C, 1 ,C, .25
     DATA  3 ,F, 2 ,F, 1 ,A, 1 ,A, 1 ,F, .375
     DATA  3 ,G, 2 ,G, 2 ,E, 1 ,A#, 1 ,G, .125
     DATA  3 ,A, 2 ,A, 2 ,F, 1 ,A, 1 ,A#, .125
     DATA  3 ,A#, 2 ,A#, 2 ,G, 1 ,G, 1 ,A, .125
     DATA  4 ,C, 3 ,C, 2 ,A, 1 ,F, 0 ,F, .25
     DATA  3 ,A, 2 ,A, 2 ,F, 1 ,F, 0 ,A, .25
     DATA  4 ,C, 3 ,C, 2 ,A, 1 ,F, 1 ,C, .25
     DATA  3 ,A#, 2 ,A#, 2 ,G, 1 ,G, 0 ,E, .25
     DATA  3 ,G, 2 ,G, 2 ,E, 1 ,G, 0 ,G, .25
     DATA  3 ,E, 2 ,E, 2 ,C, 1 ,G, 0 ,C, .25
     DATA  3 ,F, 2 ,C, 1 ,A, 1 ,F, 0 ,F, .5
     DATA  3 ,C, 2 ,C, 1 ,C, 1 ,C, 0 ,C, .25
     DATA  3 ,F, 2 ,F, 1 ,A, 1 ,A, 1 ,F, .375
     DATA  3 ,G, 2 ,G, 2 ,E, 1 ,A#, 1 ,G, .125
     DATA  3 ,A, 2 ,A, 2 ,F, 1 ,A, 1 ,A#, .125
     DATA  3 ,A#, 2 ,A#, 2 ,G, 1 ,G, 1 ,A, .125
     DATA  4 ,C, 3 ,C, 2 ,A, 1 ,F, 0 ,F, .25
     DATA  3 ,A, 2 ,A, 2 ,F, 1 ,F, 0 ,A, .25
     DATA  4 ,C, 3 ,C, 2 ,A, 1 ,F, 1 ,C, .25
     DATA  3 ,A#, 2 ,A#, 2 ,G, 1 ,G, 0 ,E, .25
     DATA  3 ,G, 2 ,G, 2 ,E, 1 ,G, 0 ,G, .25
     DATA  3 ,E, 2 ,E, 2 ,C, 1 ,G, 0 ,C, .25
     DATA  3 ,F, 2 ,C, 1 ,A, 1 ,F, 0 ,F, .5
     DATA  3 ,F, 2 ,F, 2 ,C, 1 ,C, 0 ,A, .25
     DATA  3 ,A#, 2 ,A#, 1 ,A#, 1 ,A#, 0 ,A#, .5
     DATA  4 ,D, 3 ,D, 2 ,F, 1 ,A#, 0 ,F, .25
     DATA  3 ,A#, 2 ,A#, 2 ,D, 1 ,D, 0 ,F, .25
     DATA  4 ,D, 3 ,D, 2 ,F, 1 ,D, 0 ,A#, .25
     DATA  4 ,D, 3 ,D, 2 ,F, 2 ,D, 0 ,D, .25
     DATA  3 ,F, 2 ,F, 2 ,C, 1 ,C, 0 ,A, .25
     DATA  3 ,A, 2 ,A, 2 ,F, 1 ,C, 0 ,F, .25
     DATA  4 ,C, 3 ,C, 2 ,A, 1 ,C, 1 ,C, .25
     DATA  3 ,A, 2 ,A, 2 ,F, 1 ,A, 0 ,F, .25
     DATA  4 ,C, 3 ,C, 2 ,A, 1 ,A, 0 ,A, .25
     DATA  4 ,C, 2 ,C, 2 ,A, 1 ,A, 0 ,C, .25
     DATA  3 ,C, 2 ,C, 1 ,A, 1 ,A#, 0 ,C, .25
     DATA  3 ,E, 2 ,E, 2 ,C, 1 ,A#, 0 ,E, .25
     DATA  3 ,G, 2 ,G, 2 ,E, 1 ,A#, 0 ,A#, .25
     DATA  3 ,C, 2 ,C, 1 ,A, 1 ,G, 0 ,A, .25
     DATA  3 ,E, 2 ,E, 3 ,C, 1 ,G, 0 ,G, .25
     DATA  3 ,G, 2 ,G, 3 ,E, 1 ,G, 0 ,A#, .25
     DATA  4 ,C, 3 ,C, 2 ,E, 1 ,A#, 1 ,E, .25
     DATA  4 ,C, 3 ,C, 2 ,E, 1 ,A#, 0 ,A#, .25
     DATA  4 ,C, 3 ,C, 2 ,E, 1 ,A#, 0 ,G, .25
     DATA  3 ,A, 2 ,F, 2 ,C, 1 ,A, 1 ,C, .5
     DATA  3 ,F, 2 ,F, 2 ,C, 1 ,A, 1 ,C, .25
     DATA  3 ,A#, 2 ,A#, 1 ,A#, 1 ,A#, 0 ,A#, .5
     DATA  4 ,D, 3 ,D, 2 ,F, 1 ,A#, 0 ,F, .25
     DATA  3 ,A#, 2 ,A#, 2 ,D, 1 ,D, 0 ,F, .25
     DATA  4 ,D, 3 ,D, 2 ,F, 1 ,D, 0 ,A#, .25
     DATA  4 ,D, 3 ,D, 2 ,F, 2 ,D, 0 ,D, .25
     DATA  3 ,F, 2 ,F, 2 ,C, 1 ,C, 0 ,A, .25
     DATA  3 ,A, 2 ,A, 2 ,F, 1 ,C, 0 ,F, .25
     DATA  4 ,C, 3 ,C, 2 ,A, 1 ,C, 1 ,C, .25
     DATA  3 ,A, 2 ,A, 2 ,F, 1 ,A, 0 ,F, .25
     DATA  4 ,C, 3 ,C, 2 ,A, 1 ,A, 0 ,A, .25
     DATA  4 ,C, 2 ,C, 2 ,A, 1 ,A, 0 ,C, .25
     DATA  3 ,C, 2 ,C, 1 ,A, 1 ,A#, 0 ,C, .25
     DATA  3 ,E, 2 ,E, 2 ,C, 1 ,A#, 0 ,E, .25
     DATA  3 ,G, 2 ,G, 2 ,E, 1 ,A#, 0 ,A#, .25
     DATA  3 ,C, 2 ,C, 1 ,A, 1 ,G, 0 ,A, .25
     DATA  3 ,E, 2 ,E, 3 ,C, 1 ,G, 0 ,G, .25
     DATA  3 ,G, 2 ,G, 3 ,E, 1 ,G, 0 ,A#, .25
     DATA  4 ,C, 3 ,C, 2 ,E, 1 ,A#, 0 ,G, .25
     DATA  3 ,A#, 2 ,A#, 2 ,E, 1 ,A#, 0 ,A#, .25
     DATA  3 ,G, 2 ,G, 2 ,E, 1 ,A#, 1 ,C, .25
     DATA  3 ,F, 2 ,F, 2 ,A, 1 ,A, 1 ,C, .5


     SUB SomeMusic()
      SetRegister

      FOR Performance = 0 TO 1
       RESTORE
       READ NoOfNotes

       FOR i = 1 TO NoOfNotes
        Time = TIMER
        FOR j = 0 TO 4 'Voices 0, 1 and 2
         READ Octave
         Octave = Octave + 1
         READ note$
         SELECT CASE note$
         CASE "C#"
          SetReg &HA0 + j, &H6B 'Set note number
          SetReg &HB0 + j, &H21 + 4 * Octave 'Set octave and switch on channel
         CASE "D"
          SetReg &HA0 + j, &H81
          SetReg &HB0 + j, &H21 + 4 * Octave
         CASE "D#"
          SetReg &HA0 + j, &H98
          SetReg &HB0 + j, &H21 + 4 * Octave
         CASE "E"
          SetReg &HA0 + j, &HB0
          SetReg &HB0 + j, &H21 + 4 * Octave
         CASE "F"
          SetReg &HA0 + j, &HCA
          SetReg &HB0 + j, &H21 + 4 * Octave
         CASE "F#"
          SetReg &HA0 + j, &HE5
          SetReg &HB0 + j, &H21 + 4 * Octave
         CASE "G"
          SetReg &HA0 + j, &H2
          SetReg &HB0 + j, &H22 + 4 * Octave
         CASE "G#"
          SetReg &HA0 + j, &H20
          SetReg &HB0 + j, &H22 + 4 * Octave
         CASE "A"
          SetReg &HA0 + j, &H41
          SetReg &HB0 + j, &H22 + 4 * Octave
         CASE "A#"
          SetReg &HA0 + j, &H63
          SetReg &HB0 + j, &H22 + 4 * Octave
         CASE "B"
          SetReg &HA0 + j, &H87
          SetReg &HB0 + j, &H22 + 4 * Octave
         CASE "C"
          SetReg &HA0 + j, &HAE
          SetReg &HB0 + j, &H22 + 4 * Octave
         END SELECT
        NEXT j

        READ duration
        DO
        LOOP UNTIL Time + duration < TIMER 'Wait as long as duration
        FOR j = 0 TO 4
         SetReg &HB0 + j, 0 'Switch channel off
        NEXT j

       NEXT i
      NEXT

     END SUB

     SUB SetReg (Reg, Value)
      OUT RegAddr, Reg
      OUT DataAddr, Value
     END SUB

     SUB SetRegister()
      DIM I AS INTEGER
      FOR i = 0 TO 224
       SetReg i, 0 'Clear all registers
      NEXT i

      SetReg &H20, &H1 'Plays carrier note at specified octave ch. 1
      SetReg &H23, &H1 'Plays modulator note at specified octave ch. 1
      SetReg &H40, &H1F 'Set carrier total level to softest ch. 1
      SetReg &H43, &H0 'Set modulator level to loudest ch. 1
      SetReg &H60, &HE4 'Set carrier attack and decay ch. 1
      SetReg &H63, &HE4 'Set modulator attack and decay ch. 1
      SetReg &H80, &H9D 'Set carrier sustain and release ch. 1
      SetReg &H83, &H9D 'Set modulator sustain and release ch. 1
      SetReg &H21, &H1 'Plays carrier note at specified octave ch. 2
      SetReg &H24, &H1 'Plays modulator note at specified octave ch. 2
      SetReg &H41, &H1F 'Set carrier total level to softest ch. 2
      SetReg &H44, &H0 'Set modulator level to loudest ch. 2
      SetReg &H61, &HE4 'Set carrier attack and decay ch. 2
      SetReg &H64, &HE4 'Set modulator attack and decay ch. 2
      SetReg &H81, &H9D 'Set carrier sustain and release ch. 2
      SetReg &H84, &H9D 'Set modulator sustain and release ch. 2
      SetReg &H22, &H1 'Plays carrier note at specified octave ch. 3
      SetReg &H25, &H1 'Plays modulator note at specified octave ch. 3
      SetReg &H42, &H1F 'Set carrier total level to softest ch. 3
      SetReg &H45, &H0 'Set modulator level to loudest ch. 3
      SetReg &H62, &HE4 'Set carrier attack and decay ch. 3
      SetReg &H65, &HE4 'Set modulator attack and decay ch. 3
      SetReg &H82, &H9D 'Set carrier sustain and release ch. 3
      SetReg &H85, &H9D 'Set modulator sustain and release ch. 3
     END SUB

     SUB Exit_Tune()
      TuneIt.CLOSE
      END

     END SUB

2003-10-03 10:45