Codice:
Option Explicit
'costante che determina quale scrit viene lanciato per il cambio del device audio
Const PERCORSO_SCRIPT = "C:\ChangeSoundPlaybackDefaultDevice.exe"
'costanti MIXER per strutture e funzioni
Const MMSYSERR_NOERROR = 0
Const MAXPNAMELEN = 32
Const MIXER_LONG_NAME_CHARS = 64
Const MIXER_SHORT_NAME_CHARS = 16
Const MIXER_GETLINEINFOF_COMPONENTTYPE = &H3&
Const MIXER_GETLINECONTROLSF_ONEBYTYPE = &H2&
Const MIXER_GETCONTROLDETAILSF_VALUE = &H0&
Const MIXER_SETCONTROLDETAILSF_VALUE = &H0&
'Const MIXERLINE_COMPONENTTYPE_DST_FIRST = &H0&
Const MIXERLINE_COMPONENTTYPE_DST_SPEAKERS = &H4
Const MIXERCONTROL_CONTROLTYPE_VOLUME = &H50030001
Const MIXERCONTROL_CT_CLASS_SWITCH = &H20000000
Const MIXERCONTROL_CT_UNITS_BOOLEAN = &H10000
Const MIXERCONTROL_CT_SC_SWITCH_BOOLEAN = &H0&
Const MIXERCONTROL_CONTROLTYPE_BOOLEAN = (MIXERCONTROL_CT_CLASS_SWITCH Or MIXERCONTROL_CT_SC_SWITCH_BOOLEAN Or MIXERCONTROL_CT_UNITS_BOOLEAN)
Const MIXERCONTROL_CONTROLTYPE_MUTE = (MIXERCONTROL_CONTROLTYPE_BOOLEAN + 2)
'-------------------------------------------------------------------------------------------------
'API Mixer
'-------------------------------------------------------------------------------------------------
'ottine il numero dei device audio presenti
Private Declare Function mixerGetNumDevs Lib "winmm.dll" () As Long
'apre il device audio e ne ottine handle
Private Declare Function mixerOpen Lib "winmm.dll" (phmx As Long, _
ByVal uMxId As Long, ByVal dwCallback As Long, ByVal dwInstance As Long, _
ByVal fdwOpen As Long) As Long
'ottine i dati per le strutture mixer
Private Declare Function mixerGetLineInfo Lib "winmm.dll" Alias _
"mixerGetLineInfoA" (ByVal hmxobj As Long, pmxl As MIXERLINE, _
ByVal fdwInfo As Long) As Long
'ottine i dati per le strutture mixer
Private Declare Function mixerGetLineControls Lib "winmm.dll" Alias _
"mixerGetLineControlsA" (ByVal hmxobj As Long, pmxlc As MIXERLINECONTROLS, _
ByVal fdwControls As Long) As Long
'ottine i dati per le strutture mixer
Private Declare Function mixerGetControlDetails Lib "winmm.dll" _
Alias "mixerGetControlDetailsA" (ByVal hmxobj As Long, _
pmxcd As MIXERCONTROLDETAILS, ByVal fdwDetails As Long) As Long
'setta i dati per le strutture mixer
Private Declare Function mixerSetControlDetails Lib "winmm.dll" (ByVal hmxobj _
As Long, pmxcd As MIXERCONTROLDETAILS, ByVal fdwDetails As Long) As Long
'chiude il mixer
Private Declare Function mixerClose Lib "winmm.dll" (ByVal hmx As Long) As Long
'copia le strutture in memoria
Private Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" _
(Destination As Any, Source As Any, ByVal Length As Long)
'-------------------------------------------------------------------------------------------------
'API Wave (in uscita)
'-------------------------------------------------------------------------------------------------
'restituisce il numero dei device audio wave installati
Private Declare Function waveOutGetNumDevs Lib "winmm" () As Long
'restitusce i dati della struttra caps per il wave
Private Declare Function waveOutGetDevCaps Lib "winmm.dll" Alias "waveOutGetDevCapsA" _
(ByVal uDeviceID As Long, lpCaps As WaveOutCaps, ByVal uSize As Long) As Long
'-------------------------------------------------------------------------------------------------
'API kernel32 (spostamento,allocazione,pulitura strutture/buffer in area di memoria RAM )
'-------------------------------------------------------------------------------------------------
'2 api per lo spostamento
Private Declare Sub CopyStructFromPtr Lib "kernel32" Alias "RtlMoveMemory" _
(struct As Any, ByVal ptr As Long, ByVal cb As Long)
Private Declare Sub CopyPtrFromStruct Lib "kernel32" Alias "RtlMoveMemory" _
(ByVal ptr As Long, struct As Any, ByVal cb As Long)
'3 api per area di memoria
Private Declare Function GlobalAlloc Lib "kernel32" (ByVal wFlags As Long, _
ByVal dwBytes As Long) As Long
Private Declare Function GlobalLock Lib "kernel32" (ByVal hmem As Long) As Long
Private Declare Function GlobalFree Lib "kernel32" (ByVal hmem As Long) As Long
'-------------------------------------------------------------------------------------------------
'Strutture Mixer per API
'-------------------------------------------------------------------------------------------------
Private Type MIXERCONTROL
cbStruct As Long
dwControlID As Long
dwControlType As Long
fdwControl As Long
cMultipleItems As Long
szShortName As String * MIXER_SHORT_NAME_CHARS
szName As String * MIXER_LONG_NAME_CHARS
lMinimum As Long
lMaximum As Long
Reserved(10) As Long
End Type
Private Type MIXERCONTROLDETAILS
cbStruct As Long
dwControlID As Long
cChannels As Long
item As Long
cbDetails As Long
paDetails As Long
End Type
Private Type MIXERCONTROLDETAILS_UNSIGNED
dwValue As Long
End Type
Private Type MIXERLINE
cbStruct As Long
dwDestination As Long
dwSource As Long
dwLineID As Long
fdwLine As Long
dwUser As Long
dwComponentType As Long
cChannels As Long
cConnections As Long
cControls As Long
szShortName As String * MIXER_SHORT_NAME_CHARS
szName As String * MIXER_LONG_NAME_CHARS
dwType As Long
dwDeviceID As Long
wMid As Integer
wPid As Integer
vDriverVersion As Long
szPname As String * MAXPNAMELEN
End Type
Private Type MIXERLINECONTROLS
cbStruct As Long
dwLineID As Long
dwControl As Long
cControls As Long
cbmxctrl As Long
pamxctrl As Long
End Type
Private Type InfoSchedeAudio
uMixerLine As MIXERLINE
hMixerHandle As Long
NomeSchedaAudio As String
End Type
'-------------------------------------------------------------------------------------------------
'Strutture Wave per API
'-------------------------------------------------------------------------------------------------
Private Type WaveOutCaps
ManufacturerID As Integer
ProductID As Integer
DriverVersion As Long
ProductName(1 To 32) As Byte
Formats As Long
Channels As Integer
Reserved As Integer
dwSupport As Long
End Type
Public Enum MUTE_CONTROL
SPEAKER_MUTE = 7
LINEIN_MUTE = 8
MICROPHONE_MUTE = 9
SYNTHESIZER_MUTE = 10
COMPACTDISC_MUTE = 11
WAVEOUT_MUTE = 12
AUXILIARY_MUTE = 13
End Enum
'-------------------------------------------------------------------------------------------------
'Variabili globali a livello classe
'-------------------------------------------------------------------------------------------------
'presenza headphone
Private m_HeadPhonePresent As Boolean
Private b_HeadPhontEvent As Boolean
'utilizzo script esterni
Private ScriptAudio As IWshRuntimeLibrary.WshShell
'controllo mixer
Private tMixerControls(20) As MIXERCONTROL
'matrice con i dati periferiche audio
Private tSchedeAudio() As InfoSchedeAudio
'evento che rileva la presenza o meno delle cuffie
Public Event AudioHeadPhoneChange(ByVal HeadPhone As Boolean)
'collegamento alla DLL per il sensore hardware jack cuffie se è presente
Private oObj as oObj
'inizializzazione mixer schede audio
'
Private Sub Class_Initialize()
Dim RetValue As Long
Dim MixerNumber As Integer
Dim hmx As Long
Dim TmpMixerLine As MIXERLINE
On Error GoTo lblerrorClass_Initialize
b_HeadPhontEvent = False
'qui dovete settare la variabile oggetto che punta alla DLL per il controllo del
'sensore hardware delle cuffie se è presente.
'Set oObj = New oObj 'prendetelo come esempio
Set ScriptAudio = New IWshRuntimeLibrary.WshShell
'inizializzo la variabile interna con il valore attuale del FEP.HeadPhonePresent
m_HeadPhonePresent = oFep.HeadPhonePresent
hmx = 0
For MixerNumber = 0 To mixerGetNumDevs - 1
RetValue = mixerOpen(hmx, MixerNumber, 0, 0, 0)
If RetValue <> MMSYSERR_NOERROR Then
Err.Raise vbObjectError, "B3AudioHeadPhone", "Apertura driver mixer schede audio fallita"
Exit Sub
End If
'per il set/get mute dei dispositivi audio mixer
RetValue = GetMixerControl(hmx, MIXERLINE_COMPONENTTYPE_DST_SPEAKERS, MIXERCONTROL_CONTROLTYPE_MUTE, tMixerControls(SPEAKER_MUTE))
TmpMixerLine.cbStruct = Len(TmpMixerLine)
TmpMixerLine.dwComponentType = MIXERLINE_COMPONENTTYPE_DST_SPEAKERS
RetValue = mixerGetLineInfo(hmx, TmpMixerLine, MIXER_GETLINEINFOF_COMPONENTTYPE)
If RetValue = MMSYSERR_NOERROR Then
'popolo array con i dati delle schede audio
ReDim Preserve tSchedeAudio(MixerNumber)
tSchedeAudio(MixerNumber).uMixerLine.cbStruct = TmpMixerLine.cbStruct
tSchedeAudio(MixerNumber).uMixerLine.dwComponentType = TmpMixerLine.dwComponentType
tSchedeAudio(MixerNumber).NomeSchedaAudio = Replace(TmpMixerLine.szPname, Chr(0), "")
tSchedeAudio(MixerNumber).hMixerHandle = hmx
End If
Next MixerNumber
Exit Sub
lblerrorClass_Initialize:
Err.Raise vbObjectError, "B3AudioHeadPhone", "errore apertura mixer delle schede audio installate"
End Sub
Private Sub Class_Terminate()
On Error Resume Next
Set ScriptAudio = Nothing
Set oObj = Nothing
On Error GoTo 0
End Sub
'proprietà che mi dice se sono inserite le cuffie
'
Public Property Get HeadPhonePresent() As Boolean
'qui va inserito la DLL che supporta la rilevazione delle cuffie se avete il sensore 'hardware presente sul jack
HeadPhonePresent = m_HeadPhonePresent
End Property
'funzione che mi setta attivazione del evento inserimento cuffie
'
Public Function HeadPhoneDetectionEvent(ByVal bAttivo As Boolean) As Boolean
b_HeadPhontEvent = bAttivo
HeadPhoneDetectionEvent = True
End Function
'funzione che setta il volume master della scheda audio caricata
'
Public Function SetVolume(ByVal VolumeLevel As Long, sAudioDevice As String) As Boolean
Dim uMixerControl As MIXERCONTROL
Dim uMixerLineControls As MIXERLINECONTROLS
Dim uDetails As MIXERCONTROLDETAILS
Dim uUnsigned As MIXERCONTROLDETAILS_UNSIGNED
Dim RetValue As Long
Dim hmem As Long
Dim indice As Long
On Error GoTo lblerrorSetVolume
Class_Initialize
' VolumeLevel value considero i valori da 0 a 100
If VolumeLevel < 0 Or VolumeLevel > 100 Then GoTo lblerrorSetVolume
'recupero handle della scheda audio da usare
For indice = LBound(tSchedeAudio) To UBound(tSchedeAudio)
If tSchedeAudio(indice).NomeSchedaAudio = sAudioDevice Then
Exit For
End If
Next indice
'riapro il mixer della scheda audio selezionata
RetValue = mixerGetLineInfo(tSchedeAudio(indice).hMixerHandle, tSchedeAudio(indice).uMixerLine, MIXER_GETLINEINFOF_COMPONENTTYPE)
'If RetValue <> MMSYSERR_NOERROR Then GoTo lblerrorSetAudioLevel
RetValue = mixerOpen(tSchedeAudio(indice).hMixerHandle, 0, 0, 0, 0)
If RetValue <> MMSYSERR_NOERROR Then GoTo lblerrorSetVolume
' Initializzo MIXERLINECONTROLS strucure e chiamo mixerGetLineControls
uMixerLineControls.cbStruct = Len(uMixerLineControls)
uMixerLineControls.dwLineID = tSchedeAudio(indice).uMixerLine.dwLineID 'uMixerLine.dwLineID
uMixerLineControls.dwControl = MIXERCONTROL_CONTROLTYPE_VOLUME
uMixerLineControls.cControls = 1
uMixerLineControls.cbmxctrl = Len(uMixerControl)
' Preparo il buffer a ricevere le proprietà del volume master
' e metto l'indirizzo nel uMixerLineControls.pamxctrl
hmem = GlobalAlloc(&H40, Len(uMixerControl))
uMixerLineControls.pamxctrl = GlobalLock(hmem)
uMixerControl.cbStruct = Len(uMixerControl)
RetValue = mixerGetLineControls(tSchedeAudio(indice).hMixerHandle, uMixerLineControls, _
MIXER_GETLINECONTROLSF_ONEBYTYPE)
If RetValue <> MMSYSERR_NOERROR Then GoTo lblerrorSetVolume
' Copio i dati del buffer nella struttura uMixerControl
CopyMemory uMixerControl, ByVal uMixerLineControls.pamxctrl, _
Len(uMixerControl)
GlobalFree hmem
hmem = 0
uDetails.item = 0
uDetails.dwControlID = uMixerControl.dwControlID
uDetails.cbStruct = Len(uDetails)
uDetails.cbDetails = Len(uUnsigned)
'Allocare un buffer in cui proprietà per il controllo del volume sono riportati
'e mettere il suo indirizzo in uDetails.paDetails
hmem = GlobalAlloc(&H40, Len(uUnsigned))
uDetails.paDetails = GlobalLock(hmem)
uDetails.cChannels = 1
uUnsigned.dwValue = CLng((VolumeLevel * uMixerControl.lMaximum) / 100)
CopyMemory ByVal uDetails.paDetails, uUnsigned, Len(uUnsigned)
' Setto il nuovo volume
RetValue = mixerSetControlDetails(tSchedeAudio(indice).hMixerHandle, uDetails, _
MIXER_SETCONTROLDETAILSF_VALUE)
GlobalFree hmem
hmem = 0
If RetValue <> MMSYSERR_NOERROR Then GoTo lblerrorSetVolume
mixerClose tSchedeAudio(indice).hMixerHandle
SetVolume = True
Exit Function
lblerrorSetVolume:
If tSchedeAudio(indice).hMixerHandle <> 0 Then mixerClose tSchedeAudio(indice).hMixerHandle
If hmem Then GlobalFree hmem
SetVolume = False
End Function
'funzione che restituisce un array di stringhe con il nome delle schede audio istallate
'
Public Function GetDeviceAudio() As String()
Dim sSchedeAudio() As String
Dim indice As Integer
For indice = 0 To UBound(tSchedeAudio)
ReDim Preserve sSchedeAudio(indice)
sSchedeAudio(indice) = tSchedeAudio(indice).NomeSchedaAudio
Next
GetDeviceAudio = sSchedeAudio
End Function
'funzione che setta un diverso driver audio
'
Public Function SetPlayBackDefaultDevice(ByVal sAudioDevice As String) As Long
Dim indice As Integer
Dim lRet As Long
Dim sWaveAudio() As String
Dim Caps As WaveOutCaps
On Error GoTo lblerrorSetPlayBackDefaultDevice
'controllo che il device è corretto
For indice = 0 To waveOutGetNumDevs - 1
waveOutGetDevCaps indice, Caps, Len(Caps)
'recupero tutti i nomi delle schede audio installate
ReDim Preserve sWaveAudio(indice)
sWaveAudio(indice) = StrConv(Caps.ProductName, vbUnicode)
sWaveAudio(indice) = Mid(sWaveAudio(indice), 1, Len(sAudioDevice))
sWaveAudio(indice) = Replace(sWaveAudio(indice), Chr(0), "")
sWaveAudio(indice) = Replace(sWaveAudio(indice), Chr(1), "")
sWaveAudio(indice) = Replace(sWaveAudio(indice), Chr(12), "")
'cerco quella passata come parametro
If sWaveAudio(indice) = sAudioDevice Then
lRet = ScriptAudio.Run(PERCORSO_SCRIPT & " " & sAudioDevice, 7, True)
If lRet <> 0 Then
SetPlayBackDefaultDevice = lRet
Exit Function
End If
Exit For
End If
Next indice
SetPlayBackDefaultDevice = 0
Exit Function
lblerrorSetPlayBackDefaultDevice:
'setto io errore per un crash software
SetPlayBackDefaultDevice = 99
End Function
'setta il mute del master volume della scheda audio passata per parametro
'
Public Function SetMute(ByVal sAudioDevice As String, ByVal bMuteState As Boolean) As Boolean
Dim lMute As Long
Dim indice As Integer
Dim Control As MUTE_CONTROL
Class_Initialize
Control = SPEAKER_MUTE
For indice = LBound(tSchedeAudio) To UBound(tSchedeAudio)
If tSchedeAudio(indice).NomeSchedaAudio = sAudioDevice Then
lMute = Abs(bMuteState)
SetMute = SetControlValue(tSchedeAudio(indice).hMixerHandle, tMixerControls(Control), lMute)
'MsgBox "setta audio:" & tSchedeAudio(indice).NomeSchedaAudio
Exit For
End If
Next indice
End Function
'mi dice se è attivo il mute sul master volume della scheda audio passata per parametro
'
Public Function GetMute(ByVal sAudioDevice As String) As Boolean
Dim indice As Integer
Dim Control As MUTE_CONTROL
For indice = LBound(tSchedeAudio) To UBound(tSchedeAudio)
If tSchedeAudio(indice).NomeSchedaAudio = sAudioDevice Then Exit For
Next indice
Control = SPEAKER_MUTE
GetMute = CBool(-GetControlValue(tSchedeAudio(indice).hMixerHandle, tMixerControls(Control)))
End Function
'------------------------------------------------------------------------------------------------------------
'evento del software che gestisce il sensore hardware delle cuffie
'come detto solo se avete il suddeto sensore hardware nella documentazione della macchiana avrete pure le indicazoni di quale DLL rirarvi dentro al codice.
Private Sub oObj_HeadPhonePresentChanged(ByVal HeadPhonePresent As Boolean)
If b_HeadPhontEvent Then RaiseEvent AudioHeadPhoneChange(HeadPhonePresent)
End Sub
'------------------------------------------------------------------------------------------------------------
'funzioni interne per mute mixer
Private Function GetControlValue(ByVal hmixer As Long, mxc As MIXERCONTROL) As Long
'Funzione che valorizza il valore di control.
Dim mxcd As MIXERCONTROLDETAILS
Dim vol As MIXERCONTROLDETAILS_UNSIGNED
Dim hmem As Long
Dim ret As Long
mxcd.item = 0
mxcd.dwControlID = mxc.dwControlID
mxcd.cbStruct = Len(mxcd)
mxcd.cbDetails = Len(vol)
hmem = GlobalAlloc(&H40, Len(vol))
mxcd.paDetails = GlobalLock(hmem)
mxcd.cChannels = 1
'leggo il valore di control
ret = mixerGetControlDetails(hmixer, mxcd, MIXER_GETCONTROLDETAILSF_VALUE)
'copia i dati nel buffer di control
CopyStructFromPtr vol, mxcd.paDetails, Len(vol)
If mxc.lMaximum > 100 Then
GetControlValue = (vol.dwValue * 100) / mxc.lMaximum - mxc.lMinimum
Else
GetControlValue = vol.dwValue
End If
GlobalFree (hmem)
End Function
Private Function SetControlValue(ByVal hmixer As Long, mxc As MIXERCONTROL, ByVal NewVolume As Long) As Boolean
'Setta il valore di control.
Dim mxcd As MIXERCONTROLDETAILS
Dim vol As MIXERCONTROLDETAILS_UNSIGNED
Dim hmem As Long
Dim ret As Long
mxcd.item = 0
mxcd.dwControlID = mxc.dwControlID
mxcd.cbStruct = Len(mxcd)
mxcd.cbDetails = Len(vol)
'Alloca un buffer per il valore del buffer di control.
hmem = GlobalAlloc(&H40, Len(vol))
mxcd.paDetails = GlobalLock(hmem)
mxcd.cChannels = 1
' valore di setup, usa la percentuale del range se il massimo è piu grande di 100
If mxc.lMaximum > 100 Then
vol.dwValue = NewVolume * (mxc.lMaximum \ 100)
Else
vol.dwValue = NewVolume
End If
If vol.dwValue > mxc.lMaximum Then vol.dwValue = mxc.lMaximum
If vol.dwValue < mxc.lMinimum Then vol.dwValue = mxc.lMinimum
' copia i dati nel valore del buffer di control
CopyPtrFromStruct mxcd.paDetails, vol, Len(vol)
' setta il valore di control
ret = mixerSetControlDetails(hmixer, mxcd, MIXER_SETCONTROLDETAILSF_VALUE)
GlobalFree (hmem)
If ret = MMSYSERR_NOERROR Then SetControlValue = True
End Function
Private Function GetMixerControl(ByVal hmixer As Long, ByVal componentType As Long, ByVal ctrlType As Long, ByRef mxc As MIXERCONTROL) As Long
' Questa funzione tenta di ottenere un controllo del mixer.
Dim mxlc As MIXERLINECONTROLS
Dim mxl As MIXERLINE
Dim hmem As Long
Dim ret As Long
mxl.cbStruct = Len(mxl)
mxl.dwComponentType = componentType
' Ottiene la linea corrispondente al tipo di componente
ret = mixerGetLineInfo(hmixer, mxl, MIXER_GETLINEINFOF_COMPONENTTYPE)
If ret = MMSYSERR_NOERROR Then
mxlc.cbStruct = Len(mxlc)
mxlc.dwLineID = mxl.dwLineID
mxlc.dwControl = ctrlType
mxlc.cControls = 1
mxlc.cbmxctrl = Len(mxc)
' Alloca un buffer per il control
hmem = GlobalAlloc(&H40, Len(mxc))
mxlc.pamxctrl = GlobalLock(hmem)
mxc.cbStruct = Len(mxc)
' restituisce il control
ret = mixerGetLineControls(hmixer, mxlc, MIXER_GETLINECONTROLSF_ONEBYTYPE)
If ret = MMSYSERR_NOERROR Then
GetMixerControl = True
' Copia il control nella struttura di destinazione
CopyStructFromPtr mxc, mxlc.pamxctrl, Len(mxc)
Else
GetMixerControl = False
End If
GlobalFree (hmem)
Exit Function
End If
GetMixerControl = False
End Function
Lo scrit fatto in autoit è il seguente:
Codice:
$ret = 1
If $CmdLine[0] > 0 Then
$pid = Run("control.exe mmsys.cpl,,2")
If $pid = 0 Then
$ret = 2
Else
$rc = WinWait("[CLASS:#32770]","",5)
If $rc = 0 Then
$ret = 3
Else
;WinMove("[CLASS:#32770]","",-10000,-10000)
$rc = controlsend("[CLASS:#32770]","","[CLASS:ComboBox; INSTANCE:1]",$CmdLine[1])
If $rc = 0 Then
$ret = 4
Else
$rc = controlclick("[CLASS:#32770]","","[CLASS:Button; INSTANCE:11]")
If $rc = 0 Then
$ret = 5
Else
$ret = 0
Endif
EndIf
EndIf
EndIf
EndIf
Exit $ret
Compilate con autoit e create exe dello script mettete il codice della classe in una DLL o OCX createvi un tester e avrete il controllo del volume,mute,rilevamento cuffie inserite o meno (sempre a fronte del sensore hardware) e cambio del device audio in caso di più di una scheda audio presente.
1
Rispondi Citando
soluzione
