System Lautstärke ändern

Dieter(Drummer) · 2025-01-23T18:34:40+01:00

Guten Tag an alle. Ich suche die Möglichkeit, mit "WorkBook_open" und "WorkBook_close", die Systemlautstärke zu ändern. Nur für die aktivierte Datei. Mit den beidne Codes funktioniert es nicht. Es bleibt bei 100%. Ich kann keinen Fehler finden und es wird auch keiner angezeigt. Mit der Bitte um Hilfe, wie es richtig funktioniert, dass bei öffnen der Datei 100% und bei schließen wieder 30% Lautstärke eingestellt ist. Gruß, Dieter(Drummer) Jetziger Mustercode: Private Sub Workbook_Open() Dim i As Long 'Laustärke auf 100 %, egal welcher Stand war For i = 0 To 100 Application.SendKeys ("{175}") Next End Sub Private Sub Workbook_BeforeClose(Cancel As Boolean) Dim i As Long 'Laustärke auf 30 %, egal welcher Stand war For i = 1 To 30 Application.SendKeys ("{175}") Next End Sub

Hallo Dieter,
sorry, ich kann Dir da nicht wirklich helfen.

Ich hatte nur vor einiger Zeit mal nach einer Möglichkeit gesucht, den Sound aus- und einzuschalten
sowie die Lautstärke zu erhöhen bzw. abzusenken. Dazu hatte ich noch diese Codes gefunden:

'https://www.mrexcel.com/board/threads/vba-code-to-turn-volume-on-up-down.1076829/
'siehe Beitrag von Stan Strong

Option Explicit



#If Win64 Then

    Private Const NULL_PTR = 0^

#Else

    Private Const NULL_PTR = 0&

#End If



#If VBA7 Then

    Private Declare PtrSafe Function SendMessage Lib "user32" Alias "SendMessageW" (ByVal hwnd As LongPtr, ByVal wMsg As Long, ByVal wParam As LongPtr, lParam As Any) As LongPtr

#Else

    Private Declare Function SendMessage Lib "user32" Alias "SendMessageW" (ByVal hwnd As Long, ByVal wMsg As Long, ByVal wParam As Long, lParam As Any) As Long

#End If



Private Const APPCOMMAND_VOLUME_MUTE As Long = &H80000

Private Const APPCOMMAND_VOLUME_UP As Long = &HA0000

Private Const APPCOMMAND_VOLUME_DOWN As Long = &H90000

Private Const WM_APPCOMMAND As Long = &H319

 

Sub ToggleMute()  'Lautstärke auf stumm

    Call SendMessage(Application.hwnd, WM_APPCOMMAND, NULL_PTR, ByVal APPCOMMAND_VOLUME_MUTE)

End Sub



Sub DecreaseVol() 'Lautstärke geringer werdend pro Durchlauf

    Call SendMessage(Application.hwnd, WM_APPCOMMAND, NULL_PTR, ByVal APPCOMMAND_VOLUME_DOWN)

End Sub



Sub IncreaseVol() 'Lautstärke größer werdend pro Durchlauf

    Call SendMessage(Application.hwnd, WM_APPCOMMAND, NULL_PTR, ByVal APPCOMMAND_VOLUME_UP)

End Sub

Interesse hätte ich jetzt aufgrund Deiner Frage aber schon, wenn Du eine Lösung hast, teile es bitte mit.

Gruß
Jochen

Hallo zusammen,

gut Ding will Weil haben.

Mich störte jetzt aber doch, dass das Ding erst immer runter auf Null muss und dann erst hochfährt. Wenn die Anzeige nicht wäre, wäre es ja egal.

Hier noch eine Variante, die nur noch hoch oder runter fährt oder gar nichts macht, wenn die Lautstärke schon auf dem Level ist.

Hierzu merken wir uns die letzte Einstellung und rechnen nur noch die Differenz aus. Lediglich beim Ersten Mal in der Mappe fährt es erst mal runter, um einen korrekten Stand zu bekommen.

Muss natürlich noch etwas getestet werden....

PS: Diese Variante ist jetzt auch mit der Stummschaltung ausgestattet. Einfach (-1) übergeben.

Code:


Option Explicit

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 SetzeVolumen(ByVal iWert As Long, Optional bReset As Boolean)
  Const WM_AppCommand As Long = &H319
  Const WM_Up  As Long = &HA0000
  Const WM_Dn  As Long = &H90000
  Dim i As Long, iUpDn As Long, iDiff As Long
  
  With Application
     If iWert = (-1) Then
        SetVolume .hwnd, WM_AppCommand, 0, ByVal &H80000     ' Mute ein/ausschalten
        Exit Sub
     End If
  
     iWert = iWert \ 2
     If iWert > 50 Then iWert = 50
     If iWert < 0 Then iWert = 0
     If iWert = miLastVolume Then Exit Sub                   ' keine Lautstärkenänderung =>raus

     If miLastVolume < 1 Or miLastVolume > 50 Or bReset Then ' Auf Null fahren
        For i = 1 To 50
            SetVolume .hwnd, WM_AppCommand, 0, ByVal WM_Dn
        Next i
        miLastVolume = 0                                     ' Runtergefahren
     End If
     iUpDn = IIf(iWert < miLastVolume, WM_Dn, WM_Up)         ' Richtung festlegen
     iDiff = Abs(iWert - miLastVolume)                       ' Differenz ermitteln
     miLastVolume = iWert                                    ' Level merken
' Jetzt Lautstärke verändern
     For i = 1 To iDiff
         SetVolume .hwnd, WM_AppCommand, 0, ByVal iUpDn      ' Hoch/Runterfahren
     Next i
  End With
End Sub

Private Sub opt1_Click()
' Laustärke auf 10 %, egal welcher Stand war
  SetzeVolumen 10 ',true
End Sub

_________________________
viele Grüße aus Freigericht 😊
Karl-Heinz

Forumthread: System Lautstärke ändern

15
Beiträge zum Forumthread

Beiträge zu diesem Forumthread

Forumthreads zu verwandten Themen

System Lautstärke ändern

Forumthread: System Lautstärke ändern

15 Beiträge zum Forumthread Beiträge zu diesem Forumthread

Forumthreads zu verwandten Themen

15
Beiträge zum Forumthread

Beiträge zu diesem Forumthread