vb@rchiv
VB Classic
VB.NET
ADO.NET
VBA
C#
Brandneu! sevEingabe v3.0 - Das Eingabecontrol der Superlative!  
 vb@rchiv Quick-Search: Suche startenErweiterte Suche starten   RSS-Feeds  | Newsletter  | Impressum  | Datenschutz  | vb@rchiv CD Vol.6  | Shop Copyright ©2000-2019
 
zurück
Rubrik: Multimedia & Sound · Audio   |   VB-Versionen: VB4, VB5, VB608.02.01
Lautstärke-Regelung der installierten Audiogeräte

Dieser Tipp zeigt, wie man die Namen aller installierten Audiogeräte auslesen und die Lautstärke ermitteln und ändern kann.

Autor:   LonelySuicide666Bewertung:     [ Jetzt bewerten ]Views:  31.714 
www.vbapihelpline.deSystem:  Win9x, Win8, Win10 Beispielprojekt auf CD 

Dieser Tipp zeigt, wie man die Namen aller installierten Audiogeräte auslesen kann. Außerdem zeigen wir Ihnen, wie Sie die eingestellte Lautstärke ermitteln und ändern können.

' zunächst die benötigten API-Deklarationen
Private Declare Function auxGetDevCaps Lib "winmm.dll" _
  Alias "auxGetDevCapsA" ( _
  ByVal uDeviceID As Long, _
  lpCaps As AUXCAPS, _
  ByVal uSize As Long) As Long
Private Declare Function auxGetVolume Lib "winmm.dll" ( _
  ByVal uDeviceID As Long, _
  ByRef lpdwVolume As Long) As Long
Private Declare Function auxSetVolume Lib "winmm.dll" ( _
  ByVal uDeviceID As Long, _
  ByVal dwVolume As Long) As Long
Private Declare Function auxGetNumDevs Lib "winmm.dll" () As Long
Private Declare Sub CopyMemory Lib "kernel32" _
  Alias "RtlMoveMemory" ( _
  hpvDest As Any, _
  hpvSource As Any, _
  ByVal cbCopy As Long)
 
Const MMSYSERR_BASE = 0
' DeviceID wurde nicht gefunden
Const MMSYSERR_BADDEVICEID = (MMSYSERR_BASE + 2)
' Funktion wird nicht unterstützt
Const MMSYSERR_NOTSUPPORTED = (MMSYSERR_BASE + 8)
' Kein Fehler
Const MMSYSERR_NOERROR = 0
' Treiber-Aktivierung fehlgeschlagen
Const MMSYSERR_NOTENABLED = (MMSYSERR_BASE + 3)
 
' AUXCAPS.dwSupport enthält die Fähigkeiten
' der Lautstärkeregelung
 
' Lautstärkeregelung möglich
' Private Const AUXCAPS_VOLUME = &H1   
 
' Seperate Links/Rechts Laustärkeregelung möglich 
' Private Const AUXCAPS_LRVOLUME = &H2
 
Private Type AUXCAPS
  wMid As Integer
  wPid As Integer
  vDriverVersion As Long
  szPname As String * 32
  wTechnology As Integer
  dwSupport As Long
End Type
 
Public Type VolumeSetting
  LeftVol As Integer
  RightVol As Integer
End Type
 
Private MMError As Integer
 
' auxGetNumDevs Liefert die Anzahl der verfügbaren
' Audiogeräte von Null beginnend
' Beispiel: auxGetNumDevs = 7
' dann sind die Geräte ID's 0-6
Public Function Get_NumDeviceID() As Integer
  Get_NumDeviceID = auxGetNumDevs - 1
End Function
 
' auxGetDevCaps Liefert Informationen von einem
' Audiogerät
Public Function Get_DeviceName(ByVal DeviceID As Integer) _
  As String
 
  If DeviceID < 0 Or DeviceID > Get_NumDeviceID Then _
    Exit Function
 
  Dim AUX As AUXCAPS
 
  ' Hier wird AUX mit den Devicedaten gefüllt
  Call auxGetDevCaps(DeviceID, AUX, Len(AUX))
  ' Trennen von vbNullChar-Zeichen und zurückgeben
  Get_DeviceName = Left$(AUX.szPname, _
    InStr(1, AUX.szPname, vbNullChar) - 1)
End Function
 
' Gibt die prozentuale Lautstärke wieder
Public Function Get_DeviceVolume(ByVal DeviceID As Long) _
  As VolumeSetting
 
  If DeviceID < 0 Or DeviceID > Get_NumDeviceID Then _
    Exit Function
 
  Dim Volume As VolumeSetting, BothVolumes As Long
  ' BothVolumes Füllen
  Call auxGetVolume(DeviceID, BothVolumes)
  ' Rechte und Linke Lautstärke trennen
  Call CopyMemory(Volume, BothVolumes, Len(Volume))
  ' Funktionsaufruf für die Prozentausrechnung
  With Get_DeviceVolume
    .LeftVol = Get_PercentVolume(Volume.LeftVol)
    .RightVol = Get_PercentVolume(Volume.RightVol)
  End With
End Function
 
' Rechnet aus wieviel Prozent die Laustärke ist
Private Function Get_PercentVolume(ByVal Volume As Integer) _
  As Long
 
  ' Bei der Laustärke ist zu beachten, daß die
  ' Laustärke in 2 Teilen aufgeteilt ist:
  ' 0 bis 32767 und -32767 bis -1
  ' 
  ' Beispiel: ganz leise = 0
  '          etwas lauter = 11000
  '          ungefär mittellaut = 32767
  '          mehr als mittellaut = - 22000
  '          ganz laut = -1
  If Volume > 0 Then
    Get_PercentVolume = 100 / 65535 * Volume
  Else
    Get_PercentVolume = (100 / 65535) * (65535 + Volume)
  End If
End Function
 
' Setzen der prozentualen Laustärke
Public Function Set_DeviceVolume(ByVal DeviceID As Long, _
  ByVal LeftVolume As Long, ByVal RightVolume As Long)
 
  If DeviceID < 0 Or DeviceID > Get_NumDeviceID Then _
    Exit Function
 
  Dim Volume As VolumeSetting, BothVolumes As Long
 
  ' Funktionsaufruf für die Prozentausrechnung
  Volume.LeftVol = Set_PercentVolume(LeftVolume)
  Volume.RightVol = Set_PercentVolume(RightVolume)
 
  ' Linke und Rechte Lautstärke in BothVolumes vereinen
  Call CopyMemory(BothVolumes, Volume.LeftVol, Len(Volume))
  ' Lautstärke setzen
  Call auxSetVolume(DeviceID, BothVolumes)
End Function
 
' Rechnet die prozentuale Laustärke aus
Private Function Set_PercentVolume(ByVal Volume As Long) _
  As Long
 
  If Volume <= 50 Then
    Set_PercentVolume = (65535 / 100) * Volume
  Else
    Set_PercentVolume = (65535 / 100) * (65535 + Volume)
  End If
End Function

Anwendungsbeispiel:

' Beispiel für die Funktionsaufrufe
Sub Main()
  Dim i As Integer
 
  For i = 0 To Get_NumDeviceID
    Debug.Print "Lautstärke: " & Get_DeviceName(i) + _
      " Links: " & Get_DeviceVolume(i).LeftVol + _
      " Rechts: " & Get_DeviceVolume(i).RightVol
 
    ' Geht natürlich auch bei Set_DeviceVolume
    ' Set_DeviceVolume i, 50, 50
  Next i
End Sub

Hinweis:
Auf unseren Testgeräten funktionierte der Tipp leider nicht unter Windows 2000. Auf einem Win95/98-Rechner funktioniert der Tipp einwandfrei.
 

Dieser Tipp wurde bereits 31.714 mal aufgerufen.

Voriger Tipp   |   Zufälliger Tipp   |   Nächster Tipp

Über diesen Tipp im Forum diskutieren
Haben Sie Fragen oder Anregungen zu diesem Tipp, können Sie gerne mit anderen darüber in unserem Forum diskutieren.

Neue Diskussion eröffnen

nach obenzurück


Anzeige

Kauftipp Unser Dauerbrenner!Diesen und auch alle anderen Tipps & Tricks finden Sie auch auf unserer aktuellen vb@rchiv  Vol.6
(einschl. Beispielprojekt!)

Ein absolutes Muss - Geballtes Wissen aus mehr als 8 Jahren vb@rchiv!
- nahezu alle Tipps & Tricks und Workshops mit Beispielprojekten
- Symbol-Galerie mit mehr als 3.200 Icons im modernen Look
Weitere Infos - 4 Entwickler-Vollversionen (u.a. sevFTP für .NET), Online-Update-Funktion u.v.m.
 
   

Druckansicht Druckansicht Copyright ©2000-2019 vb@rchiv Dieter Otter
Alle Rechte vorbehalten.
Microsoft, Windows und Visual Basic sind entweder eingetragene Marken oder Marken der Microsoft Corporation in den USA und/oder anderen Ländern. Weitere auf dieser Homepage aufgeführten Produkt- und Firmennamen können geschützte Marken ihrer jeweiligen Inhaber sein.

Diese Seiten wurden optimiert für eine Bildschirmauflösung von mind. 1280x1024 Pixel