Easysample : jouer des sons (mp3, wave) depuis un clavier midi

Télécharger le projet
Commenter

Description

Dans le cadre d'un spectacle, j'avais besoin de jouer des "ambiances" sonores depuis une interface Standard. Après des recherches infructueuses sur un clavier style "Ardisson", je me suis décidé à coder un petit quelque chose. EasySample exploite les MCIsendString. Cette librairie permet, en autre, de jouer des sons même superposés à partir de simples chaines de texte.

Avant toutes choses, il faut sélectionner une interface MIDI dans le Cadre "MIDI" et appuyer sur "Start".
Pour affecter un son à une touche du clavier, cliquer sur le piano pour sélectionner la touche puis renseignez les champs du cadre "Sample". N'oubliez pas de sauvegarder vos changement en cliquent sur la "coche" verte. La note est joué tant que la touche du clavier midi est enfoncé. L'option "Poussoir" permet de lancer le son d'un appui et de l'arrêter par un second appui. l'option "Boucle" permet de jouer le son en ... (vous aurez deviné ;-) Enfin l'option "Continue" permet, après un arrêt de lecture du sample, de reprndre la lecture où elle s'était arrêté.

Le cadre "IO" permet de piloter des entrées sorties en synchrone avec un son. Dans mon cas, je pilote un effet de scène type "Flamme" en même temps qu'un bruit d'explosion et de flamme. Lors de l'appuie sur la touche, un octet esst envoyé au travers du port série sélectionné. Je me suis fait un carte avec un µc PIC qui reçoit l'octet, le décode et active une sortie transistorisée qui pilote un relais de puissance. Pour ceux qui sont intéressé, laissez moi un commentaire.

Source / Exemple : 


'********************************************************************
' EasySample
' Programme de lecture de samples Pour tester ça vous devez avoir
' Clavier Midi correctement connecté sur le port midi (manette)
' de votre carte son.
' (C)2010 Bertrand BALDACH
' bertrand.baldach@gmail.com http://b.baldach.free.fr
'********************************************************************
' La partie capture MIDI est issu du travail de :
' Midi In Demo
' Démo de capture des entrées midi.
' (C)2003 Olivier RISACHER
' olivier@risacher.com http://www.rature.com
'--------------------------------------------------------------------
' Form principale
'********************************************************************

Option Explicit

Private Declare Function GetShortPathName Lib "kernel32" Alias "GetShortPathNameA" (ByVal lpszLongPath As String, ByVal lpszShortPath As String, ByVal cchBuffer As Long) As Long

Private Declare Function EnumPorts Lib "winspool.drv" Alias "EnumPortsA" _
                                   (ByVal pName As String, ByVal nLevel As Long, _
                                    lpbPorts As Any, ByVal cbBuf As Long, _
                                    pcbNeeded As Long, pcReturned As Long) As Long
                                    
Private Declare Function lstrlenA Lib "kernel32" (lpString As Any) As Long
Private Declare Function lstrcpyA Lib "kernel32" (lpString1 As Any, lpString2 As Any) As Long
                                    
Private Const SIZEOFPORT_INFO_2 = 20

Private Type PORT_INFO_2
    pPortName    As Long
    pMonitorName As Long
    pDescription As Long
    fPortType    As Long
    Reserved     As Long
End Type

Private Enum PortTypes
    PORT_TYPE_WRITE = &H1
    PORT_TYPE_READ = &H2
    PORT_TYPE_REDIRECTED = &H4
    PORT_TYPE_NET_ATTACHED = &H8
End Enum

Dim ListeNote
Public Note As Byte

Private Type Sample
    fichier As String
    loopMode As Boolean
    monostable As Boolean
    continue As Boolean
    stAte As Boolean
    IO As Byte
    Duree As Long
    Retard As Long
    Volume As Integer
    
End Type

'Clavier de 8 octaves
Dim Clavier(96) As Sample

Dim stAte As Boolean

Dim IO_On(7) As Long
Dim IO_Off(7) As Long

Dim Buffer_IO(7) As Byte

Dim lRet As Long

Dim mcistring As String
Dim MesIO(7) As Boolean

Private Sub Command10_Click()
Dim i, j As String
i = "672681"
j = "000080"

Debug.Print "i=" & i & " j=" & j & "     i AND j  = " & Hex(Val("&H" & i) And Val("&H" & j))
End Sub

Private Sub Form_Load()
'démarre la fonction de Callback
'Subclass_Start Me.hWnd

On Error Resume Next
    'au chargement on liste les drivers Midi IN disponible et on les affiches dans la liste

    Dim caps2 As MIDIINCAPS
    Dim i As Integer

    For i = 0 To (midiInGetNumDevs - 1)         'on parcours tous les drivers
        midiInGetDevCaps i, caps2, Len(caps2)   'On cherche le drivers en cours
        List1.AddItem caps2.szPname             'on l'insère dans la liste
    Next i
    
    
 ListeNote = Array(36, 38, 40, 41, 43, 45, 47, 48, 50, 52, 53, 55, 57, 59, 60, 62, 64, 65, 67, 69, 71, 72, 74, 76, 77, 79, 81, 83, 84, 86, 88, 89, 91, 93, 95, 96, 98, 100, 101, 103, 105, 107, 108, 110, 112, 113, 115, 117, 119, 120, 122, 124, 125, 127, 129, 131)
 
 ' Mode Commande RS232
 MSComm1.PortOpen = True
 Dim listePorts() As String
 listePorts = Split(GetPorts, "|")
 
For i = 0 To UBound(listePorts)
 If Left(listePorts(i), 3) = "COM" Then List2.AddItem (Left(listePorts(i), Len(listePorts(i)) - 1))
Next i

Form1.Caption = "Easy Sample V" & App.Major & "." & App.Minor & "." & App.Revision

'placement des points repères
For i = 0 To 55
    Indicateur(i).Left = i * 257 + 20
    Indicateur(i).Top = 4080
    Indicateur(i).BackColor = &H8000000F
    
Next i

stAte = False

'Initialise les buffer d'IO
For i = 0 To UBound(IO_On)
    IO_On(i) = 0
Next i

For i = 0 To UBound(IO_Off)
    IO_Off(i) = 0
Next i

End Sub
Private Sub Check2_Click()
If Check3.Enabled = True Then
Check3.Enabled = False
Else
Check3.Enabled = True
End If
End Sub

Private Sub cmdLoadFirst(MySample As Sample, manote As Byte)

Dim lRet As Long
Dim sFileName As String
Dim mcistring As String

sFileName = GetShortFileName(MySample.fichier)

mcistring = "open " & Chr(34) & sFileName & Chr(34) & " type mpegvideo alias " & "MP3_Device" & manote & " wait" '" type MPEGVideo alias "

lRet = mciSendString(mcistring, vbNullString, 0&, 0&)

If lRet = 0 Then
    
Else
    MsgBox GetMCIErrorMessage(lRet)
End If

End Sub

Private Sub cmdLoadAll()

Dim lRet As Long
Dim sFileName As String
Dim mcistring As String
Dim i As Byte

For i = 0 To UBound(Clavier)
mcistring = "open " & Chr(34) & GetShortFileName(Clavier(i).fichier) & Chr(34) & " type mpegvideo alias " & "MP3_Device" & i & " wait"  ' & " devicetype AVIVideo alias "
lRet = mciSendString(mcistring, vbNullString, 0&, 0&)
If Clavier(i).IO <> 0 Then Indicateur(i).BackColor = vbGreen
If Clavier(i).fichier <> "" Then Indicateur(i).BackColor = vbGreen
Next i

End Sub

Private Sub cmdUnloadFirst(MySample As Sample, manote As Byte)

Dim lRet As Long
Dim sFileName As String
Dim mcistring As String

sFileName = GetShortFileName(MySample.fichier)

mcistring = "close " & "MP3_Device" & manote & " wait"

lRet = mciSendString(mcistring, vbNullString, 0&, 0&)

If lRet = 0 Then
    
Else
    MsgBox GetMCIErrorMessage(lRet)
End If

End Sub

Private Sub cmdUnloadAll()

Dim lRet As Long
Dim sFileName As String
Dim mcistring As String
Dim i As Byte

For i = 0 To UBound(Clavier)
mcistring = "close " & "MP3_Device" & i & " wait"
lRet = mciSendString(mcistring, vbNullString, 0&, 0&)
Next i

End Sub

Private Sub cmdPlayFirst(alias As Byte)
Dim lRet As Long
Dim mcistring As String

mcistring = "play " & "MP3_Device" & alias

If Clavier(alias).continue = True Then
    'continue = true
    If Clavier(alias).loopMode = True Then
        mcistring = mcistring & " repeat"
    Else
        mcistring = mcistring
    End If
    
Else
    'continue = false
    If Clavier(alias).loopMode = True Then
        mcistring = mcistring & " from 0  repeat"
    Else
        mcistring = mcistring & " from 0"
    End If
   

End If
mcistring = mcistring & " notify"
'Debug.Print mcistring

lRet = mciSendString(mcistring, "", 0, Me.hWnd)

End Sub

Private Sub cmdStopFirst(alias As Byte)
Dim lRet As Long
Dim mcistring As String
mcistring = "stop " & "MP3_Device" & alias
Call mciSendString(mcistring, vbNullString, 0&, 0&)
End Sub

Private Sub cmdStopAll_Click()

'This will close all devices.
Call mciSendString("close all", vbNullString, 0&, 0&)

'This will stop playback of the device with the specifed
'alias but leave the device open
'Call mciSendString("stop " & MP3_ALIAS1, vbNullString, 0&, 0&)

End Sub

Private Sub Charger_Click()
CommonDialog1.FileName = ""
CommonDialog1.DialogTitle = "Charger"
CommonDialog1.Filter = "Fichier EasySample (*.ezs) | *.ezs"
CommonDialog1.InitDir = App.Path
CommonDialog1.ShowOpen
If CommonDialog1.FileName <> "" Then
Open CommonDialog1.FileName For Binary As #1
    Get #1, , Clavier
Close #1
cmdUnloadAll
cmdLoadAll
Form1.Caption = "Easy Sample V" & App.Major & "." & App.Minor & " - " & CommonDialog1.FileName
End If
End Sub

Private Sub Check4_Click(Index As Integer)
Dim i As Integer
Text4.Text = ""
For i = 0 To 7
    Text4.Text = Val(Text4.Text) + Str((Check4(i).Value * 2 ^ i))
Next i
End Sub

Private Sub Command2_Click()
CommonDialog1.DialogTitle = "Ouvrir"
CommonDialog1.Filter = "Fichier wave (*.wav)|*.wav|Fichier mp3 (*.mp3)|*.mp3"
CommonDialog1.InitDir = App.Path
CommonDialog1.ShowOpen

If CommonDialog1.FileName <> "" Then
    Text3.Text = CommonDialog1.FileName
End If
End Sub

Private Sub Command3_MouseDown(Button As Integer, Shift As Integer, X As Single, Y As Single)
Dim pipo As String
pipo = "&H7F" & Hex(ListeNote(Note)) & "90"
Text1.Text = Val(pipo)

End Sub
Private Sub Command3_Mouseup(Button As Integer, Shift As Integer, X As Single, Y As Single)
Dim pipo As String
pipo = "&H00" & Hex(ListeNote(Note)) & "80"
Text1.Text = Val(pipo)

End Sub

Private Sub Command4_Click()
 ' Bouton vert Sample (sauvergarde)
If Text2.Text = "" Then
    MsgBox "Veuillez cliquer sur une touche du clavier virtuel" & vbCrLf & "afin de sélectionner la note à affecter au sample.", vbApplicationModal & vbOKOnly, "Erreur"
    Exit Sub
End If

If Text3.Text = "" Then
    MsgBox "Veuillez indiquer le chemin du fichier de sample", vbApplicationModal & vbOKOnly, "Erreur"
    Exit Sub
End If

'Sauvegarde
If Clavier(Note).fichier <> "" Then cmdUnloadFirst Clavier(Note), Note
Clavier(Note).fichier = Text3.Text
Clavier(Note).loopMode = Check1.Value
Clavier(Note).monostable = Check2.Value
Clavier(Note).continue = Check3.Value
Clavier(Note).stAte = False
Clavier(Note).IO = calculIO
Clavier(Note).Volume = Slider1.Value

cmdLoadFirst Clavier(Note), Note

End Sub

Private Sub Command5_Click()
 ' Bouton rouge Sample (annuler)
Dim question
question = MsgBox("Etes-vous sur de vouloir supprimer l'affectation du sample?", vbOKCancel, "Avertissement")
If question <> 1 Then Exit Sub
Clavier(Note).fichier = ""
Clavier(Note).loopMode = 0
Clavier(Note).monostable = 0
Clavier(Note).continue = 0

cmdUnloadFirst Clavier(Note), Note

Text2.Text = ""
Text3.Text = ""
Check1.Value = 0
Check2.Value = 0
Check3.Value = 0
End Sub

Private Sub Command6_Click()
' Bouton vert Test IO
Dim toto As String
If Not MSComm1.PortOpen = True Then
    MsgBox "Aucun port COM n'est ouvert", vbCritical & vbOKOnly, "erreur"
Else
    toto = Chr(85) + Chr(Val(Text4.Text))
    MSComm1.Output = toto
End If
End Sub

Private Sub Command7_Click()
'selectionne port com
On Error GoTo erreur

If MSComm1.PortOpen = True Then MSComm1.PortOpen = False
MSComm1.CommPort = Replace(List2.List(List2.ListIndex), "COM", "")
MSComm1.PortOpen = True
Exit Sub

erreur:
Select Case Err.Number
    
    Case comInvalidPropertyValue
    MsgBox "Propriétés de port invalide", vbOKOnly, "Erreur"
    
    Case comPortInvalid
    MsgBox "Port invalide", vbOKOnly, "Erreur"
    
    Case comPortOpen
    MsgBox "Port Com ouvert", vbOKOnly, "Erreur"
    Case comNoOpen
    MsgBox "Port Com pas ouvert", vbOKOnly, "Erreur"
    Case comPortAlreadyOpen
    MsgBox "Port Com déjà ouvert", vbOKOnly, "Erreur"
    
End Select

End Sub

Private Sub Command8_Click()
  ' Bouton vert IO (sauvergarde)
If Text2.Text = "" Then
    MsgBox "Veuillez cliquer sur une touche du clavier virtuel" & vbCrLf & "afin de sélectionner la note à affecter au sample.", vbApplicationModal & vbOKOnly, "Erreur"
    Exit Sub
End If

'Sauvegarde
If Clavier(Note).fichier <> "" Then cmdUnloadFirst Clavier(Note), Note
Clavier(Note).fichier = Text3.Text
Clavier(Note).loopMode = Check1.Value
Clavier(Note).monostable = Check2.Value
Clavier(Note).continue = Check3.Value
Clavier(Note).stAte = False
Clavier(Note).IO = calculIO
Clavier(Note).Duree = Text5.Text
Clavier(Note).Retard = Text6.Text

cmdLoadFirst Clavier(Note), Note
End Sub

Private Function calculIO() As Byte
Dim temp As Byte
temp = Val(Check4(7)) * 128
temp = temp + Val(Check4(6)) * 64
temp = temp + Val(Check4(5)) * 32
temp = temp + Val(Check4(4)) * 16
temp = temp + Val(Check4(3)) * 8
temp = temp + Val(Check4(2)) * 4
temp = temp + Val(Check4(1)) * 2
temp = temp + Val(Check4(0)) * 1

calculIO = temp
End Function

Private Sub Command9_Click()
 ' Bouton rouge IO (annuler)
Dim question As Integer
Dim i As Integer
question = MsgBox("Etes-vous sur de vouloir supprimer l'affectation du sample?", vbOKCancel, "Avertissement")
If question <> 1 Then Exit Sub
Clavier(Note).IO = 0

For i = 0 To 7
    Check4(i).Value = 0
Next i
End Sub

Private Sub Exit_Click()
 'on veut quitter
    
    'on réinitialise
    midiInReset ri
    midiInStop ri
    midiInClose ri
    
    'et on quitte
    Unload Me
End Sub

Private Function GetMCIErrorMessage(ErrorCode As Long) As String

Dim sBuffer As String
Dim lRet As Long

sBuffer = Space$(255)

lRet = mciGetErrorString(ErrorCode, sBuffer, 255&)

If lRet <> 0 Then
GetMCIErrorMessage = RemoveNulls(sBuffer)
Else
GetMCIErrorMessage = "An unknown MCI error occurred."
End If

End Function

Public Function RemoveNulls(ByVal sText As String) As String

'Returns all characters up to a null character.
'If the string does not contain a null character,
'the string is returned unmodified.

Dim lNullPos As Long

lNullPos = InStr(sText, vbNullChar)

If lNullPos Then
RemoveNulls = Left$(sText, lNullPos - 1)
Else
RemoveNulls = sText
End If

End Function

Private Sub Command1_Click()
    'On démarre l'écoute
    
    'Pour ne pas ouvrir plusieurs à la fois et ne pas planter
    Command1.Enabled = False
    List1.Enabled = False
    
    'On lance l'écoute du driver sélectionné
    midiInOpen ri, List1.ListIndex, AddressOf MidiIn_Event, 0, CALLBACK_FUNCTION
    midiInStart ri
    
    
End Sub

Private Sub Image1_MouseDown(Button As Integer, Shift As Integer, X As Single, Y As Single)
 Dim temp, temp2, i As Integer
 temp = Int(Int(X / (Image1.Width / 56)))
 temp2 = Int(temp / 7) 'calcul de l'octave
 temp = temp Mod 7 ' calcul de la note
 'Inscrit le nom de la note dans le champs texte
 Select Case temp
 
        Case 0
                Text2.Text = "C" & temp2
        Case 1
                Text2.Text = "D" & temp2
        Case 2
                Text2.Text = "E" & temp2
        Case 3
                Text2.Text = "F" & temp2
        Case 4
                Text2.Text = "G" & temp2
        Case 5
                Text2.Text = "A" & temp2
        Case 6
                Text2.Text = "B" & temp2
 
 End Select

 'Rappel des valeurs de sample enregistrées
 
 Note = temp2 * 7 + temp
 For i = 0 To 55
    Indicateur(i).BackColor = &H8000000F
    If Clavier(i).IO <> 0 Then Indicateur(i).BackColor = vbGreen
    If Clavier(i).fichier <> "" Then Indicateur(i).BackColor = vbGreen
 Next i
Indicateur(Note).BackColor = vbRed
Text3.Text = Clavier(Note).fichier

If Clavier(Note).loopMode Then
    Check1.Value = 1
Else
    Check1.Value = 0
End If

If Clavier(Note).monostable Then
    Check2.Value = 1
Else
    Check2.Value = 0
End If

If Check2.Value = 1 Then
    If Clavier(Note).continue Then
         Check3.Value = 1
    Else
        Check3.Value = 0
    End If
    Check3.Enabled = True
Else
    Check3.Enabled = False
End If

If Clavier(Note).fichier <> "" Then
Slider1.Value = Clavier(Note).Volume
Else
Slider1.Value = 1000
End If

'  Infos IO

Text5.Text = Clavier(Note).Duree
Text6.Text = Clavier(Note).Retard

For i = 0 To 7
    Check4(i).Value = 0
Next i

Check4(7).Value = Int(Clavier(Note).IO / 128) Mod 2
Check4(6).Value = Int(Clavier(Note).IO / 64) Mod 2
Check4(5).Value = Int(Clavier(Note).IO / 32) Mod 2
Check4(4).Value = Int(Clavier(Note).IO / 16) Mod 2
Check4(3).Value = Int(Clavier(Note).IO / 8) Mod 2
Check4(2).Value = Int(Clavier(Note).IO / 4) Mod 2
Check4(1).Value = Int(Clavier(Note).IO / 2) Mod 2
Check4(0).Value = Int(Clavier(Note).IO / 1) Mod 2

End Sub

Private Sub Info_Click()
MsgBox "(C)2010 Bertrand BALDACH" & vbCrLf & "application basé sur le code de capture Midi de " & vbCrLf & "(C)2003 Olivier RISACHER olivier@risacher.com http://www.rature.com", vbOKOnly, "Info"
End Sub

Private Sub Options_Click()
Form2.Show
End Sub

Private Sub Sauvegarder_Click()
CommonDialog1.FileName = ""
CommonDialog1.DialogTitle = "Sauver"
CommonDialog1.Filter = "Fichier EasySample (*.ezs) | *.ezs"
CommonDialog1.InitDir = App.Path
CommonDialog1.ShowSave
If CommonDialog1.FileName <> "" Then
Open CommonDialog1.FileName For Binary As #1
    Put #1, , Clavier
Close #1
Form1.Caption = "Easy Sample V" & App.Major & "." & App.Minor & " - " & CommonDialog1.FileName
End If
End Sub

Private Sub Slider1_Change()
mcistring = "setaudio MP3_Device" & Note & " volume to " & Slider1.Value '" & Clavier(Note) & "
lRet = mciSendString(mcistring, vbNullString, 0&, 0&)
End Sub

Private Sub Text1_Change()
Dim i, j As Integer
Dim pipo As String
    'analyse des entrées. il vaut mieux le faire ici et non pas dans la fonction de callback
    'car cela plante (raison inconnue)
    Dim MIDIString As String
    Dim tempNote As Byte
    Dim MidiMess As MidiMessage

   
      
    'on affiche ici le code hexa dans ce textbox parce que c'est ce code qu'on va utiliser
    MIDIString = "00000000" + Hex(Text1.Text)
    MIDIString = Right(MIDIString, 6)
    'Debug.Print MIDIString
    If Len(MIDIString) > 4 Then
        MidiMess.Channel = Right(MIDIString, 1)
        
        MidiMess.Note = Left(Right(MIDIString, 4), 2)
        MidiMess.Velocity = Mid(MIDIString, 1, Len(MIDIString) - 4)
        MidiMess.type = Left(Right(MIDIString, 2), 1)
    End If
    
    'si les deux premiers chiffres sont 50 (80 en décimal) on a appuyé sur une touche
    'si c'est 00 alors on a laché la touche.
    tempNote = ChercheNote(Val("&H" & Mid(MIDIString, 3, 2) & "&"))
     
        
        If Clavier(tempNote).monostable = False Then
            
            If MidiMess.Velocity <> "00" And MidiMess.type = "9" Then
                cmdPlayFirst (tempNote)
                gestIO (tempNote)
            End If

        Else 'Clavier(tempNote).monostable = true
                   
                If MidiMess.Velocity <> "00" And MidiMess.type = "9" Then
                    If Clavier(tempNote).stAte = False Then
                    'Appuyé
                        Clavier(tempNote).stAte = True
                        cmdPlayFirst (tempNote)
                        gestIO (tempNote)
                    Else
                        Clavier(tempNote).stAte = False
                        cmdStopFirst (tempNote)
                    End If
                End If
        End If
        
   'Gestion des IO
    
  
End Sub

Private Sub gestIO(laTempNote As Integer)
Dim pipo As String
Dim i, j As Integer
' variable IO
Dim maintenant As Long
    
    pipo = Dec2Bin(Clavier(laTempNote).IO)
    For j = 0 To 7
        MesIO(j) = Mid(pipo, 8 - j, 1)
    Next j
    
    For i = 0 To 7
    
        If MesIO(i) = True Then
            maintenant = Timer
            If IO_On(i) < (maintenant + Clavier(laTempNote).Retard / 1000) Then IO_On(i) = maintenant + (Clavier(laTempNote).Retard / 1000)
            If IO_Off(i) < (maintenant + Clavier(laTempNote).Retard / 1000 + Clavier(laTempNote).Duree / 1000) Then IO_Off(i) = (maintenant + (Clavier(laTempNote).Retard / 1000) + (Clavier(laTempNote).Duree / 1000))
        End If
    Next i

End Sub

Public Function Dec2Bin(ByVal DecVal As Byte) As String
    Dim i As Integer
    Dim sResult As String

    sResult = Space(8)
    For i = 0 To 7
        If DecVal And (2 ^ i) Then
            Mid(sResult, 8 - i, 1) = "1"
        Else
            Mid(sResult, 8 - i, 1) = "0"
        End If
    Next
    Dec2Bin = sResult
End Function
Public Function ExtractBit(ByVal Dec As Byte, ByVal MyBit As Integer) As Boolean
    ExtractBit = Dec And (2 ^ (MyBit))
End Function

Private Function ChercheNote(laNote As Byte) As Byte
'ChercheNote = Null
Dim i As Byte
For i = 0 To UBound(ListeNote)

If laNote = ListeNote(i) Then
    ChercheNote = i
    Exit For
End If
Next i

End Function

Private Function GetShortFileName(sFile As String) As String

Dim sBuffer As String
Dim lBytes As Long

sBuffer = String$(300, vbNullChar)
lBytes = GetShortPathName(sFile, sBuffer, Len(sBuffer))

If lBytes Then
GetShortFileName = RemoveNulls(sBuffer)
End If

End Function

Public Function GetPorts() As String

    Dim pcbNeeded As Long, pcReturned  As Long, Boucle As Integer
    Dim PortI2() As PORT_INFO_2
    Dim StrPortType As String, ret As String
   
    EnumPorts vbNullString, 2, 0, 0, pcbNeeded, pcReturned
    If pcbNeeded Then
        ReDim PortI2((pcbNeeded / SIZEOFPORT_INFO_2))
        If EnumPorts(vbNullString, 2, PortI2(0), pcbNeeded, pcbNeeded, pcReturned) Then
            For Boucle = 0 To (pcReturned - 1)
                With PortI2(Boucle)
                    StrPortType = ""
                    ret = ret & GetStrFromPtrA(.pPortName) & "|"
                End With
            Next
        End If
    End If
   
    If Len(ret) > 0 Then ret = Left(ret, Len(ret) - 1)
    GetPorts = ret
   
End Function

Private Function GetStrFromPtrA(lpszA As Long) As String
    GetStrFromPtrA = String$(lstrlenA(ByVal lpszA), 0)
    Call lstrcpyA(ByVal GetStrFromPtrA, ByVal lpszA)
End Function

Private Sub Timer1_Timer()

Dim i As Integer
Dim PortComData As Byte
Dim chAnge As Boolean
PortComData = 0
chAnge = False

For i = 0 To UBound(IO_On)
    If IO_On(i) <> 0 Then
        If Timer >= IO_On(i) Then
            Buffer_IO(i) = 1
            IO_On(i) = 0
            Check4(i).BackColor = &HFF
            chAnge = True
        End If
    End If
Next i

For i = 0 To UBound(IO_Off)
    If IO_Off(i) <> 0 Then
        If Timer >= IO_Off(i) Then
            Buffer_IO(i) = 0
            IO_Off(i) = 0
            Check4(i).BackColor = &H8000000F
            chAnge = True
        End If
    End If
Next i

If chAnge = True Then
    chAnge = False
    For i = 0 To 7
        PortComData = PortComData + Buffer_IO(i) * 2 ^ i
     Next i
    If MSComm1.PortOpen = True Then
    
        MSComm1.Output = Chr(85) + Chr(PortComData)
    End If
End If

End Sub

Private Sub Form_Unload(Cancel As Integer)
On Error Resume Next
'Very important to make sure any and all devices are closed
'when the app closes.
Call mciSendString("close all", vbNullString, 0&, 0&)

MSComm1.PortOpen = False
'Arrête la fonction de Callback
Subclass_Stop
End Sub

Conclusion :


Ce programme n'a pas de prétention à concurrencer des "Fruttyloop" et autres machines de guerre mais a le mérite d'être épuré et simple de prise en main.
Télécharger le projet

Codes Sources

S'inscrire maintenant

Vous n'êtes pas encore membre ?

inscrivez-vous, c'est gratuit et ça prend moins d'une minute !

Les membres obtiennent plus de réponses que les utilisateurs anonymes.

Le fait d'être membre vous permet d'avoir un suivi détaillé de vos demandes et codes sources.

Le fait d'être membre vous permet d'avoir des options supplémentaires.