AUGMENTER, BAISSER, LE VOLUME WAVE, ET BALANCE !

'=================================
' REGLAGE DU VOLUME WAVE
'************************
'
'par Proger - 2002
'samedi 18 mai 2002
'mise à jour du jeudi 7 août 2003 : remplacement de l'usage de Hex() par du bit-masking, plus rapide
'mise à jour du 21 février 2004 : fonctions RetGain pour avoir le volume en dB
'
'Source : déclaration des API par allapi.net


Option Explicit
DefLng A-Z

'les 2 apis nécessaire au volume
Declare Function waveOutSetVolume Lib "winmm.dll" (ByVal uDeviceID As Long, ByVal dwVolume As Long) As Long
Declare Function waveOutGetVolume Lib "winmm.dll" (ByVal uDeviceID As Long, lpdwVolume As Long) As Long

'les 2 apis et le Type pour récupérer les périph' audio
Declare Function waveOutGetNumDevs Lib "winmm.dll" () As Long
Declare Function waveOutGetDevCaps Lib "winmm.dll" Alias "waveOutGetDevCapsA" (ByVal uDeviceID As Long, lpCaps As WAVEOUTCAPS, ByVal uSize As Long) As Long

Type WAVEOUTCAPS
    wMid As Integer
    wPid As Integer
    vDriverVersion As Long
    szPname As String * 260
    dwFormats As Long
    wChannels As Integer
    dwSupport As Long
End Type


Function GetDev(NameList() As String) As Long
'recupère le nom des périph' de lecture audio
'GetDev renvoie la longueur de la liste
'La liste NameList() contiendra le nom du(des) périph'
Dim BufLng As Long
Dim exeAPI As Long
Dim CntDev As Long
Dim Temp As WAVEOUTCAPS
Dim i 'as long ==> deflng a-z

    CntDev = waveOutGetNumDevs
    If CntDev = 0 Then
        GetDev = 0
        Exit Function
        
    Else
        ReDim NameList(1 To CntDev) As String
        BufLng = 274
        
        For i = 1 To CntDev
            Temp.szPname = ""
            exeAPI = waveOutGetDevCaps(i - 1, Temp, BufLng)
            'recupère le nom du périph
            NameList(i) = Left$(Temp.szPname, InStr(1, Temp.szPname, Chr$(0), vbBinaryCompare))
        Next i
        
        GetDev = CntDev
        
    End If
    
End Function

Function GetVolume(VolG As Integer, VolD As Integer, ByVal CSon As Long) As Long
'récupère la valeur gauche et droite du volume (dans VolG et VolD) de la carte son CSon
'si vous n'avez qu'une carte son, donnez comme valeur CSon = 0
Dim ValVol As Long
Dim exeAPI As Long
Dim TempG, TempD

    exeAPI = waveOutGetVolume(CSon, ValVol)
    'ValVol contient la valeur du volume de la façon suivante:
    'ValVol fait 4 octets de long, les deux premiers contiennent
    'la valeur du volume de droite, et les deux derniers gauche
    
    'Récupération par bit-masking
    TempG = (ValVol And 65535)
    
    'on remet le champ droite sur l'intervalle 0-65535
    TempD = ((ValVol And -65536) / 65536) And 65535
    
    'et on converti en type Integer, façon la plus exploitable qui soit
    VolG = CInt(TempG - 32768)
    VolD = CInt(TempD - 32768)
    'on envoie aussi la valeur brut du volume, on sais jamais :)
    GetVolume = ValVol
    
End Function

Function SetVolume(ByVal VolG As Integer, ByVal VolD As Integer, ByVal CSon As Long)
'envoie la valeur gauche et droite du volume (contenu dans VolG et VolD) de la carte son CSon
'si vous n'avez qu'une carte son, donnez comme valeur CSon = 0
Dim SetVol As Long
Dim exeAPI As Long
Dim TempG, TempD

    'conversion en type long (car la valeur va de 0 à 65535)
    TempG = CLng(VolG) + 32768
    TempD = CLng(VolD) + 32768
    
    'on place TempD sur les 2 premiers octets (en faisant abstraction du signe)
    If TempD < 32768 Then
        TempD = TempD * 65536
    Else
        TempD = ((TempD - 32768) * 65536) Or &H80000000  'rajoute le signe
    End If
    
    'concatenation des deux valeurs (gauche et droite) par opération booléenne
    SetVol = TempG Or TempD
    
    'envoi a la carte son
    exeAPI = waveOutSetVolume(CSon, SetVol)
    SetVolume = SetVol 'indication a l'utilisateur de ce qu'il a envoyé :)
    
End Function

Function SetVolBalance(ByVal ValGini As Integer, ByVal ValDini As Integer, ValBalance As Byte, NewG As Integer, NewD As Integer) As Long
'Indiquez la valeur du son gauche et droite (avec GetVolume...),
'ainsi que la valeur de la balance
'Balance : 0 = a fond à gauche, 128 = milieu, 255 = a fond à droite
'la fonction sortira les nouvelles valeurs de gauche et droite (NewG et NewD), et ...c tout
Dim TempG As Long
Dim TempD As Long
Dim OldBalance As Byte

    'on remet les valeur allant de -32768 à 32767 vers 0 à 65535
    TempG = CLng(ValGini) + 32768
    TempD = CLng(ValDini) + 32768
    
    'etape 1 : on rétablie la balance à 128 (si elle ne l'est pas)
    OldBalance = GetVolBalance(ValGini, ValDini)
    If OldBalance <> 128 Then
        If OldBalance < 128 Then 'retablissons le volume de droite
            TempD = TempG
        ElseIf OldBalance > 128 Then 'retablissons le volume de gauche
            TempG = TempD
        Else
            'ce cas n'est pas censé exister.
        End If

    Else
        'la balance actuelle est de 128 (fiou!)
    End If
    
    TempD = TempD * (ValBalance / 128)
    TempG = TempG * (Abs(ValBalance - 256)) / 128

    'antibug division par zéro
    If TempG < 0 Then TempG = 0
    If TempD < 0 Then TempD = 0
    If TempG > 65535 Then TempG = 65535
    If TempD > 65535 Then TempD = 65535
    NewD = CInt(TempD - 32768)
    NewG = CInt(TempG - 32768)
    
End Function

Function GetVolBalance(ValG As Integer, ValD As Integer) As Byte
'retourne la valeur de la balance dans une variable de type Byte
'en fonction de gauche et droite (récupérer par GetVolume...)
'Balance : 0 = a fond à gauche, 128 = milieu, 255 = a fond à droite
Dim TmpG As Long
Dim TmpD As Long

    'on remet les valeur allant de -32768 à 32767 vers 0 à 65535
    TmpG = CLng(ValG) + 32768
    TmpD = CLng(ValD) + 32768
        
        
    If TmpG = 0 And TmpD > 0 Then
        'si y'a pas de signale a gauche, c'est que c'est à fond a droite...
        GetVolBalance = 255
        
    ElseIf TmpD = 0 And TmpG > 0 Then
        '...et inversement
        GetVolBalance = 0
        
    ElseIf (TmpD - TmpG) = 0 Then
        GetVolBalance = 128
        
    Else
        'on récupère l'échelle de différence entre droite et gauche,
        'puis on réduit l'échelle entre 0 et 255
        GetVolBalance = CByte((TmpD - TmpG + 65536) * 256 / 131072)
        
    End If
    
End Function

Function GetVolMoy(CSon As Long, ValBalnce As Byte) As Integer
'fonction tout-en-un pour récuperer le volume façon windows : volume + balance
'de la carte son CSon (si vous n'avez qu'une carte, mettre CSon = 0)
'le volume est renvoyé dans GetVolMoy, et la balance dans ValBalnce
Dim VolG As Integer
Dim VolD As Integer
Dim BigVal As Long

    BigVal = GetVolume(VolG, VolD, CSon)
    ValBalnce = GetVolBalance(VolG, VolD)
    GetVolMoy = ((CLng(VolG) + CLng(VolD)) / 2)

End Function

Function SetVolMoy(CSon As Long, ByVal VolMoyen As Integer, ValBlnc As Byte) As Long
'fonction tout-en-un pour envoyer une nouvelle valeur de volume en fonction
'du "volume moyen" et de la balance
'la fonction renvoie la valeur Long envoyé à la carte son
Dim VolFG As Integer
Dim VolFD As Integer
Dim i As Long

    i = SetVolBalance(VolMoyen, VolMoyen, ValBlnc, VolFG, VolFD)
    SetVolMoy = SetVolume(VolFG, VolFD, CSon)

End Function

Function RetGain(ByVal CurVol As Long) As Double
'renvoi la valeur du volume en décibel (16 bits)
'nota : la fonction log() de VB6 retourne le log népérien, alors on converti
' en log décimal en divisant par ln(10) = 2.3 ...

    If CurVol > 0 Then
        RetGain = (20 * (Log(CurVol) / 2.30258509299405)) - 96.3
    Else
        RetGain = -96.4
    End If
    
End Function

Function InvGain(ByVal dB As Double) As Integer
'renvoi une valeur 16bits à partir du gain
'nota : le gain est compris entre 0 et -97

    If dB <= -96.3 Then
        InvGain = -32768
    ElseIf dB < 0 Then
        InvGain = (10 ^ ((dB + 96.3) / 20)) - 32768
    Else
        InvGain = 32767
    End If

End Function

Télécharger le zip