' und jetzt die eigentliche Routine -
'
' Lautstärkeänderung 0 - 100 %
'  - Rückgabewert = True wenn erfolgreich
Public Function SetVolume(VolumeLevel As Long) As Boolean
    Dim hmx As Long
    Dim uMixerLine As MIXERLINE
    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
 
    If VolumeLevel < 0 Or VolumeLevel > 100 Then GoTo Error
 
    RetValue = mixerOpen(hmx, 0, 0, 0, 0)
    If RetValue <> MMSYSERR_NOERROR Then GoTo Error
 
    uMixerLine.cbStruct = Len(uMixerLine)
    uMixerLine.dwComponentType = MIXERLINE_COMPONENTTYPE_DST_SPEAKERS
    RetValue = mixerGetLineInfo(hmx, uMixerLine, _
        MIXER_GETLINEINFOF_COMPONENTTYPE)
    If RetValue <> MMSYSERR_NOERROR Then GoTo Error
 
    uMixerLineControls.cbStruct = Len(uMixerLineControls)
    uMixerLineControls.dwLineID = uMixerLine.dwLineID
    uMixerLineControls.dwControl = MIXERCONTROL_CONTROLTYPE_VOLUME
    uMixerLineControls.cControls = 1
    uMixerLineControls.cbmxctrl = Len(uMixerControl)
 
    hMem = GlobalAlloc(&H40, Len(uMixerControl))
    uMixerLineControls.pamxctrl = GlobalLock(hMem)
    uMixerControl.cbStruct = Len(uMixerControl)
    RetValue = mixerGetLineControls(hmx, uMixerLineControls, _
        MIXER_GETLINECONTROLSF_ONEBYTYPE)
    If RetValue <> MMSYSERR_NOERROR Then GoTo Error
    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)
    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)
    RetValue = mixerSetControlDetails(hmx, uDetails, _
        MIXER_SETCONTROLDETAILSF_VALUE)
    GlobalFree hMem
    hMem = 0
    If RetValue <> MMSYSERR_NOERROR Then GoTo Error
 
    mixerClose hmx
    SetVolume = True
    Exit Function
 
Error:
    ' Fehlerbehandlung
    If hmx <> 0 Then mixerClose hmx
    If hMem Then GlobalFree hMem
    SetVolume = False
 
End Function

cu
JennyB
___________________________________________________________________
Some days are diamond - some days are stone ...