folder Tahribat.com Forumları
linefolder Visual Basic - Basic - PicBasic ve Türevleri
linefolder Youtubedan Müzik Oynatmak(VB6)



Youtubedan Müzik Oynatmak(VB6)

  1. KısayolKısayol reportŞikayet pmÖzel Mesaj
    DE5TROY3R
    DE5TROY3R's avatar
    Kayıt Tarihi: 04/Nisan/2007
    Erkek

    http://www.veindir.com/upload/td_online_muzik_oynatici_1.jpg


    Dim ArananSey, YeniSarkiZamani, i
Dim nID As NOTIFYICONDATA

Private Declare Function ShellExecute Lib "shell32.dll" Alias "ShellExecuteA" (ByVal hWnd As Long, ByVal lpOperation As String, ByVal lpFile As String, ByVal lpParameters As String, ByVal lpDirectory As String, ByVal nShowCmd As Long) As Long

Private Sub CandyButton1_Click()
If Check1.Value = "1" Then 'karşık şarkı

Randomize
random = Int(Rnd * names.ListCount) + 0
id.Text = random
durum.Caption = names.List(id.Text) & " açılıyor"
WebBrowser1.Navigate links.List(id.Text)
YeniSarkiZamani = Minute(Now) + Combo1.Text
If YeniSarkiZamani > 59 Then
YeniSarkiZamani = YeniSarkiZamani - 59
End If

Else
id.Text = id.Text + 1
durum.Caption = names.List(id.Text) & " açılıyor"
WebBrowser1.Navigate links.List(id.Text)
YeniSarkiZamani = Minute(Now) + Combo1.Text
If YeniSarkiZamani > 59 Then
YeniSarkiZamani = YeniSarkiZamani - 59
End If
End If
End Sub

Private Sub Check2_Click()
If Check2.Value = False Or durum.Caption = "TD Software" Then
xpFrame2.Visible = False
Form1.Width = "5940"
Else
xpFrame2.Visible = True
Form1.Width = "11745"
End If
End Sub

Private Sub Command1_Click()
names.Clear
links.Clear

ArananSey = Replace(Text3.Text, " ", "+")
Inet1.Execute "http://m.youtube.com/results?gl=US&hl=en&client=mv-google&search_type=videos&search_sort=relevance&uploaded=&q=" & ArananSey & "&p=" & pageid.Text, "GET", , "User-Agent: Mozilla/5.0 (Windows; U; Windows NT 6.1; tr; rv:1.9.2.12) Gecko/20101026 Firefox/3.6.15 " & vbCrLf & " Content-Type: application/x-www-form-urlencoded"
Timer1.Enabled = True
End Sub

Function TagYakala(veri As String, tagb As String, tags As String)
On Error Resume Next
On Local Error Resume Next
arrs = Split(veri, tagb)
arrB = Split(arrs(1), tags)
TagYakala = arrB(0)
End Function

Private Sub Command2_Click()
linklertext.SetFocus
End Sub

Private Sub durum_Click()

If durum.Caption = "TD Software" Then
Shell "explorer.exe http://tdsoftware.tr.cx"
Else


URL = Replace$(WebBrowser1.LocationURL, "embed/", "watch?v=")
URL = Replace$(URL, "?autoplay=1", "")

ShellExecute 0, vbNullString, URL, vbNullString, vbNullString, vbNormalFocus

'Shell "explorer.exe  " & WebBrowser1.LocationURL

End If
End Sub

Private Sub Form_Click()
minimize_to_tray
End Sub

Private Sub Form_Load()
For i2 = 1 To 9
Combo1.AddItem i2
Next i2
End Sub

Private Sub Inet1_StateChanged(ByVal State As Integer)
Dim vtData   As Variant
Dim strData  As String
Dim bDone    As Boolean
Dim arr()    As String
Dim i        As Integer
Select Case State
Case icError
vtData = Inet1.ResponseCode & " - " & Inet1.ResponseInfo
Case icResponseCompleted ' 12
bDone = False
vtData = Inet1.GetChunk(1024, icString)
DoEvents
Do While Not bDone
strData = strData & vtData
vtData = Inet1.GetChunk(1024, icString)
DoEvents
If Len(vtData) = 0 Then
bDone = True
End If
Loop
Me.kaynak.Text = Replace(strData, vbLf, vbCrLf)
If InStr(1, Me.kaynak.Text, "Lookup Results") > 0 Then
MsgBox "yes, query success"
End If
Text2.Text = Inet1.Object
End Select
End Sub

Private Sub linklertext_GotFocus()
linklertext.SelStart = 0
  linklertext.SelLength = Len(linklertext.Text) - 1
End Sub

Private Sub tahribat_Click()
Shell "explorer http://tahribat.com"
End Sub


Private Sub names_Click()
For i = 0 To names.ListCount - 1

If names.Selected(i) Then
id.Text = i
durum.Caption = names.List(id.Text) & " açılıyor"
WebBrowser1.Navigate links.List(id.Text)
YeniSarkiZamani = Minute(Now) + Combo1.Text
If YeniSarkiZamani > 59 Then
YeniSarkiZamani = YeniSarkiZamani - 59
End If
End If
Next i
End Sub

Private Sub tdomp_Timer()
If names.ListCount > 0 Then
CandyButton1.Enabled = True
Text4.Enabled = True
Check2.Enabled = True


If YeniSarkiZamani = Minute(Now) Then

If Check1.Value = "1" Then 'karşık şarkı

Randomize
random = Int(Rnd * names.ListCount) + 0
id.Text = random
durum.Caption = names.List(id.Text) & " açılıyor"
WebBrowser1.Navigate links.List(id.Text)
YeniSarkiZamani = Minute(Now) + Combo1.Text
If YeniSarkiZamani > 59 Then
YeniSarkiZamani = YeniSarkiZamani - 59
End If

Else
id.Text = id.Text + 1
durum.Caption = names.List(id.Text) & " açılıyor"
WebBrowser1.Navigate links.List(id.Text)
YeniSarkiZamani = Minute(Now) + Combo1.Text
If YeniSarkiZamani > 59 Then
YeniSarkiZamani = YeniSarkiZamani - 59
End If
End If

End If


Else
CandyButton1.Enabled = False
Text4.Enabled = False
Check2.Enabled = False
End If
End Sub

Private Sub Text4_Change()
SearchInListBox names, Text4.Text, False
End Sub

Private Sub Timer1_Timer()
On Error Resume Next

If pageid.Text = toplamsayfa.Text Then
Timer1.Enabled = False
Else

If Text2.Text = "http://m.youtube.com/results?gl=US&hl=en&client=mv-google&search_type=videos&search_sort=relevance&uploaded=&q=" & ArananSey & "&p=" & pageid.Text Then  '


If okeymi.Text = "0" Then
For link = 1 To 9
linkler = TagYakala(kaynak, tag1.Text & link & tag2.Text, tag3.Text)

isimi = TagYakala(kaynak, tag2.Text & linkler & tag3.Text, tag7.Text)

If linkler <> "" Then
List1.AddItem linkler
temizlendi = Replace$(linkler, "watch?gl=US&hl=en&client=mv-google&", "")
temizlendi = Replace$(temizlendi, "v=", "")
linklertext.Text = linklertext.Text + "http://youtube.com/" & temizlendi & vbCrLf

links.AddItem "http://www.youtube.com/embed" & temizlendi & "?autoplay=1" & vbCrLf



isimi = Right$(isimi, Len(isimi) - 2)

isimi = Replace$(isimi, "ÅŸ", "ş")
isimi = Replace$(isimi, "ı", "ı")
isimi = Replace$(isimi, "ÄŸ", "ğ")
isimi = Replace$(isimi, "ç", "ç")
isimi = Replace$(isimi, "ö", "ö")
isimi = Replace$(isimi, "Ö", "Ö")
isimi = Replace$(isimi, "ü", "ü")
isimi = Replace$(isimi, "Ä°", "İ")
isimi = Replace$(isimi, "Ç", "Ç")
isimi = Replace$(isimi, "Å", "Ş")
isimi = Replace$(isimi, "Ãœ", "Ü")
isimi = Replace$(isimi, "‪", " ")
isimi = Replace$(isimi, "Ğİ", "Ğ")
isimi = Replace$(isimi, "'", "'")
isimi = Replace$(isimi, """, " ")
isimi = Replace$(isimi, "-", "")
isimi = Replace$(isimi, "  ", " ")


isimi = LCase(isimi)

names.AddItem isimi
End If

Next link
pageid.Text = pageid.Text + 1

Inet1.Execute "http://m.youtube.com/results?gl=US&hl=en&client=mv-google&search_type=videos&search_sort=relevance&uploaded=&q=" & ArananSey & "&p=" & pageid.Text, "GET", , "User-Agent: Mozilla/5.0 (Windows; U; Windows NT 6.1; tr; rv:1.9.2.12) Gecko/20101026 Firefox/3.6.15 " & vbCrLf & " Content-Type: application/x-www-form-urlencoded"
Do While Inet1.StillExecuting
DoEvents
Loop
link = 1
Label4.Caption = "Sonuçlar(" & links.ListCount & ")"

End If
Else
End If
End If

End Sub

Private Sub WebBrowser1_CommandStateChange(ByVal Command As Long, ByVal Enable As Boolean)
durum.Caption = WebBrowser1.LocationName
If durum.Caption = "http:///" Then
durum.Caption = "TD Software"
End If
End Sub

Private Sub WebBrowser1_StatusTextChange(ByVal Text As String)
durum.Caption = WebBrowser1.LocationName
If durum.Caption = "http:///" Then
durum.Caption = "TD Software"
End If
End Sub

Private Sub Form_MouseMove(Button As Integer, Shift As Integer, X As Single, Y As Single)
On Error Resume Next

Dim Msg As Long
Dim sFilter As String
Msg = X / Screen.TwipsPerPixelX
Select Case Msg
Case WM_LBUTTONDOWN
Me.Show
Shell_NotifyIcon NIM_DELETE, nID
Case WM_LBUTTONUP
Case WM_LBUTTONDBLCLK
Case WM_RBUTTONDOWN
Case WM_RBUTTONUP
Me.Show
Shell_NotifyIcon NIM_DELETE, nID
Case WM_RBUTTONDBLCLK
End Select
End Sub

Private Sub Form_Unload(Cancel As Integer)
On Error Resume Next

Shell_NotifyIcon NIM_DELETE, nID ' del tray icon
End Sub

Sub minimize_to_tray()
On Error Resume Next

Me.Hide
nID.cbSize = Len(nID)
nID.hWnd = Me.hWnd
nID.uId = vbNull
nID.uFlags = NIF_ICON Or NIF_TIP Or NIF_MESSAGE
nID.uCallBackMessage = WM_MOUSEMOVE
nID.hIcon = Me.Icon ' the icon will be your Form1 project icon
nID.szTip = "TD Online Müzik Oynatıcı" & vbNullChar
Shell_NotifyIcon NIM_ADD, nID
End Sub
Private Sub xpFrame1_Click()
minimize_to_tray
End Sub


    Public Type NOTIFYICONDATA
cbSize As Long
hWnd As Long
uId As Long
uFlags As Long
uCallBackMessage As Long
hIcon As Long
szTip As String * 64
End Type
Public Const NIM_ADD = &H0
Public Const NIM_MODIFY = &H1
Public Const NIM_DELETE = &H2
Public Const WM_MOUSEMOVE = &H200
Public Const NIF_MESSAGE = &H1
Public Const NIF_ICON = &H2
Public Const NIF_TIP = &H4
Public Const WM_LBUTTONDBLCLK = &H203 'Double-click
Public Const WM_LBUTTONDOWN = &H201 'Button down
Public Const WM_LBUTTONUP = &H202 'Button up
Public Const WM_RBUTTONDBLCLK = &H206 'Double-click
Public Const WM_RBUTTONDOWN = &H204 'Button down
Public Const WM_RBUTTONUP = &H205 'Button up

Public Declare Function Shell_NotifyIcon Lib "shell32" Alias "Shell_NotifyIconA" (ByVal dwMessage As Long, pnid As NOTIFYICONDATA) As Boolean

Private Declare Function SetWindowPos Lib "user32" (ByVal hWnd As Long, ByVal hWndInsertAfter As Long, ByVal X As Long, ByVal Y As Long, ByVal cX As Long, ByVal cY As Long, ByVal wFlags As Long) As Long
Const SWP_NOMOVE As Long = &H2
Const SWP_NOSIZE As Long = &H1
Const HWND_TOPMOST = -1
Const HWND_NOTOPMOST = -2


    Option Explicit
Private Declare Function SendMessage Lib "user32" Alias "SendMessageA" _
                        (ByVal hWnd As Long, ByVal wMsg As Long, ByVal wParam As Integer, _
                         ByVal lParam As Any) As Long
Private Const CB_FINDSTRINGEXACT = &H158
Private Const CB_FINDSTRING = &H14C
Private Const LB_FINDSTRINGEXACT = &H1A2
Private Const LB_FINDSTRING = &H18F

Public Declare Function GetTickCount Lib "kernel32" () As Long
Public Declare Function GetAsyncKeyState Lib "user32" (ByVal vKey As Long) As Integer

Public Sub wait(ByVal dblMilliseconds As Double)
    Dim dblStart As Double
    Dim dblEnd As Double
    Dim dblTickCount As Double
    dblTickCount = GetTickCount()
    dblStart = GetTickCount()
    dblEnd = GetTickCount + dblMilliseconds
    Do
    DoEvents
    dblTickCount = GetTickCount()
    Loop Until dblTickCount > dblEnd Or dblTickCount < dblStart
End Sub



Public Function SearchInComboBox(cboObject As ComboBox, intKeyCode, Optional bMatch As Boolean = True) As Long
    Dim strTemp As String
    Dim lngReturn As Long
    If intKeyCode >= 65 And intKeyCode <= 90 Then
        With cboObject
            strTemp = .Text
            If bMatch Then
                lngReturn = SendMessage(.hWnd, CB_FINDSTRINGEXACT, -1, ByVal strTemp)
            Else
                lngReturn = SendMessage(.hWnd, CB_FINDSTRING, -1, ByVal strTemp)
            End If
            If lngReturn <> -1 Then
                .ListIndex = lngReturn
                .SelStart = Len(strTemp)
                .SelLength = Len(.Text) - Len(strTemp)
            Else
                .Text = strTemp
                .SelStart = Len(.Text)
            End If
        End With
    End If
End Function
Public Function SearchInListBox(lstObject As ListBox, strTemp As String, Optional bMatch As Boolean = True) As Long
    Dim lngReturn As Long
    With lstObject
        If bMatch Then
            lngReturn = SendMessage(.hWnd, LB_FINDSTRINGEXACT, -1, ByVal strTemp)
        Else
            lngReturn = SendMessage(.hWnd, LB_FINDSTRING, -1, ByVal strTemp)
        End If
        .ListIndex = lngReturn
    End With
End Function
    Reply With Quote Alıntı yap
  2. KısayolKısayol reportŞikayet pmÖzel Mesaj
    aliyk
    aliyk's avatar
    Kayıt Tarihi: 07/Mayıs/2007
    Erkek

    programın kendisini vereydinde uğraşmıyaydık

    Lekum Dinikum Veliye Din ...
    Reply With Quote Alıntı yap
  3. KısayolKısayol reportŞikayet pmÖzel Mesaj
    DE5TROY3R
    DE5TROY3R's avatar
    Kayıt Tarihi: 04/Nisan/2007
    Erkek
    aliyk bunu yazdı

    programın kendisini vereydinde uğraşmıyaydık

    buyur

    http://www.tahribat.com/Forum-Td-Online-Muzik-Oynatici-156765/

    Reply With Quote Alıntı yap
  4. KısayolKısayol reportŞikayet pmÖzel Mesaj
    kady
    kady's avatar
    Kayıt Tarihi: 10/Kasım/2009
    Erkek
    DE5TROY3R bunu yazdı
    aliyk bunu yazdı

    programın kendisini vereydinde uğraşmıyaydık

    buyur

    http://www.tahribat.com/Forum-Td-Online-Muzik-Oynatici-156765/

    saol bakıyorum

    http://profil.gittigidiyor.com/kady
    Reply With Quote Alıntı yap
  5. KısayolKısayol reportŞikayet pmÖzel Mesaj
    asa42
    asa42's avatar
    Kayıt Tarihi: 17/Eylül/2009
    Erkek
    DE5TROY3R bunu yazdı
    aliyk bunu yazdı

    programın kendisini vereydinde uğraşmıyaydık

    buyur

    http://www.tahribat.com/Forum-Td-Online-Muzik-Oynatici-156765/

    Kaynak kod verdiğin iyi olmuş eline sağlık. C# a çevirip kullanabilirm ileride.

    Reply With Quote Alıntı yap
Toplam Hit: 1950 Toplam Mesaj: 5