Vb6 pc sesi kısma yükseltme

'eqwedelly

Üye
16 Ocak 2011
240
0
TÜRKİYE
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
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

Kod:
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
 
Üst

Turkhackteam.org internet sitesi 5651 sayılı kanun’un 2. maddesinin 1. fıkrasının m) bendi ile aynı kanunun 5. maddesi kapsamında "Yer Sağlayıcı" konumundadır. İçerikler ön onay olmaksızın tamamen kullanıcılar tarafından oluşturulmaktadır. Turkhackteam.org; Yer sağlayıcı olarak, kullanıcılar tarafından oluşturulan içeriği ya da hukuka aykırı paylaşımı kontrol etmekle ya da araştırmakla yükümlü değildir. Türkhackteam saldırı timleri Türk sitelerine hiçbir zararlı faaliyette bulunmaz. Türkhackteam üyelerinin yaptığı bireysel hack faaliyetlerinden Türkhackteam sorumlu değildir. Sitelerinize Türkhackteam ismi kullanılarak hack faaliyetinde bulunulursa, site-sunucu erişim loglarından bu faaliyeti gerçekleştiren ip adresini tespit edip diğer kanıtlarla birlikte savcılığa suç duyurusunda bulununuz.