Lautstärke einstellen VBA API

[ecco]

Hallo
Möchte mit Vba die Lautstärke ändern. Win10, Excel 2013
Muss da unten Wirkung zeigen!

   

MfG Link

[RPP63]

Moin!
Google kaputt?
https://www.herber.de/forum/archiv/1132t...r_VBA.html

Gruß Ralf

[ecco]

Hallo
Da war ich schon. Zeigt keine Wirkung!
MfG Link

[RPP63]

Ich bin zur Zeit am Phone und kann das erst gleich testen.
Ich melde mich gleich.

---

Hast Recht, funktioniert nicht.

Nimm dies, ist getestet und funktioniert bei mir:

Modul Modul1

Option Explicit 
 
Const VK_VOLUME_MUTE = &HAD 
Const VK_VOLUME_DOWN = &HAE 
Const VK_VOLUME_UP = &HAF 
 
#If VBA7 Then 
    Private Declare PtrSafe Sub keybd_event Lib "user32" _
      (ByVal bVk As Byte, ByVal bScan As Byte, _
      ByVal dwFlags As Long, ByVal dwExtraInfo As Long) 
#Else 
    Private Declare Sub keybd_event Lib "user32" _
      (ByVal bVk As Byte, ByVal bScan As Byte, _
      ByVal dwFlags As Long, ByVal dwExtraInfo As Long) 
#End If 
 
Sub VolUp() 
  keybd_event VK_VOLUME_UP, 0, 1, 0 
  keybd_event VK_VOLUME_UP, 0, 3, 0 
End Sub 
 
Sub VolDown() 
  keybd_event VK_VOLUME_DOWN, 0, 1, 0 
  keybd_event VK_VOLUME_DOWN, 0, 3, 0 
End Sub 
 
Sub VolToggle() 
  keybd_event VK_VOLUME_MUTE, 0, 1, 0 
End Sub 

Stammt von hier:
https://wellsr.com/vba/2016/excel/use-vb...lume-down/
(übrigens auch mittels Suchmaschinee gefunden …)

Gruß Ralf

[ecco]

Hallo
Das funktioniert!
Danke für die Mühe.
Habe es noch ein bisschen geändert.
MfG Link

Code:

Const VK_VOLUME_MUTE = &HAD
Const VK_VOLUME_DOWN = &HAE
Const VK_VOLUME_UP = &HAF

    Private Declare PtrSafe Sub keybd_event Lib "user32" (ByVal bVk As Byte, ByVal bScan As Byte, ByVal dwFlags As Long, ByVal dwExtraInfo As Long)
    Private Declare PtrSafe Function GetTickCount Lib "kernel32" () As Long

Sub VolDown()
   keybd_event VK_VOLUME_DOWN, 0, 1, 0
   keybd_event VK_VOLUME_DOWN, 0, 3, 0
End Sub
Sub DoNothing(Finish As Long)
    Dim NowTick As Long
    Dim EndTick As Long
    EndTick = GetTickCount + (Finish * 10000)
    Do
        NowTick = GetTickCount
        DoEvents
    Loop Until NowTick >= EndTick
End Sub

Sub MinimumVolume()
Dim i As Integer
For i = 1 To 100
  Call VolDown
Next i
End Sub

Sub VolMe()

Application.EnableCancelKey = xlErrorHandler 'ESC beendet Schleife

On Error GoTo ERRORHANDLER

MinimumVolume
   keybd_event VK_VOLUME_UP, 0, 1, 0
   keybd_event VK_VOLUME_UP, 1, 5, 1
   keybd_event VK_VOLUME_UP, 0, 1, 0
   keybd_event VK_VOLUME_UP, 1, 5, 1
   keybd_event VK_VOLUME_UP, 0, 1, 0
   keybd_event VK_VOLUME_UP, 1, 5, 1
   keybd_event VK_VOLUME_UP, 0, 1, 0
   keybd_event VK_VOLUME_UP, 1, 5, 1
   keybd_event VK_VOLUME_UP, 0, 1, 0
   keybd_event VK_VOLUME_UP, 1, 5, 1
   keybd_event VK_VOLUME_UP, 0, 1, 0
   keybd_event VK_VOLUME_UP, 1, 5, 1
   keybd_event VK_VOLUME_UP, 0, 1, 0
   keybd_event VK_VOLUME_UP, 1, 5, 1
   keybd_event VK_VOLUME_UP, 0, 1, 0
   keybd_event VK_VOLUME_UP, 1, 5, 1
   keybd_event VK_VOLUME_UP, 0, 1, 0
   keybd_event VK_VOLUME_UP, 1, 5, 1
   keybd_event VK_VOLUME_UP, 0, 1, 0
   keybd_event VK_VOLUME_UP, 1, 5, 1
   keybd_event VK_VOLUME_UP, 0, 1, 0
   keybd_event VK_VOLUME_UP, 1, 5, 1
   keybd_event VK_VOLUME_UP, 0, 1, 0
   keybd_event VK_VOLUME_UP, 1, 5, 1
  

Dim Text
Dim prüfen
Application.Wait (Now + TimeValue("0:00:02"))
Application.Speech.Speak "Heute"                               'Heute

If Not Tabelle1.Range("AE8").Value = " " Then
Application.Wait (Now + TimeValue("0:00:01"))
strText = Worksheets("K").Range("AE8")
    Application.Speech.Speak "" & strText
End If

If Not Tabelle1.Range("AG8").Value = " " Then
Application.Wait (Now + TimeValue("0:00:01"))
strText = Worksheets("K").Range("AG8")
    Application.Speech.Speak "" & strText
End If

Application.Wait (Now + TimeValue("0:00:01"))
Application.Speech.Speak "Morgen"                               'Morgen

If Not Tabelle1.Range("AE9").Value = " " Then
Application.Wait (Now + TimeValue("0:00:01"))
strText = Worksheets("K").Range("AE9")
    Application.Speech.Speak "" & strText
End If

If Not Tabelle1.Range("AG9").Value = " " Then
Application.Wait (Now + TimeValue("0:00:01"))
strText = Worksheets("K").Range("AG9")
    Application.Speech.Speak "" & strText
End If
  
Application.Wait (Now + TimeValue("0:00:01"))
Application.Speech.Speak "Übermorgen"                               'Übermorgen

If Not Tabelle1.Range("AE10").Value = " " Then
Application.Wait (Now + TimeValue("0:00:01"))
strText = Worksheets("K").Range("AE10")
    Application.Speech.Speak "" & strText
End If

If Not Tabelle1.Range("AG10").Value = " " Then
Application.Wait (Now + TimeValue("0:00:01"))
strText = Worksheets("K").Range("AG10")
    Application.Speech.Speak "" & strText
End If
  
ERRORHANDLER:
End Sub