Thema: System Lautstärke ändern

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

Code:


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 Workbook_Open()
  SetzeVolumen 100
End Sub

Private Sub Workbook_BeforeClose(Cancel As Boolean)
  SetzeVolumen 30
End Sub


Private Sub SetzeVolumen(ByVal iWert As Long)
  Dim i As Long, j As Long
  For j = 0 To 1
      For i = 1 To IIf(j = 0, 50, iWert \ 2)
          SetVolume Application.hwnd, &H319, 0, ByVal (j * &H10000) + &H90000
      Next i
  Next j
End Sub

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

Private Sub Workbook_Open()

Dim i As Long

  'Laustärke auf 100 %, egal welcher Stand war

   For i = 0 To 100

      Application.SendKeys ("{175}") 'Volumen Erhöhung

   Next

End Sub

Private Sub Workbook_BeforeClose(Cancel As Boolean)

Dim i As Long

   'Laustärke von 100, egal welcher Stand war

   For i = 1 To 35

      Application.SendKeys ("{174}") 'Volumen Minderung

   Next

End Sub

Code:


Private Declare PtrSafe Function SendMessageA Lib "user32" ( _
        ByVal hwnd As LongPtr, ByVal wMsg As Long, _
        ByVal wParam As LongPtr, lParam As LongPtr) As LongPtr

Private Sub Workbook_Open()
  VolumeUpDown 1
End Sub

Private Sub Workbook_BeforeClose() 'Cancel As Boolean)
  VolumeUpDown 0
End Sub


Private Sub VolumeUpDown(ByVal UpDown As Long)
  Dim i As Long
  For i = 1 To 50
      SendMessageA Application.hwnd, &H319, 0, ByVal (UpDown * &H10000) + &H90000
  Next i
End Sub

Private Sub VolumeUpDown(ByVal UpDown As Long)

  Dim i As Long

  For i = 1 To 35 'hier die kleine Änderung

      SendMessageA Application.hwnd, &H319, 0, ByVal (UpDown * &H10000) + &H90000

  Next i

End Sub

Code:


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)
  Dim i As Long, j As Long
  For j = 0 To 1
      For i = 1 To IIf(j = 0, 50, iWert \ 2)
          SetVolume Application.hwnd, &H319, 0, ByVal (j * &H10000) + &H90000
      Next i
  Next j
End Sub

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

Private Sub opt2_Click()
' Laustärke auf 20 %, egal welcher Stand war
  SetzeVolumen 20
End Sub

'usw......

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