JEUX DE LUMIÈRE À LED

'========================================
' Form demo pour le module WaveInBIO.bas
'**********
'
'Par Proger

'c'est hélas l'interface, et particulièrement les graphiques, qui sont lent...
Dim led As Integer
Dim zmin As Double
Dim zmax As Double
Dim xck As Long
Dim Loff As Long
Option Explicit

'pour donner une priorité haute au process
'(ca garanti que l'enregistrement continue meme si l'ordinateur est subitement occupé)
Private Declare Function GetCurrentProcess Lib "kernel32" () As Long
Private Declare Function SetPriorityClass Lib "kernel32" (ByVal hProcess As Long, ByVal dwPriorityClass As Long) As Long
Private Const HIGH_PRIORITY_CLASS = &H80
Private Const NORMAL_PRIORITY_CLASS = &H20
Private frmProcess As Long

'l'affichage dynamique ou affichage calme (réduit la consommation CPU)
'certaines infos sont illisibles si elles sont mises à jour trop souvent.
Private Const REFRESH_UPDATE = 2
Private RefreshCount As Long

'pour le VU-metre "adouci"
Private KLG As Double
Private KIG As Double
Private RIG As Double
Private ItM As Double

'pour le FFT, analyse spectrale et spectrogramme
Private pBuf As IPictureDisp
Private Declare Function BitBlt Lib "gdi32" (ByVal hDestDC As Long, ByVal x As Long, ByVal y As Long, ByVal nWidth As Long, ByVal nHeight As Long, ByVal hSrcDC As Long, ByVal xSrc As Long, ByVal ySrc As Long, ByVal dwRop As Long) As Long
Private ColoTable(0 To 520) As Long
Private tFFTw As Long
Private tFFTh As Long

'pour la gestion des parcelles de fichiers
Private BaseName As String 'nom de base du fichier, partie variable avec des ####
Private CurrName As String
Private DebTime As Date    'marqueur temps, utilisé pour savoir depuis combien de temps ca enregistre
Private TimePerP As Long   'secondes par fragments (défaut = 600, voir Form_Load)
Private NameIndex As Long  'compteur de fichiers
Private NameChOf As Long   'offset de la zone variable ####
Private NameChLn As Long   'longueur de la zone variable
Private NNM As Boolean     'petit flag pour le timer : mise à jour du nom de fichier
Private TimeRec As Long    'totaliseur du nombre de secondes d'enregistrement
Private TimeRecF As Long   'petit flag pour le timer : quand mettre à jour
Private Sub Form_Load()
Open App.Path + "\sortie.txt" For Output As #1
Dim Cson() As String
Dim i As Long

    'préparation interface carte son
    Combo1.Clear
    For i = 1 To GetInDev(Cson())
        Combo1.AddItem Cson(i)
    Next i
    Combo1.Text = Cson(1)
    
    'préparation interface echantillonnage
    Combo2.AddItem 8000
    Combo2.AddItem 11025
    Combo2.AddItem 16000
    Combo2.AddItem 22050
    Combo2.AddItem 32000
    Combo2.AddItem 44100
    Combo2.AddItem 48000
    Combo2.AddItem 88200
    Combo2.AddItem 96000
    Combo2.ListIndex = 3


    

    'autres variables
    TimePerP = 600
    xck = 0
    


End Sub
Private Function NouvelleSession(NomFichier As String) As String
'nouvelle session d'enregistrement.
Dim p As Long, t As Long, i As Long

    'vérifie l'extension
    If LCase$(Right$(NomFichier, 4)) <> ".wav" Then
        If InStrRev(NomFichier, ".") = Len(NomFichier) - 3 Then
            'mauvaise extension
            BaseName = Mid$(BaseName, 1, Len(NomFichier) - 4) & ".wav"
        Else
            'pas d'extension
            BaseName = NomFichier & ".wav"
        End If
    Else
        BaseName = NomFichier
    End If
    
    'vérifie la présence de la zone variable ####
    p = InStr(1, NomFichier, "#", vbBinaryCompare)
    t = InStrRev(NomFichier, "#", , vbBinaryCompare) - p + 1
    If p = 0 Then
        NouvelleSession = "Nom invariant !!"
        'si le nom est invariant, on considère n'enregistrer que dans 1 fichier.
        'anti-plantage : calcul de la durée max possible avant que le fichier dépasse 2Go :
        TimePerP = 2147483640 \ CLng(Combo2.List(Combo2.ListIndex)) * 2
        CurrName = BaseName
        Exit Function
    End If
    
    'mise à jour des variables locales pour le changement de noms
    CurrName = BaseName
    NameChOf = p
    NameChLn = t
    NameIndex = 1
    NNM = False
    
    'recherche s'il n'y a pas d'anciens fichiers avec ce format,
    'décale l'index automatique en conséquence.
    Do
        Mid(CurrName, NameChOf, NameChLn) = Format$(NameIndex, String$(NameChLn, "0"))
        If Dir(CurrName, vbNormal) = "" Then Exit Do
        NameIndex = NameIndex + 1
    Loop
    
    NouvelleSession = CurrName

End Function

Private Function HMS(ByVal s As Long) As String
'conversion de secondes en heures:minutes:secondes sans passer par les strings...
'extra-rapide :) les divisions sont en fait des rotations de bits shl/sal en asm
Dim i As Long, h As Long, m As Long
Dim osB(1 To 8) As Byte

    osB(3) = 58 ' ":"
    osB(6) = 58

    m = s \ 60
    s = s - m * 60
    h = m \ 60
    m = m - h * 60
    
    i = s \ 10
    osB(8) = 48 + (s - i * 10)
    osB(7) = 48 + i
    
    i = m \ 10
    osB(5) = 48 + (m - i * 10)
    osB(4) = 48 + i
    
    i = h \ 10
    osB(2) = 48 + (h - i * 10)
    osB(1) = 48 + i
        
    HMS = StrConv(osB(), vbUnicode)

End Function



Private Sub Check1_Click()
Dim uFrq As Long

    If Check1.Value = 1 Then
        'augmente la priorité système
        frmProcess = GetCurrentProcess()
        Call SetPriorityClass(frmProcess, HIGH_PRIORITY_CLASS)
        
        'initialise l'acquisition et écoute
        uFrq = CLng(Combo2.List(Combo2.ListIndex))
        If Not VU_StartInput(CBool(Check5.Value), uFrq) Then  '<== DEMARRAGE DE L'ECOUTE
            Check1.Value = False
            Exit Sub
        End If
        

        
        Timer1.Enabled = True
        Combo1.Enabled = False
        Combo2.Enabled = False
        Check5.Enabled = False
    Else

        Timer1.Enabled = False
        VU_StopInput 'stoppe proprement l'écoute
        
        'remet la priorité en normale (pratique si le programme commence à déconner)
        frmProcess = GetCurrentProcess()
        Call SetPriorityClass(frmProcess, NORMAL_PRIORITY_CLASS)
        
        Combo1.Enabled = True
        Combo2.Enabled = True
        Check5.Enabled = True
    End If
    
End Sub


Private Sub Check3_Click()

    VU_DoFFT = CBool(Check3.Value)

End Sub

Private Sub Check4_Click()

    VU_DoCut = CBool(Check4.Value)

End Sub

Private Sub Combo1_Click()
VU_Device = Combo1.ListIndex

End Sub

Private Sub Command1_Click()
    Shell "sndvol32 -R -D " & Combo1.ListIndex, vbNormalFocus
End Sub





Private Sub HScroll1_Change()
Call HScroll1_Scroll
End Sub

Private Sub HScroll1_Scroll()
    VU_Boost = (CDbl(HScroll1.Value)) / 20
    Label3.Caption = Format$(VU_Boost, "#0.00") & " dB"
End Sub



Private Sub Timer1_Timer()
Dim dGain As Double, smG As Double
Dim i As Long, c As Long, p As Long, upd As Boolean


    'moulinette
    upd = VU_Update() '<== PRINCIPALE FONCTION GERANT L'ACQUISITION DU SON

    'VU-metre
    dGain = VU_Gain
    'Print #1, dGain


    
    
If upd Then 'les actions suivantes ne sont mise à jour que s'il y a eu un nouvel enregistrement

    RefreshCount = RefreshCount + 1
    p = (RefreshCount Mod REFRESH_UPDATE) = 0

    'mise à jour paramètres VU-metre
    If p Then
    'Label1.Caption = Format$(dGain, "#00")
    If dGain > zmax Then zmax = dGain
    If dGain < zmin Then zmin = dGain
    If zmax > 0 Then zmax = zmax - 10
    If zmin < 65999 Then zmin = zmin + 10
    Me.Caption = Str$(zmin) + " : " + Str$(zmax) + "  =  " + Str$(zmax - zmin)
    'noir=0
    'Rouge=1
    'Jaune=5
    'vert=4
    'Cyan=6
    'Bleu=2
    'Violet=3
    'Blanc=7
    
    
    
    led = 0
    If dGain > (zmin + (zmax - zmin) / 8) Then led = 1
    If dGain > (zmin + 2 * (zmax - zmin) / 8) Then led = 5
    If dGain > (zmin + 3 * (zmax - zmin) / 8) Then led = 4
    If dGain > (zmin + 4 * (zmax - zmin) / 8) Then led = 6
    If dGain > (zmin + 5 * (zmax - zmin) / 8) Then led = 2
    If dGain > (zmin + 6 * (zmax - zmin) / 8) Then led = 3
    If dGain > (zmin + 7 * (zmax - zmin) / 8) Then led = 7
    
    
    If led = 0 Then Form1.BackColor = 0
    If led = 1 Then Form1.BackColor = vbRed
    If led = 5 Then Form1.BackColor = vbYellow
    If led = 4 Then Form1.BackColor = vbGreen
    If led = 6 Then Form1.BackColor = vbCyan
    If led = 2 Then Form1.BackColor = vbBlue
    If led = 3 Then Form1.BackColor = vbMagenta
    If led = 7 Then Form1.BackColor = vbWhite
    
    'If (led = 7) Or (led = 3) Or (led = 2) Or (led = 6) Then
    '    SaveSetting "HWPorte", "MAIN", "TX", "121"
    '    Loff = 0
    'Else
    '    If Loff < 10 Then Loff = Loff + 1
    'End If
    
    'If Loff = 9 Then
    '    SaveSetting "HWPorte", "MAIN", "TX", "98"
        
    'End If
    
    Out 888, led
    End If
End If 'fin update
    
End Sub

Private Sub Form_Unload(Cancel As Integer)
Out 888, 0
End
End Sub

Private Sub Timer2_Timer()
If xck > 9 Then Exit Sub
Me.Caption = Str$(10 - xck)
xck = xck + 1
If xck = 9 Then Check1.Value = 1
End Sub

Télécharger le zip