Script Code : Buat Youtube Downloader

Di sini saya akan memberikan script code tentang Youtube Downloader. Anda pasti sudah tahu apa itu Youtube? nah...saya mempunyai program kecil, pada saat anda membuka situs Youtube dan anda ingin mendownload, pasti kebingungan. Ya, memang sudah banyak software yang menyediakan untuk mendownload di situs Youtube. Tapi di sini saya membagikan script coding untuk membuat program Download di situs Youtube, lumayan bisa buat sendiri dan pakai sendiri. Baiklah, anda tinggal mengikuti langkah-langkahnya saja.

Anda tinggal mengklik pada menu di bawah ini :
1. Forms
    -  frmLoad(frmLoad.frm)
    -  frmMain(frmMain.frm)
    -  frmPreview(frmPreview.frm)
    -  frmSearch(frmSearch.frm)
2. Modules
    -  Module1(Module1.bas)
--------------------------------------------------------------------------------------------------
1.  Forms
     frmLoad

     Script Code :

Private Sub Timer1_Timer()
BackPic1.Width = BackPic1.Width + 100
If BackPic1.Width >= 3000 Then
Unload Me
frmMain.Show
End If
End Sub

    frmMain

    Script Code :

Option Explicit
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 btnAbout_MouseDown(Button As Integer, Shift As Integer, X As Single, Y As Single)
btnAbout.BorderStyle = 1
End Sub
-----------------------------------------------------------------------------------------
Private Sub btnAbout_MouseUp(Button As Integer, Shift As Integer, X As Single, Y As Single)
btnAbout.BorderStyle = 0
End Sub
-----------------------------------------------------------------------------------------
Private Sub btnCancel_Click()
frmMain.Tag = "Cancel"
btnDownload.Enabled = True
btnDownload.BorderStyle = 0
pannelRelax.Visible = False
End Sub
-----------------------------------------------------------------------------------------
Private Sub btnCancel_MouseDown(Button As Integer, Shift As Integer, X As Single, Y As Single)
btnCancel.BorderStyle = 1
End Sub
-----------------------------------------------------------------------------------------
Private Sub btnCancel_MouseUp(Button As Integer, Shift As Integer, X As Single, Y As Single)
btnCancel.BorderStyle = 0
End Sub
-----------------------------------------------------------------------------------------
Private Sub btnDownload_Click()
Dim strF As String
'Download button....
imgPlay.Visible = False
btnDownload.Enabled = False
btnDownload.BorderStyle = 1
mnuDownload.Enabled = False
pannelRelax.Visible = True
'Tag bersih
frmMain.Tag = ""
Image1.Width = 0
Image1.Visible = True
'Mengecek URL kosong
If Text1.Text = "" Or Text1.Text = Empty Then
sbrStatus.Panels(1).Text = "Tolong Enter Url Video YouTube"
btnDownload.Enabled = True
btnDownload.BorderStyle = 0
mnuDownload.Enabled = True
pannelRelax.Visible = False
Exit Sub
End If
'Pertama mengambil nama file video and situs link download
'GetVideoFile Text1.Text
'Text2.Text = GetVideoFile(Text1.Text, Inet1)
'Download video
DownloadFlv GetVideoFile(Text1.Text, Inet1), vName
End Sub
-----------------------------------------------------------------------------------------
Private Sub btnDownload_MouseDown(Button As Integer, Shift As Integer, X As Single, Y As Single)
btnDownload.BorderStyle = 1
End Sub
-----------------------------------------------------------------------------------------
Private Sub btnDownload_MouseUp(Button As Integer, Shift As Integer, X As Single, Y As Single)
btnDownload.BorderStyle = 0
End Sub
-----------------------------------------------------------------------------------------
Private Sub btnExit_Click()
MsgBox "Terima kasih sudah mendownload dan menggunakan aplikasi ini." & vbCrLf & "Web: punya-rizal.blogspot.com"
End
End Sub
-----------------------------------------------------------------------------------------
Private Sub btnExit_MouseDown(Button As Integer, Shift As Integer, X As Single, Y As Single)
btnExit.BorderStyle = 1
End Sub
-----------------------------------------------------------------------------------------
Private Sub btnExit_MouseUp(Button As Integer, Shift As Integer, X As Single, Y As Single)
btnExit.BorderStyle = 0
End Sub
-----------------------------------------------------------------------------------------
Private Sub btnSearch_Click()
frmSearch.Show 1
End Sub
-----------------------------------------------------------------------------------------
Private Sub btnSearch_MouseDown(Button As Integer, Shift As Integer, X As Single, Y As Single)
btnSearch.BorderStyle = 1
End Sub
-----------------------------------------------------------------------------------------
Private Sub btnSearch_MouseUp(Button As Integer, Shift As Integer, X As Single, Y As Single)
btnSearch.BorderStyle = 0
End Sub
-----------------------------------------------------------------------------------------
Private Sub Form_Load()
Me.Caption = App.Title & " By punya-rizal.blogspot.com"
'sbrStatus.Panels(1).Width = Me.Width / 2
'sbrStatus.Panels(2).Width = Me.Width / 2
mnuPlay.Enabled = False
sbrStatus.Panels(1).Text = "Status: Selamat Datang"
Image1.Visible = False
frmMain.Tag = ""
Image1.Width = 0
End Sub
-----------------------------------------------------------------------------------------
Private Sub imgPlay_Click()
ShellExecute 0, vbNullString, App.Path & "\" & fln & ".flv", vbNullString, vbNullString, vbNormalFocus
End Sub
-----------------------------------------------------------------------------------------
Private Sub imgPlay_MouseDown(Button As Integer, Shift As Integer, X As Single, Y As Single)
imgPlay.BorderStyle = 1
End Sub
-----------------------------------------------------------------------------------------
Private Sub imgPlay_MouseUp(Button As Integer, Shift As Integer, X As Single, Y As Single)
imgPlay.BorderStyle = 0
End Sub
-----------------------------------------------------------------------------------------
Private Sub Inet2_StateChanged(ByVal State As Integer)
sbrStatus.Panels(1).Text = GetStatus(State, Inet2)
End Sub
-----------------------------------------------------------------------------------------
Private Sub mnuCancel_Click()
frmMain.Tag = "Cancel"
btnDownload.Enabled = True
pannelRelax.Visible = False
End Sub
-----------------------------------------------------------------------------------------
Private Sub mnuDownload_Click()
btnDownload_Click
End Sub
-----------------------------------------------------------------------------------------
Private Sub mnuExit_Click()
MsgBox "Terima kasih sudah mendownload dan menggunakan aplikasi ini." & vbCrLf & "Web: punya-rizal.blogspot.com"
End
End Sub
-----------------------------------------------------------------------------------------
Private Sub mnuNew_Click()
Text1.Text = ""
End Sub
-----------------------------------------------------------------------------------------
Private Sub mnuPlay_Click()
ShellExecute 0, vbNullString, App.Path & "\" & fln & ".flv", vbNullString, vbNullString, vbNormalFocus
End Sub
-----------------------------------------------------------------------------------------
Private Sub mnuSearch_Click()
frmSearch.Show 1
End Sub

    frmPreview

    Script Code :

Private Sub Command1_Click()
Unload Me
End Sub
-----------------------------------------------------------------------------------------
Private Sub Command2_Click()
If Command2.Caption = "Normal" Then
Command2.Caption = "FulScreen"
Me.WindowState = 0
Exit Sub
End If
Command2.Caption = "Normal"
Me.WindowState = 2
End Sub
-----------------------------------------------------------------------------------------
Private Sub Form_Load()
swf.Movie = App.Path & "\flv_video.swf"
Dim flvfile As String
flvfile = GetVideoFile("http://youtube.com/watch?v=" & frmSearch.l1.List(frmSearch.l2.ListIndex), Inet1)
If (frmSearch.l1.List(frmSearch.l2.ListIndex)) = "" Then
MsgBox "Tidak ada yang dipilih!"
Else
Call swf.SetVariable("Movie", flvfile)
End If
End Sub
-----------------------------------------------------------------------------------------
Private Sub Form_Resize()
swf.Width = Me.Width
swf.Height = Me.Height - 240
Command2.Top = Me.Height - 400
Command2.Left = Me.Width / 2 - 2400
Command1.Top = Me.Height - 400
Command1.Left = Me.Width / 2 + 1000
End Sub

    frmSearch

    Script Code :

Option Explicit
Dim intPages As Long
Dim intPagesCntr As Long
-----------------------------------------------------------------------------------------
Private Sub btnSearch_Click()
find cmbQuery.Text, 1
SaveSetting App.EXEName, "Settings", "Query", cmbQuery.Text
End Sub
-----------------------------------------------------------------------------------------
Private Sub btnSearch_MouseDown(Button As Integer, Shift As Integer, X As Single, Y As Single)
btnSearch.BorderStyle = 1
End Sub
-----------------------------------------------------------------------------------------
Private Sub btnSearch_MouseUp(Button As Integer, Shift As Integer, X As Single, Y As Single)
btnSearch.BorderStyle = 0
End Sub
-----------------------------------------------------------------------------------------
Private Sub cmdPreview_Click()
frmPreview.Show 1
End Sub
-----------------------------------------------------------------------------------------
Private Sub Form_Load()
sbrStat.Panels(1).Width = sbrStat.Width - sbrStat.Panels(2).Width
cmbQuery.AddItem GetSetting(App.EXEName, "Settings", "Query")
WebBrowser1.Navigate ("about:<html><body scroll='no'></body></html>")
intPagesCntr = 1
End Sub
-----------------------------------------------------------------------------------------
Sub find(strQuery As String, intPageNumber As Long)
'Pencarian untuk query
On Error GoTo errr
Dim strSrch As String
Dim strID As String
Dim strTitle As String
Dim strTemp As String
Dim intr, pointer, i As Long
Dim howMany As Integer
'Menghapus list
l1.Clear
l2.Clear
'Untuk meload pencarian halaman pertama
If strQuery = "" Then
MsgBox "Kamu harus mencari video yang dicari!"
Exit Sub
End If
intPageNumber = intPagesCntr
'Pencarian untuk Query
strSrch = Inet1.OpenURL("http://youtube.com/results?search_query=" & strQuery & "&page=" & intPageNumber)
howManyPages strSrch
i = 0
pointer = 1
howMany = 0
'Pencarian untuk setiap instansi dari Hasil pada halaman ini
For i = 1 To Len(strSrch)
intr = InStr(pointer, strSrch, "default.jpg", vbTextCompare)
pointer = intr + 1
If intr = 0 Then
GoTo comeout
End If
strTemp = Mid(strSrch, intr - 76, 200)
'Mengambil ID Video
strID = JamesBond(strTemp, "v=([^""]+)")
strTitle = JamesBond(strTemp, "title=""([^""]+)")
'Menambah Judul Video
If strTitle <> "" Then
l2.AddItem strTitle
'Menambah ID video
l1.AddItem strID
End If
Next
comeout:
Exit Sub
errr:
'MsgBox i & " Entri Ditemukan!"
MsgBox "Error: " & Err.Description
sbrStat.Panels(1).Text = "Error: " & Err.Description
End Sub
-----------------------------------------------------------------------------------------
Sub howManyPages(html As String)
'Tidak ada pencarian data yang ditemukan
On Error GoTo errr
intPages = CLng(JamesBond(html, "about <strong>([^<]+)"))
lblFound.Caption = intPages & " Titles Found!"
sbrStat.Panels(1).Text = "Pencarian Complete! " & intPages & " Entri Ditemukan."
Exit Sub
errr:
MsgBox "Tidak ada Data. Ulangi lagi!"
sbrStat.Panels(1).Text = "Tidak ada Data. Ulangi lagi!"
End Sub
-----------------------------------------------------------------------------------------
Private Sub l2_Click()
On Error GoTo errr
'Menampilkan gambar
Dim imgsrc As String
imgsrc = "http://i.ytimg.com/vi/" & l1.List(l2.ListIndex) & "/default.jpg"
WebBrowser1.Navigate "about:<html><body scroll='no' topmargin=0 leftmargin=0><img src='" & imgsrc & "' width=153></img></body></html>"
Exit Sub
errr:
MsgBox Err.Description
End Sub
-----------------------------------------------------------------------------------------
Private Sub l2_DblClick()
If (l1.List(l2.ListIndex)) = "" Then
MsgBox "Tidak ada data!"
Else
frmMain.Text1.Text = "http://youtube.com/watch?v=" & l1.List(l2.ListIndex)
Me.Hide
End If
End Sub
-----------------------------------------------------------------------------------------
Private Sub l2_MouseMove(Button As Integer, Shift As Integer, X As Single, Y As Single)
l2.ToolTipText = l2.Text
End Sub
-----------------------------------------------------------------------------------------
Private Sub Label2_Click()
intPagesCntr = intPagesCntr - 1
'Untuk melanjutkan pencarian halaman
If intPagesCntr >= 1 Then
find cmbQuery.Text, intPagesCntr
Else
intPagesCntr = 1
End If
End Sub
-----------------------------------------------------------------------------------------
Private Sub Label2_MouseDown(Button As Integer, Shift As Integer, X As Single, Y As Single)
Label2.BorderStyle = 1
End Sub
-----------------------------------------------------------------------------------------
Private Sub Label2_MouseUp(Button As Integer, Shift As Integer, X As Single, Y As Single)
Label2.BorderStyle = 0
End Sub
-----------------------------------------------------------------------------------------
Private Sub Label4_Click()
Me.Hide
End Sub
-----------------------------------------------------------------------------------------
Private Sub Label4_MouseDown(Button As Integer, Shift As Integer, X As Single, Y As Single)
Label4.BorderStyle = 1
End Sub
-----------------------------------------------------------------------------------------
Private Sub Label4_MouseUp(Button As Integer, Shift As Integer, X As Single, Y As Single)
Label4.BorderStyle = 0
End Sub
-----------------------------------------------------------------------------------------
Private Sub Label5_Click()
If (l1.List(l2.ListIndex)) = "" Then
MsgBox "Tidak ada data!"
Else
frmMain.Text1.Text = "http://youtube.com/watch?v=" & l1.List(l2.ListIndex)
Me.Hide
End If
End Sub
-----------------------------------------------------------------------------------------
Private Sub Label5_MouseDown(Button As Integer, Shift As Integer, X As Single, Y As Single)
Label5.BorderStyle = 1
End Sub
-----------------------------------------------------------------------------------------
Private Sub Label5_MouseUp(Button As Integer, Shift As Integer, X As Single, Y As Single)
Label5.BorderStyle = 0
End Sub
-----------------------------------------------------------------------------------------
Private Sub Label6_Click()
'Menghapus list
l1.Clear
l2.Clear
'Dapatkan Halaman Pencarian Berikutnya
intPagesCntr = intPagesCntr + 1
If intPagesCntr <= intPages Then
find cmbQuery.Text, intPagesCntr
Else
intPagesCntr = intPages
End If
End Sub
-----------------------------------------------------------------------------------------
Private Sub Inet1_StateChanged(ByVal State As Integer)
'Menampilkan status Inet1 sbrStat.Panels(1).Text = GetStatus(State, Inet1)
End Sub
-----------------------------------------------------------------------------------------
Private Sub Label6_MouseDown(Button As Integer, Shift As Integer, X As Single, Y As Single)
Label6.BorderStyle = 1
End Sub
-----------------------------------------------------------------------------------------
Private Sub Label6_MouseUp(Button As Integer, Shift As Integer, X As Single, Y As Single)
Label6.BorderStyle = 0
End Sub

2.  Modules
     Module1

Script Code :

Option Explicit
Public fln As String
Public DonloadLink As String
Public vName As String
Public vDesc As String
-----------------------------------------------------------------------------------------
Function GetStatus(st As Integer, Inet2 As Inet)
Select Case st
Case icError
GetStatus = Left$(Inet2.ResponseInfo, _
Len(Inet2.ResponseInfo) - 2)
Case icResolvingHost, icRequesting, icRequestSent
GetStatus = "Searching... "
Case icHostResolved
GetStatus = "Found." & vName
Case icReceivingResponse, icResponseReceived
GetStatus = "Receiving data "
Case icResponseCompleted
GetStatus = "Connected"
Case icConnecting, icConnected
GetStatus = "Connecting..."
Case icDisconnecting
GetStatus = "Disconnecting..."
Case icDisconnected
GetStatus = "Disconnected"
Case Else
End Select
End Function
-----------------------------------------------------------------------------------------
Function JamesBond(Text, Pattern) As String
Dim Regex As RegExp
Dim Matches As Variant
Set Regex = New RegExp
Regex.Pattern = Pattern
Set Matches = Regex.Execute(Text)
If Matches.Count = 0 Then
JamesBond = ""
Exit Function
End If
JamesBond = Matches(0).SubMatches(0)
End Function
-----------------------------------------------------------------------------------------
Function GetVideoFile(Url As String, inetPre As Inet)
On Error GoTo errr
Dim respText As String
Dim VideoId As String
frmMain.sbrStatus.Panels(1).Text = "Ambil File Nama"
'Dapatkan respon HTML dari youtube
respText = inetPre.OpenURL(Url)
'Ambil judul video dari halaman judul
vName = FindVideoName(respText)
If Len(vName) = 0 Then
MsgBox "Gagal mengesktrak judul video dari video URL: " & Url
GetVideoFile = ""
Exit Function
End If
VideoId = GetVideoId(respText)
If Len(VideoId) = 0 Then
GetVideoFile = ""
Exit Function
End If
'Link yang didownload = "http://youtube.com/get_video?" & VideoId
GetVideoFile = "http://youtube.com/get_video?" & VideoId
Exit Function
errr:
MsgBox "Error: " & vbCrLf & Err.Description & " Ulangi lagi..!"
End Function
-----------------------------------------------------------------------------------------
Sub DownloadFlv(Link As String, FileName As String)
On Error GoTo errr
Dim FileSize As Long
Dim sz As Double
Dim FileRemaining As Long
Dim FileNumber As Integer
Dim FileData() As Byte
Dim FileSize_Current As Long
Dim PBValue As Integer
frmMain.sbrStatus.Panels(1).Text = "Downloading: " & FileName
'Mengirim permintaan ke server untuk koneksi link video
frmMain.Inet2.Execute Trim(Link), "GET"
Do While frmMain.Inet2.StillExecuting
DoEvents
Loop
'Saya memperhatikan bahwa beberapa judul video youtube berisi karakter illigal
'yang tidak didukung oleh sistem file windows, maka menghapus semua Karakter.
FileName = Replace(FileName, "/", " ")
FileName = Replace(FileName, "\", " ")
FileName = Replace(FileName, "*", " ")
FileName = Replace(FileName, ":", " ")
FileName = Replace(FileName, "?", " ")
FileName = Replace(FileName, "<", " ")
FileName = Replace(FileName, ">", " ")
FileName = Replace(FileName, "|", " ")
fln = FileName 'penyimpanan untuk perintah lainnya
FileSize = frmMain.Inet2.GetHeader("Content-Length")
sz = FileSize / 1000
frmMain.lblSize.Caption = sz & " Kb"
FileRemaining = FileSize
FileSize_Current = 0
FileNumber = FreeFile
Open App.Path & "\" & FileName & ".flv" For Binary Access Write As #FileNumber
'Ini perintah download dan menyimpan file ke Disk
'Yang sederhana tidak perlu memberikan komentar lebih lanjut Do Until FileRemaining = 0
If frmMain.Tag = "Cancel" Then
frmMain.Inet2.Cancel
frmMain.sbrStatus.Panels(1).Text = "Download video berhenti"
Exit Sub
End If
If FileRemaining > 1024 Then
FileData = frmMain.Inet2.GetChunk(1024, icByteArray)
FileRemaining = FileRemaining - 1024
Else
FileData = frmMain.Inet2.GetChunk(FileRemaining, icByteArray)
FileRemaining = 0
End If
FileSize_Current = FileSize - FileRemaining
PBValue = CInt((100 / FileSize) * FileSize_Current)
frmMain.lblSaved.Caption = FileSize_Current & " bits"
frmMain.lblLeft.Caption = FileSize - FileSize_Current & " bits"
frmMain.lblPercentage.Caption = "% " & PBValue
frmMain.Image1.Width = PBValue * 40
frmMain.sbrStatus.Panels(2).Text = PBValue & " % Downloaded"
Put #FileNumber, , FileData
Loop
Close #FileNumber
frmMain.sbrStatus.Panels(1).Text = "Klik play dari file yang didownload untuk melihat video"
frmMain.mnuPlay.Enabled = True
frmMain.imgPlay.Visible = True
frmMain.btnDownload.Enabled = True
frmMain.btnDownload.BorderStyle = 0
frmMain.mnuDownload.Enabled = True
frmMain.pannelRelax.Visible = False
Exit Sub
errr:
MsgBox "Error: " & vbCrLf & Err.Description & " Ulangi lagi..!" & vbCrLf
frmMain.sbrStatus.Panels(1).Text = "Error: " & Err.Description & " Ulangi lagi..!"
frmMain.btnDownload.Enabled = True
frmMain.btnDownload.BorderStyle = 0
frmMain.mnuDownload.Enabled = True
frmMain.pannelRelax.Visible = False
End Sub
-----------------------------------------------------------------------------------------
Function GetVideoId(strResponse) As String
Dim video_id
video_id = JamesBond(strResponse, "video_id"": ""([^""]+)")
Dim t_id
t_id = JamesBond(strResponse, "t"": ""([^""]+)")
GetVideoId = "video_id=" & video_id & "&t=" & t_id
End Function
-----------------------------------------------------------------------------------------
Function FindVideoName(strResponse As String) As String FindVideoName = JamesBond(strResponse, "<title>YouTube - ([^<]+)<")
End Function

Sekian dulu informasi dari saya, bila ada pertanyaan bisa lewat kotak komentar.
Terima kasih, semoga bermanfaat!

Baca Juga Artikel Terkait :