Attribute VB_Name = "modHtmlSource"
Option Explicit
'
'
'=============================================================================================================
'
' modHtmlSource Module
' --------------------
'
' Created By  : Kevin Wilson and Chris Smith
'               http://www.TheVBZone.com   ( The VB Zone )
'               http://www.TheVBZone.net   ( The VB Zone .net )
'
' Created On  : January 10, 2002
' Last Update : June 19, 2002
'
' VB Versions : 5.0 / 6.0
'
' Requires    : Microsoft XML, v2.0 [or better] (MSXML.DLL - This comes with MS Internet Explorer 4.0 or better)
'
' Description : This module makes it easy to make an HTTP request to a specified web page and get back
'               result of that request in either HTML or XML format.
'
' See Also    : http://msdn.microsoft.com/downloads/sample.asp?url=/msdn-files/027/001/013/msdncompositedoc.xml
'               http://msdn.microsoft.com/library/en-us/xmlsdk30/htm/xmmscxmlreference.asp
'               http://msdn.microsoft.com/library/en-us/xmlsdk/htm/dom_reference_2kdh.asp
'               http://msdn.microsoft.com/downloads/topic.asp?URL=/MSDN-FILES/028/000/072/topic.xml
'               http://msdn.microsoft.com/nhp/default.asp?contentid=28000438
'               http://msdn.microsoft.com/downloads/sample.asp?url=/msdn-files/027/001/439/msdncompositedoc.xml
'               http://msdn.microsoft.com/downloads/sample.asp?url=/msdn-files/027/001/013/msdncompositedoc.xml
'               http://msdn.microsoft.com/downloads/sample.asp?url=/msdn-files/027/000/537/msdncompositedoc.xml
'
' Example Use :
'
'  Public Sub Main()
'    Dim vntSource  As Variant
'    Dim lngErrNum  As Long
'    Dim strErrDesc As String
'    If HTML_GetSource("http://www.TheVBZone.com", vntSource, , , , , , lngErrNum, strErrDesc) = False Then
'      MsgBox "The following error occured:" & Chr(13) & Chr(13) & "Error Number = " & CStr(lngErrNum) & Chr(13) & "Error Description = " & strErrDesc, vbOKOnly + vbExclamation, "  ERROR"
'    Else
'      MsgBox vntSource
'    End If
'  End Sub
'
'=============================================================================================================
'
' LEGAL:
'
' You are free to use this code as long as you keep the above heading information intact and unchanged. Credit
' given where credit is due.  Also, it is not required, but it would be appreciated if you would mention
' somewhere in your compiled program that that your program makes use of code written and distributed by
' Kevin Wilson (www.TheVBZone.com).  Feel free to link to this code via your web site or articles.
'
' You may NOT take this code and pass it off as your own.  You may NOT distribute this code on your own server
' or web site.  You may NOT take code created by Kevin Wilson (www.TheVBZone.com) and use it to create products,
' utilities, or applications that directly compete with products, utilities, and applications created by Kevin
' Wilson, TheVBZone.com, or Wilson Media.  You may NOT take this code and sell it for profit without first
' obtaining the written consent of the author Kevin Wilson.
'
' These conditions are subject to change at the discretion of the owner Kevin Wilson at any time without
' warning or notice.  Copyright© by Kevin Wilson.  All rights reserved.
'
'=============================================================================================================




'=============================================================================================================
' HTML_GetSource
'
' Purpose:
' --------
' This function goes to the specified URL, executes the HTML, ASP, XML, XSL, CGI, etc. located at that URL
' and returns back the source code of what would be the result to be displayed in a web browser.  This is
' the equivelant of you going to a web site with Internet Explorer or Netscape, letting the page fully load
' then viewing the source behind the return for that URL.
'
' Parameter:              Use:
' ---------------------------------------------------
' strURL                  The URL of the site to download the HTML source code. This must be an absolute URL, such as "http://Myserver/Mypath/Myfile.asp"
' Return_Content          If the "blnReturnXML" parameter is FALSE, returns the HTML source code returned from the HTTP request.
'                         If the "blnReturnXML" parameter is TRUE, returns an "MSXML.DOMDocument" object with the XML returned from the HTTP request.
' strMethod               Optional. HTTP method used to open the connection (such as GET, POST, PUT, or PROPFIND)
' vntBody                 Optional. This parameter is the request body to use to be sent via the HTTP request
'                         to the server.  This can be one of 4 things: A String, an Byte Array, an XML DOM
'                         object, or an IStream object.
'                           - String: the response is always encoded as UTF-8. The caller must set a Content-Type header with the appropriate content type and include a charset parameter.
'                           - Byte Array (SAFEARRAY of UI1): the response is sent as is without additional encoding. The caller must set a Content-Type header with the appropriate content type.
'                           - XML DOM Object: the response is encoded according to the encoding attribute on the <? declaration in the document. If there is no XML declaration or encoding attribute, UTF-8 is assumed.
'                           - IStream Object: the response is sent as is without additional encoding. The caller must set a Content-Type header with the appropriate content type.
' strUserName             Optional. Username that is sent to the web site (if username/password are required and none is specified, a login dialog is displayed).
' strPassWord             Optional. Password that is sent to the web site (if username/password are required and none is specified, a login dialog is displayed).
' blnReturnXML            Optional. If set to TRUE and the result of the HTTP request is proper XML, this
'                         function returns an "MSXML.DOMDocument" object.
' Return_ErrNum           Optional. If an error occurs, this returns the number of the error that occured.
' Return_ErrDesc          Optional. If an error occurs, this returns the description of the error that occured.
'
' Return:
' -------
' Returns TRUE if successfully executed
' Returns FALSE if an error occurs during execution
'
'=============================================================================================================
Public Function HTML_GetSource(ByVal strURL As String, _
                               ByRef Return_Content As Variant, _
                               Optional ByVal strMethod As String = "GET", _
                               Optional ByVal vntBody As Variant, _
                               Optional ByVal strUserName As String, _
                               Optional ByVal strPassword As String, _
                               Optional ByVal blnReturnXML As Boolean, _
                               Optional ByRef Return_ErrNum As Long, _
                               Optional ByRef Return_ErrDesc As String) As Boolean
On Error GoTo ErrorHandler
  
  Dim objXML As MSXML.XMLHTTPRequest
  
  ' Set default values
  Return_ErrNum = 0
  Return_ErrDesc = ""
  If blnReturnXML = True Then
    Set Return_Content = Nothing
  Else
    Return_Content = ""
  End If
  
  ' Check required params
  If Trim(strURL) = "" Then
    Return_ErrNum = -1: Return_ErrDesc = "No valid URL specified"
    Exit Function
  End If
  strMethod = UCase(Trim(strMethod))
  If strMethod = "" Then strMethod = "GET"
  If IsEmpty(vntBody) = True Or IsMissing(vntBody) = True Then vntBody = ""
  
  ' Setup the XML HTTP request
  Set objXML = New MSXML.XMLHTTPRequest
  objXML.open strMethod, strURL, False, strUserName, strPassword
  
  ' Download the HTML source
  objXML.send vntBody
  If blnReturnXML = True Then
    Set Return_Content = objXML.responseXML
    'Return_Content = objXML.responseXML.xml
  Else
    Return_Content = objXML.responseText
  End If
  
  ' Function executed successfully
  HTML_GetSource = True
  Set objXML = Nothing
  Exit Function
  
ErrorHandler:
  Return_ErrNum = Err.Number
  Return_ErrDesc = Err.Description
  Err.Clear
  Set objXML = Nothing
  
End Function