Function GetData(strUrl) 'As String
'Uses Internet Explorer to return a string containing the
'contents of an http or ftp web page. This returns the worst
'quality of data but is the most likely to be supported
'without installing anything.
Dim web 'As InternetExplorer.Application
Dim doc 'As InternetExplorer.Document
Dim strWebPage 'As String
Set web = CreateObject("InternetExplorer.Application")
web.Navigate strUrl
Do While web.Busy
Loop
On Error Resume Next
Set doc = Nothing
Do Until Not doc Is Nothing
Set doc = web.Document
Loop
strWebPage = doc.body.OuterHTML
web.Quit
GetData = strWebPage
End Function
Function GetData(strUrl)
'Uses the Microsoft WinHttp 5.1 object included with:
'Windows 2000 SP3, Windows XP SP1, Windows Server 2003
'Falls back to using the older 5.0 object if available.
Dim web, strWebPage
Const HTTPREQUEST_SETCREDENTIALS_FOR_SERVER = 0
Const HTTPREQUEST_SETCREDENTIALS_FOR_PROXY = 1
Const WinHttpRequestOption_UserAgentString = 0
Const WinHttpRequestOption_EscapePercentInURL = 3
Const WinHttpRequestOption_EnableRedirects = 6
Const WinHttpRequestOption_UrlEscapeDisable = 7
Const WinHttpRequestOption_UrlEscapeDisableQuery = 8
Set web = Nothing
On Error Resume Next
Set web = CreateObject("WinHttp.WinHttpRequest.5.1")
On Error Resume Next
If web Is Nothing Then
Set web = CreateObject("WinHttp.WinHttpRequest.5")
End If
web.Option(WinHttpRequestOption_EnableRedirects) = True
web.Open "GET", strURL, False
'''''''''
' Can use below text if needed to log in to server
' web.SetCredentials(strUserName, strPassword, HTTPREQUEST_SETCREDENTIALS_FOR_SERVER)
'''''''''
'''''''''
' Could also use the below commented text to get all or specific header
' web.Open "HEAD", strURL, False
' web.Send
' GetData = web.GetResponseHeader("Set-Cookie")
' GetData = web.GetAllResponseHeaders
'''''''''
'''''''''
' Can use the below code to set a custom header
' web.SetRequestHeader "Cookie", "username=foo"
'''''''''
'''''''''
' Can use below text to POST data to a server
' web.Open "PUT", strURL, False
' web.Send "username=foo&password=bar"
'''''''''
'''''''''
' Can use below text to retrieve a binary (very slow string function conversion)
' web.Send
' varByteArray = web.ResponseBody
' For lngCounter = 0 to UBound(varByteArray)
' strWebPage = strWebPage & Chrw(Ascw(Chr(Ascb(Midb(varByteArray,lngCounter+1,1)))))
' Next
'''''''''
web.Send
If web.Status = "200" Then
strWebPage = web.ResponseText
'Try to follow META redirect pages
If InStr(1, strWebPage, " 0 Then
strWebPage = Mid(strWebPage, InStr(1, strWebPage, "") - 1)
Do While InStr(strWebPage, """") <> 0 : strWebPage = Replace(strWebPage, """", "") : Loop
strWebPage = Trim(strWebPage)
If InStr(strWebPage, " ") <> 0 Then strWebPage = Left(strWebPage, InStr(strWebPage, " ") - 1)
strWebPage = MakeAbsolute(strWebPage, strUrl)
'Change the input argument to notify the calling routine
strUrl = strWebPage
strWebPage = GetData(strWebPage)
End If
GetData = strWebPage
Else
GetData = ""
End If
End Function
Function GetData(strUrl) 'As String
'Uses the Microsoft XML parser (Windows 2000) or from:
'http://download.microsoft.com/download/9/6/5/9657c01e-107f-409c-baac-7d249561629c/msxmlcab.exe
'http://download.microsoft.com/download/9/6/5/9657c01e-107f-409c-baac-7d249561629c/msxml.msi
Dim web
Set web = CreateObject("Microsoft.XMLHTTP")
web.Open "GET", strUrl, False ', strUserName, strPassword
web.Send
' Could also use this to get all or specific header:
' web.Open "HEAD", strUrl, False
' web.Send
' GetData = web.getAllResponseHeaders
' GetData = web.getResponseHeader("server")
GetData = web.responseText
End Function
Function GetData(strUrl) 'As String
'Uses POST.EXE from http://www.ericphelps.com/webget/post.zip
'Downloads an http web page and returns a string containing the contents
Dim ts 'As Scripting.TextStream
Dim fs 'As Scripting.FileSystemObject
Dim web 'As Post.clsPost
Dim strWebPage 'As String
Dim strWebSite 'As String
Dim strResource 'As String
If left(strUrl,7) = "http://" Then
strWebSite = Mid(strUrl, 8)
Else
strWebSite = strUrl
End If
If Instr(strWebSite, "/") = 0 Then strWebSite = strWebSite & "/"
strResource = Mid(strWebSite, Instr(strWebSite, "/"))
strWebSite = Left(strWebSite, Instr(strWebSite, "/") - 1)
Set web = CreateObject("Post.clsPost")
web.DataTimeout = 120
web.SocketTimeout = 60
'Get it! (Force string so VBS doesn't try to pass a string-type variant instead)
strWebPage = web.GetHeader(Cstr(strWebSite), Cstr(strResource))
'Check to see if we got content
If ((Len(Mid(strWebPage, Instr(strWebPage, vbCrlf & vbCrlf) + 4)) = 0) Or (Left(strWebPage, 11) = "HTTP/1.1 30")) Then
If InStr(strWebPage, "Location:") <> 0 Then
'Recursive follow of http redirect. Trim the new location out of the response
strWebPage = Mid(strWebPage, InStr(strWebPage, "Location:") + 9)
strWebPage = Trim(strWebPage)
strWebPage = Left(strWebPage, InStr(strWebPage, vbCr) - 1)
'Change the input argument to notify the calling routine
strUrl = strWebPage
strWebPage = GetData(strWebPage)
Else
strWebPage = ""
End If
Else
'Recursive follow of meta tag redirect
If InStr(1, strWebPage, " 0 Then
strWebPage = Mid(strWebPage, InStr(1, strWebPage, "") - 1)
Do While InStr(strWebPage, """") <> 0 : strWebPage = Replace(strWebPage, """", "") : Loop
strWebPage = Trim(strWebPage)
If InStr(strWebPage, " ") <> 0 Then strWebPage = Left(strWebPage, InStr(strWebPage, " ") - 1)
strWebPage = MakeAbsolute(strWebPage, "http://" & strWebSite & strResource)
'Change the input argument to notify the calling routine
strUrl = strWebPage
strWebPage = GetData(strWebPage)
Else
'Remove the header
strWebPage = Mid(strWebPage, Instr(strWebPage, vbCrlf & vbCrlf) + 4)
End If
End If
GetData = strWebPage
End Function
Function GetData(strUrl) 'As String
'Uses MSINET.OCX from http://activex.microsoft.com/controls/vb5/msinet.cab
'Requires a Microsoft developer's license. May require license fix from
'ftp://ftp.microsoft.com/softlib/mslfiles/vbc.exe
'Returns a string containing the contents of a web page
Dim web 'As InetCtls.Inet
Dim strWebPage 'As String
Set web = CreateObject("InetCtls.Inet")
web.RequestTimeout = 60
strWebPage = web.OpenURL(Cstr(strUrl))
GetData = strWebPage
End Function
Function GetData(strUrl) 'As String
'Uses WGET.EXE from http://wget.sunsite.dk/
'to return a string containing the contents of an http web page
Dim ts 'As Scripting.TextStream
Dim wsh 'As Wscript.Shell
Dim fs 'As Scripting.FileSystemObject
Dim fil 'As Scripting.File
Dim strWebPage 'As String
Dim strTempFile 'As String
Const ForReading = 1
Const ForWriting = 2
Const TemporaryFolder = 2
Set fs = CreateObject("Scripting.FileSystemObject")
Set wsh = CreateObject("Wscript.Shell")
strTempFile = fs.BuildPath(fs.GetSpecialFolder(TemporaryFolder), fs.GetBaseName(Wscript.ScriptFullName) & ".tmp")
Set ts = fs.CreateTextFile(strTempFile, True)
ts.Close
Set fil = fs.GetFile(strTempFile)
wsh.Run "wget.exe -O " & fil.ShortPath & " " & strUrl, 0, True
Set ts = fs.OpenTextFile(strTempFile, ForReading, True)
strWebPage = ts.ReadAll
ts.Close
fil.Delete True
GetData = strWebPage
End Function
Function GetData(strUrl) 'As String
'This is not my original script, but is one of the public domain
'scripts included as a sample with PrimalSCRIPT. Credit for the
'script is attributed to "Eric K." and "Michael Harris". This
'script does a BINARY download. I've modified it here to suit
'my purposes. The "Chrw-Ascw-Chr-Ascb-Midb" is what is needed to
'perform a byte array to string conversion! Keep it in mind.
Dim xml 'As Microsoft.XMLHTTP
Dim strWebPage 'As String
Dim varByteArray 'As Variant
Dim lngCounter 'As Long
Set xml = CreateObject("Microsoft.XMLHTTP")
xml.Open "GET", strUrl, False
xml.Send
varByteArray = xml.ResponseBody
Set xml = Nothing
For lngCounter = 0 to UBound(varByteArray)
strWebPage = strWebPage & Chrw(Ascw(Chr(Ascb(Midb(varByteArray,lngCounter+1,1)))))
Next
GetData = strWebPage
End Function
Function GetData(strUrl) 'As String
'Uses WEBGET.EXE from http://www.ericphelps.com/webget/get.zip
'Downloads an http web page and returns a string containing the contents
Dim web 'As WebGet.Web
Dim sRxData 'As String
Set web = CreateObject("WebGet.Web")
If Left(strUrl, 7) <> "http://" Then strUrl = "http://" & strUrl
web.URL = strUrl
sRxData = web.GetText
GetData = sRxData
End Function