PC - Lautstärke einstellen

[volti]

Hallo Forum,

manchmal möchte man per VBA die Lautstärke an seinem PC einstellen. 

Neben einigen anderen bei mir nicht funktionierenden Methoden bietet sich eine Methode an, bei der eine WM_APPCOMMAND-Message an Windows gesendet wird.
Leider wird hier nur VolumeUp, VolumeDown und VolumeMute angeboten und das auch noch mit zwei Prozent Änderung pro Aufruf anstatt mit einem Prozent.

Somit ist eigentlich die Übergabe eines festen Lautsprecherlevels nicht möglich. 

Ein Trick wäre, immer erst auf Null zu fahren und dann anhand dieses festen Startwerts das Volumen durch Hochfahren festzulegen und sich den neuen Wert zu merken.
Vom neuen gemerkten Startwert können Folgeeinstellungen dann direkt erfolgen.

Der folgende Code ermöglicht die

Festlegung eines Levels durch Übergabe eines geraden positiven Wertes von 0 bis 100

Prozentuale Erhöhung oder Verminderung durch Übergabe eines negativen oder ungeraden Wertes

Stummschaltung bzw. Einschaltung des Tones durch die Übergabe eines Wertes größer 100 bzw. WM_Mute.

Erzwingung des Runterfahrens und dadurch Speicherung eines Startwertes

PS: Durch die Zwei-Prozentveränderung wird der gewünschte Wert manchmal nicht direkt getroffen, aber das sollte ja kein Problem darstellen.

Code:

Public Const WM_Mute    As Long = &H80000
Dim miLastVolume        As Long
        
Private Declare PtrSafe Function SetVolume Lib "user32" Alias "SendMessageA" ( _
        ByVal hwnd As LongPtr, ByVal wMsg As Long, _
        ByVal wParam As LongPtr, lParam As LongPtr) As LongPtr

Private Sub Lautstärke(ByVal iWert As Long, Optional bReset As Boolean)
  Const WM_AppCmd As Long = &H319
  Const WM_Down   As Long = &H90000
  Const WM_Up     As Long = &HA0000
  Dim i As Long
  
  With Application
     If Abs(iWert) > 100 Then
        SetVolume .hwnd, WM_AppCmd, 0, ByVal WM_Mute        ' Mute ein/ausschalten
        Exit Sub
     End If
  
     If iWert < 0 Or (iWert Mod 2) = 1 Then
        iWert = iWert + miLastVolume + IIf(iWert < 0, -1, 1)
     End If
     If iWert <> 0 And iWert = miLastVolume And bReset = False Then Exit Sub

     If miLastVolume = 0 Or bReset Then                     ' Auf Null fahren
        For i = 1 To 50
            SetVolume .hwnd, WM_AppCmd, 0, ByVal WM_Down
        Next i
        miLastVolume = 0                                    ' Runtergefahren
     End If

     For i = 1 To Abs(iWert - miLastVolume) \ 2             ' Jetzt Lautstärke verändern
         SetVolume .hwnd, WM_AppCmd, 0, ByVal IIf(iWert < miLastVolume, WM_Down, WM_Up)
     Next i
     If iWert > 100 Then iWert = 100                        ' Korrigierung
     If iWert < 0 Then iWert = 0                            ' Korrigierung
     miLastVolume = iWert                                   ' Level merken
  End With
End Sub



' ### Tests ###
Sub Test1()
  Lautstärke 6, True ' Lautstärke auf 0, dann auf 6 setzen
End Sub

Sub Test2()
  Lautstärke 60      ' Lautstärke sofort auf 60 setzen
End Sub

Sub Test3()
  Lautstärke 20      ' Lautstärke sofort auf 20 setzen
End Sub

Sub Test4()
  Lautstärke 5       ' Lautstärke um 5 erhöhen
End Sub

Sub Test5()
  Lautstärke -7      ' Lautstärke um 7 erniedrigen
End Sub

Sub Test6()
  Lautstärke WM_Mute ' Lautstärke stummschalten
End Sub

_________
viele Grüße
Karl-Heinz