Option Explicit
Private Declare Function DoFileDownload _
Lib "shdocvw.dll" ( _
ByVal lpszFile As String) _
As Long
Sub DownLoadYouTubeVideo()
'///////////////////////////////////////////////////////////////////////////////////////
'// Routine to download Video from YouTube
'// Requires: This project needs a reference to "Microsoft Internet Controls" and
'// "Microsoft HTML Object Library"
'// Inputs: Valid YouTube address of Viewing Video
'// : eg. Paul Potts, 'Britains Got Talent * Paul Potts WOWS with Nessun Dorma!'
'// : http://www.youtube.com/watch?v=exyJ2CSfrHo
'// : Must be in abov format..just copy from address Bar
'// By Ivan F Moala
'// http://www.xcelfiles.com
'// 18th Aug 2007
'///////////////////////////////////////////////////////////////////////////////////////
Dim strVideoUrl As String
Dim strCode As String
Dim objIE As Object
Dim PosLastID As Long, PosVideoID As Long
'// "Microsoft HTML Object Library"
Dim HtmlDoc As New HTMLDocument
Dim strYouTubeURL As String
Set objIE = New InternetExplorer
'// Paul Potts - change here as required
strYouTubeURL = "http://www.youtube.com/watch?v=exyJ2CSfrHo"
'// 720 Dunk
'strYouTubeURL = "http://www.youtube.com/watch?v=9Xpcgthwdp0"
'// Goto YouTube Site specified
With objIE
.navigate strYouTubeURL
'// Remove IF you want it visible, you may hear the audio
'.Visible = True
'// Wait for the page to load
Do While .Busy Or .readyState <> READYSTATE_COMPLETE
DoEvents
Loop
End With
'// Set Document object
Set HtmlDoc = objIE.Document
'// Set new IE Document into variable
Set HtmlDoc = objIE.Document
'// Extract HTML code from page whch contains OBJECT id = movie_player
strCode = HtmlDoc.Body.innerHTML
'// Find position of LastID
PosLastID = InStr(1, strCode, "&sk=")
'// Find position of VideoID
PosVideoID = InStr(1, strCode, "amp;video_id")
'// Get FileID
strVideoUrl = Mid(strCode, PosVideoID + 13, PosLastID - PosVideoID - 13)
'// Replace amp; as the 1st PARAM does NOT have Ctrl char and apend to URL_GET_VIDEO
strVideoUrl = "http://youtube.com/get_video?video_id=" & Replace(strVideoUrl, "amp;", "", 1)
'// Prompt user to Name with FLV extension
MsgBox "The File Download Dialog box will appear shortly." & vbCrLf & _
"When it prompts you to download, ensure you" & vbCrLf & _
"name the file with an .flv extension.", vbInformation, "Name file convention"
Dim Ret As Long
'// Try downloading via Windows Download dialog
Ret = DoFileDownload(StrConv(strVideoUrl, vbUnicode))
'// Close site properly
objIE.Quit
Set objIE = Nothing
Set HtmlDoc = Nothing
End Sub