Tällä koodilla voit säätää kaikkia ääniä, jotkaa kuuluvat kaijuttimista. Lisää formiin VSCroll:li.
Option Explicit Private hMixerHandle As Long Private uMixerControls(20) As MIXERCONTROL Private Const MMSYSERR_NOERROR = 0 Private Const MAXPNAMELEN = 32 Private Const MIXER_LONG_NAME_CHARS = 64 Private Const MIXER_SHORT_NAME_CHARS = 16 Private Const MIXER_GETLINEINFOF_COMPONENTTYPE = &H3& Private Const MIXER_GETLINECONTROLSF_ONEBYTYPE = &H2& Private Const MIXER_SETCONTROLDETAILSF_VALUE = &H0& Private Const MIXERLINE_COMPONENTTYPE_DST_FIRST = &H0& Private Const MIXERLINE_COMPONENTTYPE_DST_SPEAKERS = &H4 Private Const MIXERCONTROL_CONTROLTYPE_VOLUME = &H50030001 Private Const MIXER_GETCONTROLDETAILSF_VALUE = &H0& 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 Private Declare Function mixerGetLineInfo Lib "winmm.dll" Alias "mixerGetLineInfoA" (ByVal hmxobj As Long, pmxl As MIXERLINE, ByVal fdwInfo As Long) As Long Private Declare Function mixerGetLineControls Lib "winmm.dll" Alias "mixerGetLineControlsA" (ByVal hmxobj As Long, pmxlc As MIXERLINECONTROLS, ByVal fdwControls As Long) As Long Private Declare Function mixerSetControlDetails Lib "winmm.dll" (ByVal hmxobj As Long, pmxcd As MIXERCONTROLDETAILS, ByVal fdwDetails As Long) As Long Private Declare Function mixerClose Lib "winmm.dll" (ByVal hmx As Long) As Long Private Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (Destination As Any, Source As Any, ByVal Length As Long) 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 Private Declare Function mixerGetNumDevs Lib "winmm.dll" () As Long Private Declare Sub CopyStructFromPtr Lib "kernel32" Alias "RtlMoveMemory" (struct As Any, ByVal ptr As Long, ByVal cb As Long) Private Declare Function mixerGetControlDetails Lib "winmm.dll" Alias "mixerGetControlDetailsA" (ByVal hmxobj As Long, pmxcd As MIXERCONTROLDETAILS, ByVal fdwDetails As Long) As Long Public Enum VOL_CONTROL SPEAKER = 0 End Enum 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 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: If hmx <> 0 Then mixerClose hmx If hMem Then GlobalFree hMem SetVolume = False End Function Private Sub Form_Load() VScroll1.Max = 100 VScroll1.Min = 0 Me.Show OpenMixer (0) If GetVolume(SPEAKER) >= 0 Or GetVolume(SPEAKER) <= 100 Then VScroll1.Value = 100 - GetVolume(SPEAKER) Else VScroll1.Value = 0 End If CloseMixer End Sub Private Sub VScroll1_Change() SetVolume (100 - VScroll1.Value) End Sub Public Function OpenMixer(ByVal MixerNumber As Long) As Long Dim ret As Long If MixerNumber < 0 Or MixerNumber > mixerGetNumDevs - 1 Then Exit Function ret = mixerOpen(hMixerHandle, MixerNumber, 0, 0, 0) If ret <> MMSYSERR_NOERROR Then Exit Function ret = GetMixerControl(hMixerHandle, MIXERLINE_COMPONENTTYPE_DST_SPEAKERS, MIXERCONTROL_CONTROLTYPE_VOLUME, uMixerControls(SPEAKER)) OpenMixer = True End Function Private Function CloseMixer() As Long CloseMixer = mixerClose(hMixerHandle) hMixerHandle = 0 End Function Private Function GetVolume(Control As VOL_CONTROL) As Long GetVolume = GetControlValue(hMixerHandle, uMixerControls(Control)) End Function Private Function GetMixerControl(ByVal hMixer As Long, ByVal componentType As Long, ByVal ctrlType As Long, ByRef mxc As MIXERCONTROL) As Long Dim mxlc As MIXERLINECONTROLS Dim mxl As MIXERLINE Dim hMem As Long Dim ret As Long mxl.cbStruct = Len(mxl) mxl.dwComponentType = componentType 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) hMem = GlobalAlloc(&H40, Len(mxc)) mxlc.pamxctrl = GlobalLock(hMem) mxc.cbStruct = Len(mxc) ret = mixerGetLineControls(hMixer, mxlc, MIXER_GETLINECONTROLSF_ONEBYTYPE) If ret = MMSYSERR_NOERROR Then GetMixerControl = True CopyStructFromPtr mxc, mxlc.pamxctrl, Len(mxc) Else GetMixerControl = False End If GlobalFree (hMem) Exit Function End If GetMixerControl = False End Function Private Function GetControlValue(ByVal hMixer As Long, mxc As MIXERCONTROL) As Long 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 ret = mixerGetControlDetails(hMixer, mxcd, MIXER_GETCONTROLDETAILSF_VALUE) 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
Aihe on jo aika vanha, joten et voi enää vastata siihen.