VERSION 5.00
Begin VB.Form frmVolume 
   BorderStyle     =   4  'Fixed ToolWindow
   ClientHeight    =   1440
   ClientLeft      =   45
   ClientTop       =   285
   ClientWidth     =   915
   LinkTopic       =   "Form1"
   MaxButton       =   0   'False
   MinButton       =   0   'False
   ScaleHeight     =   1440
   ScaleWidth      =   915
   ShowInTaskbar   =   0   'False
   StartUpPosition =   3  'Windows Default
   Begin VB.VScrollBar VScroll1 
      Height          =   1215
      Left            =   120
      Max             =   100
      TabIndex        =   1
      Top             =   120
      Width           =   255
   End
   Begin VB.CommandButton Command1 
      Height          =   135
      Left            =   120
      TabIndex        =   0
      Top             =   720
      Width           =   135
   End
   Begin VB.Label Label2 
      Caption         =   "100"
      Height          =   255
      Left            =   480
      TabIndex        =   3
      Top             =   360
      Width           =   375
   End
   Begin VB.Label Label1 
      Caption         =   "0"
      Height          =   255
      Left            =   480
      TabIndex        =   2
      Top             =   960
      Width           =   375
   End
End
Attribute VB_Name = "frmVolume"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = False
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

    ' 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

Private Sub Form_Load()
    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)
    Command1.SetFocus
End Sub

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 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
    ' 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