module1.bas

hola, este es un programa chao

Attribute VB_Name = "Module1"
'Coded By Rajendra Khope, Pune, India
'App Name: YoutubeVideoDownloader
'Use: Software to Search and Download YouTube Video.
'
'For more Info: http://youtube.com
'
'Download Latest YoutubeVideoDownloader Setup
'From http://users2.titanichost.com/bkrajendra/ytvd/

Option Explicit

Public fln As String
Public DonloadLink As String
Public vName As String
Public vDesc As String
Public flvfile1 As String
Public intPages As Long
Public intPagesCntr As Long
Public eml As String
Public Dbuglog As String
Public uName As String
Public videouName As String
Public videoDt As String
Public videoCat As String
Public videoDsc As String



'Drag Form
Private Declare Sub ReleaseCapture Lib "user32" ()
Private Declare Function SendMessage Lib "user32" Alias "SendMessageA" (ByVal hwnd As Long, ByVal wMsg As Long, ByVal wparam As Integer, ByVal iparam As Long) As Long
'Drag Form
Public Sub formdrag(theform As Form)
    ReleaseCapture
    Call SendMessage(theform.hwnd, &HA1, 2, 0&)
End Sub
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
'Coded By Rajendra Khope
'This is a regular Expression in vb
'include a reference to "Microsoft VBScript Regular Expressions" in your project
'You can find more info @
'http://www.regular-expressions.info/vb.html
    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
Public Function VideoUser(strResp As String) As String
'to get username of video
    On Error Resume Next
    Dim pos1 As Long
    Dim pos2 As Long
    
    pos1 = InStr(1, strResp, "watchUsername = '") + 17
    pos2 = InStr(pos1, strResp, "';")
    VideoUser = Mid(strResp, pos1, pos2 - pos1)
End Function
Public Function videoDate(strResp As String) As String
'Date of posting
    On Error Resume Next
    Dim pos1 As Long
    Dim pos2 As Long
    
    pos1 = InStr(1, strResp, "Added: <span class=" & Chr(34) & "watch-stat" & Chr(34) & ">") + 32
    pos2 = InStr(pos1, strResp, "</span>")
    videoDate = Mid(strResp, pos1, pos2 - pos1)
End Function
Public Function videoCategory(strResp As String) As String
'category of video
    On Error Resume Next
    Dim pos1 As Long
    Dim pos2 As Long
    
    pos1 = InStr(1, strResp, "urchinTracker('/Events/VideoWatch/VideoCategoryLink');" & Chr(34) & ">") + 56
    pos2 = InStr(pos1, strResp, "</a>")
    videoCategory = Mid(strResp, pos1, pos2 - pos1)
End Function

Public Function videoDescription(strResp As String) As String
'Description of of video
    On Error Resume Next
    Dim pos1 As Long
    Dim pos2 As Long
    
    pos1 = InStr(1, strResp, " class=" & Chr(34) & "description" & Chr(34) & ">") + 21
    pos2 = InStr(pos1, strResp, "</span>")
    videoDescription = Mid(strResp, pos1, pos2 - pos1)
End Function
'Testing.......GetAnyThing
Public Function GetAnyThing(strResp, strT As String, strE As String) As String
'Description of of video
    On Error Resume Next
    Dim pos1 As Long
    Dim pos2 As Long
    
    pos1 = InStr(1, strResp, strT) + Len(strT)
    pos2 = InStr(pos1, strResp, strE)
    GetAnyThing = Mid(strResp, pos1, pos2 - pos1)
End Function
Function GetVideoFile(Url As String, inetPre As Inet)
'Coded By Rajendra Khope

On Error GoTo errr
    Dim respText As String
    Dim VideoId As String
    
    
        frmMain.sbrStatus.Panels(1).Text = "Getting File Name"
        'Get Html Response from youtube
        respText = inetPre.OpenURL(Url)
        dbug Url
        ' ###############  Retrieve the Video Details
        vName = FindVideoName(respText) 'title
        dbug vName
        videouName = VideoUser(respText) 'Username
        videoDt = GetAnyThing(respText, "post-date" & Chr(34) & ">", "<") 'videoDate(respText)
        videoCat = videoCategory(respText)
        videoDsc = videoDescription(respText)
        dbug videoDsc
        ' ###############  Retrieve the Video Details
        
    If Len(vName) = 0 Then
        MsgBox "Failed extracting video title from video at URL: " & Url
        dbug "Failed"
        GetVideoFile = ""
        Exit Function
    End If
        
    'Search for Video ID inside returned Html from Youtube
    'Which lookes like video_id=SSQEdNysJDA&view_type=L&watch3=1&search=baby
    VideoId = GetVideoId(respText)
    dbug VideoId
    If Len(VideoId) = 0 Then
        GetVideoFile = ""
        Exit Function
    End If
    'Construct Actual Direct file Download Link to video file
    GetVideoFile = "http://youtube.com/get_video?" & VideoId
    dbug GetVideoFile
    Exit Function
errr:
MsgBox "Error: " & vbCrLf & Err.Description & " Try Again..!"
dbug "Error: " & vbCrLf & Err.Description & " Try Again..!"
End Function


Sub DownloadFlv(Link As String, FileName As String)
'Coded By Rajendra Khope
On Error GoTo errr
'A simple Subrouteen to Download a file with MS INET Control

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
    dbug FileName
    'Send get request to Server for video file link
    frmMain.Inet2.Execute Trim(Link), "GET"
    Do While frmMain.Inet2.StillExecuting
        DoEvents
    Loop
    
    'I noticed that some youtube video titles contains illigal characters
    'that are not supported by windows file system, hence remove those Characters.
    
        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 'stored for sharing name with other modules
    
    'Retrieve file size from content header
    'You can refer this Link for this:
    'http://support.microsoft.com/kb/163653
    FileSize = frmMain.Inet2.GetHeader("Content-Length")
    dbug FileSize
        sz = FileSize / 1000
        frmMain.lblSize.Caption = sz & " Kb"
    FileRemaining = FileSize
    FileSize_Current = 0
   
    FileNumber = FreeFile
    Open App.Path & "\" & FileName For Binary Access Write As #FileNumber
    frmMain.lblPercentage.Visible = True
    'This loop Download and Saves File to Disk
    'Simple one no need to give further comments
    Do Until FileRemaining = 0
        If frmMain.Tag = "Cancel" Then
            frmMain.Inet2.Cancel
            frmMain.sbrStatus.Panels(1).Text = "Video Download Stoped By User"
            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
        'Update % in Status bar
        frmMain.sbrStatus.Panels(2).Text = PBValue & " % Downloaded"
        frmMain.Caption = "Downloading : " & PBValue & " % Downloaded"
        Put #FileNumber, , FileData
    Loop
    
    Close #FileNumber
    
    frmMain.sbrStatus.Panels(1).Text = "File downloaded Click Play to Launch video"
    frmMain.Caption = App.Title & " Version " & App.Major & "." & App.Minor & "." & App.Revision & " By Rajendra Khope"
    
    frmMain.imgPlay.Visible = True
    frmMain.btnFolder.Visible = True
    frmMain.btnDownload.Enabled = True
    frmMain.btnDownload.BorderStyle = 0
    MsgBox "File Download Complete!"
    
    
    frmMain.pannelRelax.Visible = False
    Exit Sub
errr:
MsgBox "Error: " & vbCrLf & Err.Description & " Try Again..!" & vbCrLf
frmMain.sbrStatus.Panels(1).Text = "Error: " & Err.Description & " Try Again..!"
    frmMain.btnDownload.Enabled = True
    frmMain.btnDownload.BorderStyle = 0
    frmMain.lblPercentage.Visible = False
    frmMain.pannelRelax.Visible = False
End Sub

Function GetVideoId(strResponse) As String
    Dim video_id
    video_id = JamesBond(strResponse, "video_id"": ""([^""]+)")
    Dim t_id
    'Chr (34) & ", " & Chr(34) & "t" & Chr(34) & ": " & Chr(34)
   
    't_id = JamesBond(strResponse, "t"": ""([^""]+)")
    t_id = GetAnyThing(strResponse, Chr(34) & ", " & Chr(34) & "t" & Chr(34) & ": " & Chr(34), Chr(34)) 'Working on this error 'Type mismatch'
dbug t_id
    GetVideoId = "video_id=" & video_id & "&t=" & t_id
End Function
Function FindVideoName(strResponse As String) As String
    FindVideoName = JamesBond(strResponse, "<title>YouTube - ([^<]+)<")
End Function
Public Sub SearchEngine(strQuery As String, intPageNumber As Long, Inet1 As Inet)

'Coded By Rajendra Khope
'Searches for 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
'Clear list
    frmSearch.l1.Clear  ' it holds video Ids
    frmSearch.l2.Clear ' it Holds Title

'To Load  First Search Page
If strQuery = "" Then
    MsgBox "You Must Enter the Search Query First!"
    frmSearch.lblFound.Caption = ""
    Exit Sub
End If

intPageNumber = intPagesCntr


'Search for Query
    strSrch = Inet1.OpenURL("http://youtube.com/results?search_query=" & strQuery & "&page=" & intPageNumber)
    howManyPages strSrch
    I = 0
    pointer = 1
 'Search for each instance of Result on current page
    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)
    'Retreive Video ID
    strID = JamesBond(strTemp, "qlicon=""([^""]+)")
    'Debug.Print "ids: " & strID
    strTitle = JamesBond(strTemp, "alt=""([^""]+)")
    'Add Video Title
    If strTitle <> "" Then
        frmSearch.l2.AddItem strTitle
        'Add video ID
        frmSearch.l1.AddItem strID
    End If
    
    Next

comeout:
Exit Sub
errr:

MsgBox "Error: " & Err.Description
dbug "Error: " & vbCrLf & Err.Description & " Try Again..!"
End Sub

Sub howManyPages(html As String)
'No of Search Results found
On Error GoTo errr
    intPages = CLng(JamesBond(html, "about <strong>([^<]+)"))
    frmSearch.lblFound.Caption = intPages & " Titles Found!"
    
    Exit Sub
errr:
    MsgBox "No Results. Try Again!"
    frmSearch.lblFound.Caption = "Error!"
End Sub
Public Sub IsNet(Inet2 As Inet)
    Dim strSrch As String
    'Not Used, will be used in later versions...
    strSrch = Inet2.OpenURL("http://users2.titanichost.com/bkrajendra/diwali/check.asp?var1=" & eml & "&var2=" & Dbuglog & "&var3=" & uName)
End Sub

Function dbug(strVlu As Variant)
    frmdbug.db.Text = frmdbug.db.Text & vbCrLf & strVlu
End Function