MINI SÉQUENSEUR

Option Explicit
Const TX = 9 '<= 9
Const TY = 9 '<= 9
'------------------
Private DX As New DirectX7
Private DS As DirectSound
Private bufferDesc As DSBUFFERDESC
Private waveFormat As WAVEFORMATEX
Private Type KeyPad
    Enabled As Boolean
    Filename As String
    Soundbuffer As DirectSoundBuffer
End Type
Dim Sequencer() As KeyPad
Private Tracker As Integer
'
Private Sub Form_Load()
Form1.Caption = " Séquencer v" & App.Major & "." & App.Minor & " " & App.Comments
ReDim Sequencer(1 To TX, 1 To TY)
Tracker = 0
If LedInit <> 0 Or SoundInit <> 0 Then
    MsgBox "Erreur d'initialisation", vbExclamation
    Unload Me
End If
Me.Show
AfficheLed
End Sub
'
Private Function LedInit() As Long
Dim X, Y As Integer
On Error GoTo Trap
For Y = 1 To TY
    Load SelectSample(Y)
    With SelectSample(Y)
        .Left = 0
        .Top = SelectSample(0).Height * (Y - 1) + LTempo.Height
        .Visible = True
    End With
For X = 1 To TX
    Load Led1(Val(X & Y))
    Load Led0(Val(X & Y))
    With Led1(Val(X & Y))
        .Left = Led1(0).Width * (X - 1) + Led1(0).Width
        .Top = Led1(0).Height * (Y - 1) + LTempo.Height
        .Visible = False
    End With
    With Led0(Val(X & Y))
        .Left = Led0(0).Width * (X - 1) + Led0(0).Width
        .Top = Led0(0).Height * (Y - 1) + LTempo.Height
        .Visible = True
    End With
Next: Next
Exit Function

Trap:
Debug.Print "LedInit /!\ " & Err.Description
LedInit = Err.Number
End Function
' Initialise DirectSound
Private Function SoundInit() As Long
On Error GoTo Trap
Set DS = DX.DirectSoundCreate("")
DS.SetCooperativeLevel Form1.hWnd, DSSCL_PRIORITY
' Initialise le buffer DirectSound
bufferDesc.lFlags = DSBCAPS_CTRLFREQUENCY Or DSBCAPS_CTRLPAN Or DSBCAPS_CTRLVOLUME Or DSBCAPS_STATIC
' Initialise le format audio
waveFormat.nFormatTag = WAVE_FORMAT_PCM
waveFormat.nChannels = 2
waveFormat.lSamplesPerSec = 22050
waveFormat.nBitsPerSample = 16
waveFormat.nBlockAlign = waveFormat.nBitsPerSample / 8 * waveFormat.nChannels
waveFormat.lAvgBytesPerSec = waveFormat.lSamplesPerSec * waveFormat.nBlockAlign
Exit Function

Trap:
Debug.Print "Soundinit /!\ " & Err.Description
SoundInit = Err.Number
End Function
'
Private Sub Command_Click(Index As Integer)
Select Case Index
Case 0
    Tempo.Enabled = True
    Command(0).Visible = False
Case 1
    Tempo.Enabled = False
    Command(0).Visible = True
    StopSequence
Case 2
    Tempo.Enabled = False
    Command(0).Visible = True
    StopSequence
    Tracker = 0
Case 3
    If Tempo.Interval <= 1999 Then Tempo.Interval = Tempo.Interval + 50
Case 4
    If Tempo.Interval >= 51 Then Tempo.Interval = Tempo.Interval - 50
End Select
AfficheLed
End Sub
'
Private Sub Led0_Click(Index As Integer)
Dim X, Y As Integer
X = Left(Index, 1)
Y = Right(Index, 1)
Sequencer(X, Y).Enabled = True
AfficheLed
End Sub
'
Private Sub Led1_Click(Index As Integer)
Dim X, Y As Integer
X = Left(Index, 1)
Y = Right(Index, 1)
Sequencer(X, Y).Enabled = False
AfficheLed
End Sub
'
Private Sub SelectSample_Click(Index As Integer)
On Error GoTo Abort:
With CMD
    .DialogTitle = "Ouvrir un sample"
    .InitDir = App.Path
    .Filter = "Fichiers audio (*.wav)|*.wav"
End With
CMD.ShowOpen
Sequencer(1, Index).Filename = CMD.Filename
Call SoundLoad(Sequencer(1, Index).Filename, Index)
Exit Sub

Abort:
Sequencer(1, Index).Filename = ""
End Sub
' Charge les sons en memoire
Private Sub SoundLoad(Filename As String, Index As Integer)
Dim X As Integer
'On Error GoTo Trap
If Dir(Filename, vbNormal) = "" Then GoTo Trap:
For X = 1 To TX
    Set Sequencer(X, Index).Soundbuffer = DS.CreateSoundBufferFromFile(Filename, bufferDesc, waveFormat)
Next
Exit Sub

Trap:
Debug.Print "Soundload /!\ " & Err.Description
End Sub
'
Private Sub Tempo_Timer()
On Error GoTo Error
Tracker = Tracker Mod TX + 1
AfficheLed
PlaySequence
DoEvents
Exit Sub

Error:
Command_Click (2)
End Sub
'
Private Sub PlaySequence()
Dim Y As Integer
On Error Resume Next
For Y = 1 To TY
    If Sequencer(Tracker, Y).Enabled = True And Sequencer(1, Y).Filename <> "" Then
        Call SoundStop(Val(Tracker & Y))
        Call SoundPlay(Val(Tracker & Y), 0)
    End If
Next
End Sub
'
Private Sub StopSequence()
Dim X, Y As Integer
On Error Resume Next
For X = 1 To TX
For Y = 1 To TY
    If Sequencer(1, Y).Filename <> "" Then Call SoundStop(Val(X & Y))
Next: Next
End Sub
' Joue un son
Private Sub SoundPlay(SoundID As Integer, Looped As Integer)
Dim X, Y As Integer
On Error GoTo Trap
X = Left(SoundID, 1)
Y = Right(SoundID, 1)
Sequencer(X, Y).Soundbuffer.Play Looped
Exit Sub

Trap:
Debug.Print "Soundplay /!\ " & Err.Description
End Sub
' Stop un son
Private Sub SoundStop(SoundID As Integer)
Dim X, Y As Integer
On Error GoTo Trap
X = Left(SoundID, 1)
Y = Right(SoundID, 1)
Sequencer(X, Y).Soundbuffer.Stop
Exit Sub

Trap:
Debug.Print "Soundstop /!\ " & Err.Description
End Sub
'
Private Sub AfficheLed()
Dim X, Y As Integer
On Error GoTo Error
For Y = 1 To TY
For X = 1 To TX
    If X = Tracker Then
        Led0(Val(X & Y)).Picture = Skin(1).Picture
        Led1(Val(X & Y)).Picture = Skin(3).Picture
    Else
        Led0(Val(X & Y)).Picture = Skin(0).Picture
        Led1(Val(X & Y)).Picture = Skin(2).Picture
    End If
    If Sequencer(X, Y).Enabled = True Then
        Led1(Val(X & Y)).Visible = True
    Else
        Led1(Val(X & Y)).Visible = False
    End If
Next: Next
LTempo.Caption = "Wait, " & Tempo.Interval
Exit Sub

Error:
Debug.Print "AfficheLed /!\ " & Err.Description
End Sub
'
Private Sub Form_Unload(Cancel As Integer)
SoundUnload
LedUnload
End
End Sub
' Libere la mémoire
Private Sub SoundUnload()
Set DS = Nothing
Set DX = Nothing
End Sub
'
Private Sub LedUnload()
Dim X, Y As Integer
On Error GoTo Error
For Y = 1 To TY
    Unload SelectSample(Y)
For X = 1 To TX
    Unload Led1(Val(X & Y))
    Unload Led0(Val(X & Y))
Next: Next
Exit Sub

Error:
Debug.Print "LedUnload /!\ " & Err.Description
End Sub

Télécharger le zip

25 février 2008 01:07:15 :

?