Soyez le premier à donner votre avis sur cette source.
Vue 23 320 fois - Téléchargée 1 323 fois
'================================= ' 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
14 déc. 2005 à 17:45
Ya un buffer overflow au niveau de la ligne
GetVolBalance = CByte((TmpD - TmpG + 65536) * 256 / 131072)
Bhen sinon c'est interessant quand meme ! :)
8 déc. 2005 à 17:27
@+
26 mars 2003 à 16:25
1 juil. 2002 à 14:51
je vais tester ça sur un ordi qui a une carte son en état de marche :D
18 mai 2002 à 22:52
Cette nouvelle version s'intègre très facilement dans n'importe quel progs (car tout tiens dans un module), et vous permet de contrôler le volume style "winamp" ou style "DJ" de toutes vos cartes sons.
PS : je ne connais pas le comportement de ce code si vous utilisez des cartes sons 8-bits, ...
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.