Vb.net - Sesi Kısma Yükseltme

[Selyk]

Öncelikle merhabalar direk anlatıma geçicem

Forma 1 tane modül, 6 tane label, 2 tane timer, 1 tane check kutusu, 2 tane slider kontrolü(MSCOMCTL.OCX) ekleyin.

Modüle eklenecek kod

Public Declare Function waveOutGetVolume Lib "winmm.dll" (ByVal uDeviceID As Long, lpdwVolume As Long) As Long
 
Public Declare Function waveOutSetVolume Lib "winmm.dll" (ByVal uDeviceID As Long, ByVal dwVolume As Long) As Long
 
Public Const MAXPNAMELEN = 32
 
Public Type WAVEOUTCAPS
wMid As Integer
wPid As Integer
vDriverVersion As Long
szPname As String * MAXPNAMELEN
dwFormats As Long
wChannels As Integer
dwSupport As Long
End Type
 
Public Declare Function waveOutGetNumDevs Lib "winmm.dll" () As Long
 
Public Declare Function waveOutGetDevCaps Lib "winmm.dll" Alias "waveOutGetDevCapsA" (ByVal uDeviceID As Long, lpCaps As WAVEOUTCAPS, ByVal uSize As Long) As Long

Forma eklenecek kodlar

Private Sub Check1_Click()
Timer1.Interval = 0
Timer2.Interval = 0
End Sub
 
Private Sub Form_Load()
 
label1.caption="sag"
label2.caption="sol"
label3.caption="alçak"
label4.caption="yüksek"
label5.caption="alçak"
label6.caption="yüksek"
check1.caption="Kaydirma Göstergeleri Ayni Anda Hareket Etsin"
 
Dim lpc As WAVEOUTCAPS
If waveOutGetNumDevs() = 0 Then
MsgBox ("Ses çalacak donanmim yok")
End If
Call waveOutGetDevCaps(0, lpc, Len(lpc))
If lpc.wChannels = 0 Then
Slider2.Visible = False [m]'mono ise birini gizle[/m]
End If
 
If (lpc.dwSupport And 4) = 0 Then [m]'ses ayarini desteklemiyorsa ikisinide gizle[/m]
Slider1.Visible = False
Slider2.Visible = False
End If
 
If (lpc.dwSupport And 8) = 0 Then [m]'sol sag ses ayarini desteklemiyorsa birini gizle[/m]
Slider2.Visible = False
End If
 
Slider1.Min = 0
Slider1.Max = &HFFFF&
Slider1.TickFrequency = &HFFFF& / 10
Slider2.Min = 0
Slider2.Max = &HFFFF&
Slider2.TickFrequency = &HFFFF& / 10
 
 
Dim x, sol, sag, st [m]'su anki seviyeyi göster[/m]
Call waveOutGetVolume(0, x)
sol = x And &HFFFF& [m]'düsük seviyeli 2byte[/m]
st = Hex(x And &HFFFF0000)
If Len(st) > 4 Then
st = Mid(st, 1, Len(st) - 4) [m]'yüksek seviyeli 2 bayti al[/m]
Else
st = 0
End If
sag = CDbl("&h" & st)
Slider1.Value = sol
Slider2.Value = sag
End Sub
 
Sub sesayar()
Dim x, sol, sag, s
sol = Slider1.Value
sag = Slider2.Value
s = Val("&h" & Hex(sag) & String(4 - Len(Hex(sol)), "0") & Hex(sol) & "&")
Call waveOutSetVolume(0, s)
End Sub
 
Private Sub Slider1_Click()
sesayar
End Sub
 
Private Sub Slider1_Scroll()
If Check1.Value = 0 Then
Else
Timer1.Interval = 0
Timer2.Interval = 1
End If
sesayar
End Sub
 
Private Sub Slider2_Click()
sesayar
End Sub
 
Private Sub Slider2_Scroll()
If Check1.Value = 0 Then
Else
Timer2.Interval = 0
Timer1.Interval = 1
End If
sesayar
End Sub
 
Private Sub Timer1_Timer()
Slider1 = Slider2
End Sub
 
Private Sub Timer2_Timer()
Slider2 = Slider1
End Sub

İyi Günler

 

[Selyk]

 

[iwystic]

Konu için teşekkürler.