How To Change Master Volume Code (Visual Basic 6)

Firstly set up your form.

You need one Slider (Named Slider1) To get the slider, press control + T and scroll down to the bit that says "Microsoft Windows Common Controls X.0 (SPX)" Insert that and it will be on there.

Now for the code on the form.

the code is :

Private Sub Form_Load()
Show
Slider1.Value = GetVolume
End Sub

Private Sub Slider1_Change()
SetVolume Slider1.Value
End Sub
Private Sub Slider1_Scroll()
Slider1_Change
End Sub


And now, insert a module, and put this code:


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

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

' VolumeLevel value must be between 0 and 100
If VolumeLevel < 0 Or VolumeLevel > 100 Then GoTo error

' Open the mixer
RetValue = mixerOpen(hmx, 0, 0, 0, 0)
If RetValue <> MMSYSERR_NOERROR Then GoTo error

' Initialize MIXERLINE structure and call mixerGetLineInfo
uMixerLine.cbStruct = Len(uMixerLine)
uMixerLine.dwComponentType = MIXERLINE_COMPONENTTYPE_DST_SPEAKERS
RetValue = mixerGetLineInfo(hmx, uMixerLine, _
MIXER_GETLINEINFOF_COMPONENTTYPE)
If RetValue <> MMSYSERR_NOERROR Then GoTo error

' Initialize MIXERLINECONTROLS strucure and
' call mixerGetLineControls
uMixerLineControls.cbStruct = Len(uMixerLineControls)
uMixerLineControls.dwLineID = uMixerLine.dwLineID
uMixerLineControls.dwControl = MIXERCONTROL_CONTROLTYPE_VOLUME
uMixerLineControls.cControls = 1
uMixerLineControls.cbmxctrl = Len(uMixerControl)

' Allocate a buffer to receive the properties of the master volume control
' and put his address into uMixerLineControls.pamxctrl
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

' Copy data buffer into the uMixerControl structure
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)

' Allocate a buffer in which properties for the volume control are set
' and put his address into 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)

' Set new volume level
RetValue = mixerSetControlDetails(hmx, uDetails, _
MIXER_SETCONTROLDETAILSF_VALUE)
GlobalFree hMem
hMem = 0
If RetValue <> MMSYSERR_NOERROR Then GoTo error

mixerClose hmx
' signal success
SetVolume = True
Exit Function

error:
' An error occurred

' Release resources
If hmx <> 0 Then mixerClose hmx
If hMem Then GlobalFree hMem
' signal failure
SetVolume = False
End Function

Public Function GetVolume() As Long
OpenMixer (0)
If GetVolumeP(SPEAKER) >= 0 Or GetVolumeP(SPEAKER) <= 100 Then
GetVolume = GetVolumeP(SPEAKER)
Else
GetVolume = 0
End If
CloseMixer
End Function


Public Function OpenMixer(ByVal MixerNumber As Long) As Long
Dim ret As Long
' is there a mixer available?
If MixerNumber < 0 Or MixerNumber > mixerGetNumDevs - 1 Then Exit Function

' open the mixer
ret = mixerOpen(hMixerHandle, MixerNumber, 0, 0, 0)
If ret <> MMSYSERR_NOERROR Then Exit Function

' get the primary line controls by name, (this does not get all of the controls).

' speaker (master) volume
ret = GetMixerControl(hMixerHandle, MIXERLINE_COMPONENTTYPE_DST_SPEAKERS, MIXERCONTROL_CONTROLTYPE_VOLUME, uMixerControls(SPEAKER))
' return the mixer handle
OpenMixer = True
End Function

Private Function CloseMixer() As Long
CloseMixer = mixerClose(hMixerHandle)
hMixerHandle = 0
End Function

Private Function GetVolumeP(Control As VOL_CONTROL) As Long
GetVolumeP = 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
' This function attempts to obtain a mixer control. Returns True if successful.
Dim mxlc As MIXERLINECONTROLS
Dim mxl As MIXERLINE
Dim hMem As Long
Dim ret As Long

mxl.cbStruct = Len(mxl)
mxl.dwComponentType = componentType

' Obtain a line corresponding to the component type
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)

' Allocate a buffer for the control
hMem = GlobalAlloc(&H40, Len(mxc))
mxlc.pamxctrl = GlobalLock(hMem)
mxc.cbStruct = Len(mxc)

' Get the control
ret = mixerGetLineControls(hMixer, mxlc, MIXER_GETLINECONTROLSF_ONEBYTYPE)

If ret = MMSYSERR_NOERROR Then
GetMixerControl = True

' Copy the control into the destination structure
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
'This function gets the value for a 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

' Get the control value
ret = mixerGetControlDetails(hMixer, mxcd, MIXER_GETCONTROLDETAILSF_VALUE)

' Copy the data into the control value buffer
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

And now when you move the slider up or down, it will change the system volume.

Share this

Related Posts

1 comments :

comments
2.6.10 delete

How to get default volume level in vb

Reply
avatar
There was an error in this gadget