web

[krigans]

hi chris
i have messed up the code but still u can use it by making the required changes
being the forum i found many of them required this hope u pass to others in future i plan to make this as a dll and i have one more piece of code for registry and i will put that also in the next chunk
hope u all enjoy

for this u will require wininet.dll and form with two textbox's and two commandbuttons username/password, login/cancel
in form load
Dim sSupportingHeaders As String
Dim sReturnValue As String
Dim sData As String

If Connect("www.google.com", sSupportingHeaders) Then
'/forumdisplay.php?forumid=1
sData = "forumid=1"
sReturnValue = PostRequest("", sSupportingHeaders, sData)
End If
paste the below code in module

Private Const INTERNET_FLAG_RELOAD = &H80000000
Private Const ERROR_SUCCESS = 0&
Private Const INTERNET_ERROR_BASE = 12000
Private Const ERROR_INTERNET_FORCE_RETRY = (INTERNET_ERROR_BASE + 32)
Private Const INTERNET_OPEN_TYPE_PRECONFIG = 0
Private Const INTERNET_OPEN_TYPE_PROXY = 3
Private Const INTERNET_INVALID_PORT_NUMBER = 0
Private Const INTERNET_DEFAULT_HTTP_PORT = 80
Private Const INTERNET_SERVICE_HTTP = 3
Private Const INTERNET_FLAG_KEEP_CONNECTION = &H400000
Private Const RESPONSE_LENGTH = 1024
Private Const FLAGS_ERROR_UI_FILTER_FOR_ERRORS = &H1
Private Const FLAGS_ERROR_UI_FLAGS_CHANGE_OPTIONS = &H2
Private Const FLAGS_ERROR_UI_FLAGS_GENERATE_DATA = &H4
Private Const FLAGS_ERROR_UI_SERIALIZE_DIALOGS = &H10
Private Const HTTP_QUERY_FLAG_NUMBER = &H20000000
Private Const HTTP_QUERY_STATUS_CODE = 19
Private Const HTTP_STATUS_DENIED = 401
Private Const HTTP_STATUS_PROXY_AUTH_REQ = 407
Private Const INTERNET_OPTION_PROXY_USERNAME = 43
Private Const INTERNET_OPTION_PROXY_PASSWORD = 44
Private Const INTERNET_OPTION_CONNECT_TIMEOUT = 2
Private Const INTERNET_OPTION_RECEIVE_TIMEOUT = 6
Private Const INTERNET_OPTION_SEND_TIMEOUT = 5

'To get the last error occurred
Private Declare Function GetLastError Lib "kernel32" () As Long

'open internet get the handle
Private Declare Function InternetOpen Lib "wininet.dll" Alias _
"InternetOpenA" (ByVal sAgent As String, _
ByVal lAccessType As Long, ByVal sProxyName As String, _
ByVal sProxyBypass As String, ByVal lFlags As Long) As Long

'read the information received by the net
Private Declare Function InternetReadFile Lib "wininet.dll" _
(ByVal hFile As Long, ByVal sBuffer As String, ByVal lNumBytesToRead As Long, _
lNumberOfBytesRead As Long) As Integer

' Sends the specified request to the HTTP server.
Private Declare Function HttpSendRequest Lib "wininet.dll" Alias "HttpSendRequestA" _
(ByVal hHttpRequest As Long, ByVal sHeaders As String, ByVal lHeadersLength As Long, _
ByVal sOptional As String, ByVal lOptionalLength As Long) As Integer

' Opens a HTTP session for a given site.
Private Declare Function InternetConnect Lib "wininet.dll" Alias "InternetConnectA" _
(ByVal hInternetSession As Long, ByVal sServerName As String, ByVal nServerPort As Integer, _
ByVal sUserName As String, ByVal sPassword As String, ByVal lService As Long, _
ByVal lFlags As Long, ByVal lContext As Long) As Long

' Opens an HTTP request handle.
Private Declare Function HttpOpenRequest Lib "wininet.dll" Alias "HttpOpenRequestA" _
(ByVal hHttpSession As Long, ByVal sVerb As String, ByVal sObjectName As String, ByVal sVersion As String, _
ByVal sReferer As String, ByVal something As Long, ByVal lFlags As Long, ByVal lContext As Long) As Long

' Queries for information about an HTTP request.
Private Declare Function HttpQueryInfo Lib "wininet.dll" Alias "HttpQueryInfoA" _
(ByVal hHttpRequest As Long, ByVal lInfoLevel As Long, ByRef sBuffer As Any, _
ByRef lBufferLength As Long, ByRef lIndex As Long) As Integer

' Traps the error's occurred while connecting to net InternetErrorDlg
Private Declare Function InternetErrorDlg Lib "wininet.dll" _
(ByVal hwnd As Long, ByVal hInternet As Long, ByVal dwError As Long, _
ByVal dwFlags As Long, ByVal lppvData As Long) As Long

'Closes the internet connection using the handle
Private Declare Function InternetCloseHandle Lib "wininet.dll" _
(ByVal hInet As Long) As Integer

'Sets any information explicitly required to set eg :- username,password,timeout
Public Declare Function InternetSetOption Lib "wininet.dll" Alias "InternetSetOptionA" _
(ByVal hInternet As Long, ByVal lOption As Long, ByRef sBuffer As Any, _
ByVal lBufferLength As Long) As Integer

'Sets any information explicitly required to set eg :- username,password,timeout (String version)
Private Declare Function InternetSetOptionStr Lib "wininet.dll" Alias _
"InternetSetOptionA" (ByVal hInternet As Long, ByVal lOption As Long, _
ByVal sBuffer As String, ByVal lBufferLength As Long) As Integer

' Adds one or more HTTP request headers to the HTTP request handle.
Private Declare Function HttpAddRequestHeaders Lib "wininet.dll" Alias "HttpAddRequestHeadersA" _
(ByVal hHttpRequest As Long, ByVal sHeaders As String, _
ByVal lHeadersLength As Long, ByVal lModifiers As Long) As Integer

' DownLoad the file specified without saveas dialog box
Public Declare Function URLDownloadToFile Lib "urlmon" Alias _
"URLDownloadToFileA" (ByVal pCaller As Long, ByVal szURL As String, _
ByVal szFileName As String, ByVal dwReserved As Long, ByVal lpfnCB As Long) _
As Long

Private plHandle As Long ' store the internet handle
Private plConnection As Long ' store the net connection handle
Private plRequest As Long ' store the information about request's made

Private psServerName As String

'A Call to the function Connect returns true if the computer has established a connection to the internet.
Public Function Connect(ServerName As String, ByRef sSupportingHeaders As String) As Boolean
Dim lHandle As Long
Dim lConnection As String

Dim sAgent As String
Dim sProxy As String
Dim sProxyEnable As String
Dim sProxyServer As String
Dim sUserAgent As String

sAgent = App.EXEName
sProxy = ProxyName

'Get Handle to Internet Gateway
If Len(Trim$(sSupportingHeaders)) = 0 Then Call SetProxySettings(sProxyEnable, sProxyServer, sUserAgent, sSupportingHeaders)
lHandle = InternetOpen(sAgent, INTERNET_OPEN_TYPE_PRECONFIG, vbNullString, vbNullString, 0)
If lHandle <> 0 Then
plHandle = lHandle
Else
Exit Function
End If
'Connect to server
lConnection = InternetConnect(plHandle, ServerName, INTERNET_INVALID_PORT_NUMBER, "", "", INTERNET_SERVICE_HTTP, 0, 0)
If lConnection <> 0 Then
plConnection = lConnection
Connect = True
'frmBlankForm.Connected = True
Else
Connect = False
'frmBlankForm.Connected = False
Disconnect
End If

End Function

Public Sub Disconnect()
'Clean Up
On Error Resume Next
InternetCloseHandle plRequest
InternetCloseHandle plConnection
InternetCloseHandle plHandle
End Sub

Public Function PostRequest(ScriptName As String, ByRef sSupportingHeaders As String, Optional sData As String = "", Optional sAction As String = "G") As String
Dim lRequest As Long
Dim sAns As String
Dim lRead As Long
Dim sResult As String
Dim lctr As Long
Dim sHeader As String
Dim sUrl As String
Dim sRtValue As String
Dim nSpacePos As Integer
Dim nEnterPos As Integer
Dim sProxyServer As String
Dim sProxyEnable As String
Dim sUserAgent As String
Dim sMessageId As String
Dim sFileName As String
Dim queryInfo As Boolean
Dim dwError As Long
Dim dwStatus As Long
Dim dwStatusSize As Long
Dim sUserName As String
Dim sPassword As String

dwStatusSize = Len(dwStatus)
sAgent = App.EXEName
sProxy = ProxyName

'Open request
sUrl = gsPHPURLPATH & ScriptName
If ScriptName = "" Then
sUrl = gsPHPURLPATH
lRequest = HttpOpenRequest(plConnection, "GET", sUrl, "HTTP/1.0", "", 0, _
INTERNET_FLAG_RELOAD Or INTERNET_FLAG_KEEP_CONNECTION, 0)
Else
lRequest = HttpOpenRequest(plConnection, "POST", sUrl, "HTTP/1.0", "", 0, _
INTERNET_FLAG_RELOAD Or INTERNET_FLAG_KEEP_CONNECTION, 0)
End If

'Testing purpose
'hRequest = HttpOpenRequest(hConnect, "GET", "", "HTTP/1.0", vbNullString, 0, _
INTERNET_FLAG_RELOAD Or INTERNET_FLAG_KEEP_CONNECTION Or SecFlag, 0)

If lRequest <> 0 Then
plRequest = lRequest

Else
Disconnect
End If

Resend:
lRequest = HttpSendRequest(plRequest, sSupportingHeaders, Len(sSupportingHeaders), sData, Len(sData))

'Testing purpose
'lRequest = HttpSendRequest(plRequest, sSupportingHeaders, Len(sSupportingHeaders), vbNullString, 0)
'lRequest = HttpSendRequest(plRequest, vbNullString, 0, sData, Len(sData))

queryInfo = HttpQueryInfo(plRequest, HTTP_QUERY_FLAG_NUMBER Or HTTP_QUERY_STATUS_CODE, dwStatus, dwStatusSize, 0)

If (dwStatus = HTTP_STATUS_PROXY_AUTH_REQ) Then

With frmProxyAuthentication
.Show vbModal
sUserName = Trim$(.txtUserName)
sPassword = Trim$(.txtPassword)
Unload frmProxyAuthentication
End With
If Len(Trim$(sUserName)) <> 0 And Len(Trim$(sPassword)) <> 0 Then
' set the username and password and then connect again
'gsUserId = sUserName
Call InternetSetOptionStr(plRequest, INTERNET_OPTION_PROXY_USERNAME, sUserName, Len(sUserName) + 1)
Call InternetSetOptionStr(plRequest, INTERNET_OPTION_PROXY_PASSWORD, sPassword, Len(sPassword) + 1)
'ReadAllData
GoTo Resend
Else
PostRequest = ""
Exit Function
End If
ElseIf dwStatus <> 200 Then
Select Case dwStatus
Case 502 ' Bad Gateway
Case 400 ' proxy server problem
MsgBox "Check your server connection"
Case 404 ' File not found
Case Else
MsgBox "Status:" & dwStatus
End Select
'ReadAllData
End If
If lRequest > 0 Then
sAns = Space$(RESPONSE_LENGTH)
Do While InternetReadFile(plRequest, sAns, RESPONSE_LENGTH, lRead)
If lRead = 0 Then
Exit Do
Else
sResult = sResult & Left$(sAns, lRead)
End If
lRead = 1024
sAns = Space$(lRead)
Loop
'display results
'Debug.Print sResult
If ScriptName = "" Then ' remove the tags and send the filenames
Dim iStartTagPos As Integer
Dim iEndTagPos As Integer
'Dim sRnData() As String
Dim sRnData As String
Dim iCtr As Integer
Dim sSearchString As String
Dim iEndPoint As Integer

sSearchString = "<A HREF="
sRnData = ""
'ReDim sRnData(0)
For iCtr = 1 To Len(sResult)
iStartTagPos = InStr(iCtr, sResult, sSearchString)
'iEndTagPos = InStr(iStartTagPos + 1, sResult, sSearchString)
iEndTagPos = InStr(iStartTagPos + 1, sResult, ">")
If iStartTagPos > 0 And iEndTagPos > 0 Then
'iEndPoint = iStartTagPos + 1 + Len(sSearchString)
iEndPoint = iStartTagPos + 1 + Len(sSearchString)
sRnData = sRnData & Mid(sResult, iEndPoint, (iEndTagPos - 1) - iEndPoint) & gsSEPERATOR
'sRnData(UBound(sRnData)) = Mid(sResult, iEndPoint, iEndTagPos - 1) & gsSEPERATOR
'ReDim Preserve sRnData(UBound(sRnData) + 1)
End If
iCtr = iEndTagPos
If iStartTagPos = 0 Or iEndTagPos = 0 Then Exit For
Next iCtr
PostRequest = sRnData
'the script returned back and checkfor the directory to download
Exit Function
End If

If InStr(1, sResult, "<") > 0 And ScriptName <> "" Then ' begins with html tag's then parse to get errors
'MsgBox "Consult the http://www.Bindazbuzz.com Error : 101"
' since query info gives status the below code is not required
' sRtValue = HTML2Text(sResult)
' nEnterPos = InStr(1, sRtValue, vbCrLf)
' If nEnterPos > 0 Then
' Dim sErrornumber As String
' sRtValue = Mid(sRtValue, 1, nEnterPos - 1)
' nSpacePos = InStr(1, sRtValue, " ")
' sErrornumber = Mid(sRtValue, 1, nSpacePos - 1)
' Select Case sErrornumber
' Case 407 'Authentication required
' 'frmAuthentication.show
' Case Else
' MsgBox "Error Number :- " & Mid(sRtValue, 1, nSpacePos - 1) & _
' vbCrLf & "Error Message :- " & Mid(sRtValue, nSpacePos + 1), vbOKOnly, App.EXEName
' End Select
' End If
Else
PostRequest = sResult
End If
Screen.MousePointer = vbDefault
Else
Disconnect
End If

End Function

Private Function SetProxySettings(ByRef sProxyEnable As String, ByRef sProxyServer As String, ByRef sUserAgent As String, ByRef sSupportingHeaders As String) As Boolean
Dim blnRegValue As Boolean
Dim iColonPos As Integer

'useragent ' Mozilla/4.0 (compatible; MSIE 5.0; Windows 98; DigExt)"
sUserAgent = objReg.GetStringValue("HKEY_CURRENT_USER\Software\Microsoft\Windows\CurrentVersion\Internet Settings", "User Agent")
If Len(Trim$(sUserAgent)) = 0 Then
SetProxySettings = False
MsgBox "Please check your proxy settings"
Exit Function
End If

sProxyEnable = objReg.GetDWordValue("HKEY_CURRENT_USER\Software\Microsoft\Windows\CurrentVersion\Internet Settings", "ProxyEnable")
If Len(Trim$(sProxyEnable)) = 0 Then
SetProxySettings = False
MsgBox "Please check your proxy settings"
Exit Function
End If
sSupportingHeaders = "Accept-Language: en" & vbCrLf & _
"User-Agent: " & sUserAgent & vbCrLf & _
"Content-Type: application/x-www-form-urlencoded" & vbCrLf & _
"Connection: Keep-Alive" & vbCrLf & _
"Accept: *.*, */*" & vbCrLf


If sProxyEnable = 1 Then 'Proxy Connection
sProxyServer = objReg.GetStringValue("HKEY_CURRENT_USER\Software\Microsoft\Windows\CurrentVersion\Internet Settings", "ProxyServer")
sSupportingHeaders = sSupportingHeaders & vbCrLf
'for testing purpose of proxy username,password
'& _
"Proxy-Authorization: Basic YWNjdDAxMjpNYWhlc2gxMg=="
SetProxySettings = True
Else
SetProxySettings = False
End If
End Function


Private Function UrlEncode(sText As String) As String
'This function converts non-alphanumeric characters to their
'hexadecimal equivalents, as required by http protocol.


Dim sTemp As String
Dim sAns As String
Dim sChar As String
Dim lctr As Long

For lctr = 1 To Len(sText)

sChar = Mid$(sText, lctr, 1)

'is it alphanumeric
If sChar Like "[0-9A-Za-z]" Then

sTemp = sTemp & sChar
ElseIf sChar = " " Then
sTemp = sTemp & "+"
ElseIf True Then
sTemp = sTemp & "%" & Right$("0" & Hex(Asc(sChar)), 2)

End If
If Len(sTemp) > 1000 Then
sAns = sAns & sTemp
sTemp = ""
End If

Next

UrlEncode = sAns & sTemp

End Function

Public Function HTML2Text(HTMLString As String, Optional SaveAsFile As String) As String

Const MAX_ROW_LENGTH = 65
Const MAX_LINE_LENGTH = 75

Dim sHTML As String
Dim sOut As String
Dim sWkg As String
Dim lLen As Long
Dim lngLoop As Long, lngCtr As Long

Dim sChar As String
Dim sTag As String
Dim blnBodyStart As Boolean, blnBodyTag As Boolean

Dim blnPrevSpace As Boolean
Dim sCharCode As String
Dim blnOL As Boolean, blnUL As Boolean
Dim iPlaceInList As Integer

Dim iFileNum As Integer

Dim blnOneCrLf As Boolean
Dim blnTwoCrlf As Boolean
Dim lTempCtr As Long, iTempCtr As Integer
Dim lTempCtr2 As Long

Dim blnFormatCell As Boolean

Dim lRowLength As Long
Dim iLineCount As Integer


Dim blnInComment As Boolean
Dim sTemp As String, sTemp2 As String


Dim blnFlag As Boolean
Dim blnSubFlag As Boolean

Dim blnOutputCells As Boolean
Dim lRowCharCount As Long
Dim sNestedTag As String
Dim sCharInCell As String
Dim sTagInCell As String
Dim sEndTag As String

Dim blnInCells As Boolean
Dim blnInScript As Boolean


sHTML = HTMLString
lLen = Len(sHTML)

For lngCtr = 1 To lLen

sTag = ""
sChar = Mid(sHTML, lngCtr, 1)


If sChar = "<" And Not blnInComment Then


lngCtr = lngCtr + 1
lngLoop = 1
sWkg = ""
'start new loop to get the tag name
Do
'if we never find end, then we must exit
If lngCtr = lLen Then Exit For

sChar = Mid(sHTML, lngCtr, 1)
If sChar <> ">" Then
sWkg = sWkg & sChar

lngCtr = lngCtr + 1

End If

If sChar = ">" Or lngCtr >= lLen Then
If lngCtr < lLen Then
If Mid(sHTML, lngCtr + 1, 1) < 32 Then blnPrevSpace = True
End If
'lTempCtr = lngCtr

Exit Do
End If



If Remove*********(sWkg = "!--") Then Exit Do


'lngCtr = lngCtr + 1

Loop
sTag = Trim(sWkg)

'determine if another tag is coming because
'if so, we don't want to output any spaces.

blnFlag = False
blnSubFlag = False
lTempCtr = lngCtr + 1
If lTempCtr >= lLen Then Exit For
sTemp = Mid(sHTML, lTempCtr, 1)
If Asc(sTemp) <= 32 Then
sTemp = ""


Do

sTemp = sTemp & Mid(sHTML, lTempCtr, 1)
If sTemp = "<" Then
If blnFlag Then blnPrevSpace = True
Exit Do

ElseIf Asc(sTemp) > 32 Then

blnPrevSpace = Not (blnSubFlag)

Exit Do
ElseIf Asc(sTemp) <= 32 Then
blnFlag = True
blnSubFlag = Asc(sTemp) = 32

End If


lTempCtr = lTempCtr + 1
If lTempCtr >= lLen Then Exit For
sTemp = ""
Loop
End If

'Certain tags interest us: TITLE, <BR><P>

If InStr(Left(sTag, 1), "/") = 0 Then
If Left(sTag, 5) = "TITLE" Then
lngCtr = lngCtr + 1

Do

sChar = Mid(sHTML, lngCtr, 1)

If (sChar = "<" And sChar <> Chr$(13) And sChar <> Chr$(10)) Or lngCtr = lLen Then
If Not blnInComment And Not blnInScript Then sOut = sOut & vbCrLf & vbCrLf
iLineCount = 0
blnTwoCrlf = True
lngCtr = lngCtr - 1
Exit Do
End If

sOut = sOut & sChar

lngCtr = lngCtr + 1
Loop
ElseIf Left(sTag, 4) = "BODY" And Not blnInScript Then
blnBodyTag = True
ElseIf (sTag = "P" Or Left(sTag, 2) = "P ") And Not blnInScript Then
If blnBodyStart And Not blnTwoCrlf And Not blnInScript And Not blnInComment Then
sOut = sOut & vbCrLf & vbCrLf
iLineCount = 0
blnTwoCrlf = True
End If
ElseIf (sTag = "TR" Or Left(sTag, 3) = "TR ") And Not blnInScript Then

lTempCtr = lngCtr + 1
lRowCharCount = 0
blnFlag = False
Do
sTemp = Mid(sHTML, lTempCtr, 1)
If sTemp = "<" Then 'get name of tag
sNestedTag = ""
Do
lTempCtr = lTempCtr + 1
If lTempCtr >= lLen Then Exit For
sTemp2 = Mid(sHTML, lTempCtr, 1)
If sTemp2 = ">" Then Exit Do
sNestedTag = sNestedTag & sTemp2
Loop
End If

If (sNestedTag = "/TR" Or sNestedTag = "/TABLE") And Not blnInScript Then
blnOutputCells = (lRowCharCount < MAX_ROW_LENGTH)
Exit Do
ElseIf (sNestedTag = "TABLE" Or Left$(sNestedTag, 6) = "TABLE ") And Not blnInScript Then
blnOutputCells = False
Exit Do
ElseIf (sNestedTag = "TD" Or Left$(sNestedTag, 3) = "TD " _
Or sNestedTag = "TH" Or Left$(sNestedTag, 3) = "TH ") And Not blnInScript Then
lTempCtr = lTempCtr + 1

blnFlag = False
Do
If lTempCtr >= lLen Then Exit For
sCharInCell = Mid(sHTML, lTempCtr, 1)
Select Case sCharInCell
Case "<" 'nested tag
lTempCtr = lTempCtr + 1
sTagInCell = ""
Do
If lTempCtr >= lLen Then Exit For
sTemp2 = Mid(sHTML, lTempCtr, 1)
If sTemp2 <> ">" Then
sTagInCell = sTagInCell & sTemp2
Else
Exit Do
End If
lTempCtr = lTempCtr + 1
Loop


If Remove*********(sTagInCell) = "/TD" Then
sNestedTag = ""
Exit Do
ElseIf (sTagInCell = "P" Or Left$(sTagInCell, 2) = "P " _
Or sTagInCell = "BR" Or Left$(sTagInCell, 3) _
= "BR ") And Not blnInScript Then

lRowCharCount = MAX_ROW_LENGTH + 1
Exit Do
End If
Case Else
If Not blnFlag And Not blnInScript Then lRowCharCount = lRowCharCount + 1
End Select
lTempCtr = lTempCtr + 1
Loop
End If 'td tag

If lTempCtr = lLen Then Exit For
lTempCtr = lTempCtr + 1
Loop 'loop begins under the TR condition
lRowCharCount = 0

sOut = sOut & vbCrLf
iLineCount = 0
blnOneCrLf = True

blnInCells = False
ElseIf sTag = "TD" Or Left(sTag, 3) = "TD " _
Or sTag = "TH" Or Left(sTag, 3) = "TH " Then
If blnOutputCells Then
If blnInCells Then sOut = sOut & Space$(3)
blnInCells = True
Else
sOut = sOut & vbCrLf
blnOneCrLf = True
End If

ElseIf sTag = "BR" Or sTag = "TABLE" Or Left$(sTag, 5) = "TABLE" Then
If blnBodyStart And Not blnOneCrLf Then
sOut = sOut & vbCrLf
iLineCount = 0
blnOneCrLf = True
End If
ElseIf sTag = "OPTION" Or Left(sTag, 7) = "OPTION " Then
sOut = sOut & vbCrLf & vbTab
iLineCount = 0
ElseIf sTag = "SCRIPT" Or Left(sTag, 7) = "SCRIPT " Then
blnInScript = True

ElseIf Left(sTag, 3) = "!--" And blnBodyTag Then
blnInComment = True
ElseIf sTag = "OL" Or Left(sTag, 3) = "OL " Then
blnOL = True
sOut = sOut & vbCrLf & vbCrLf
iLineCount = 0
ElseIf sTag = "UL" Or Left(sTag, 3) = "UL " Then
blnUL = True
sOut = sOut & vbCrLf & vbCrLf
iLineCount = 0
ElseIf sTag = "LI" Or Left(sTag, 3) = "LI " Then
'if not in the middle of a numbered list, just add bullet
sOut = sOut & vbCrLf
iLineCount = 0
If blnOL Then
iPlaceInList = iPlaceInList + 1
sOut = sOut & iPlaceInList & ". "
iLineCount = iLineCount + 2
Else
sOut = sOut & Chr$(149) & " "
iLineCount = iLineCount + 2
End If

End If

Else 'end tag

If Left(Remove*********(sTag), 7) = "/SCRIPT" Then blnInScript = False

If blnBodyStart Then
'we need to find the end for blnOL and blnUL
'if you want to process other end tags
'do it here.
Select Case Left(Remove*********(sTag), 3)
Case "/OL"
blnOL = False
If Not blnTwoCrlf Then
sOut = sOut & vbCrLf & vbCrLf
iLineCount = 0
blnTwoCrlf = True
End If
iPlaceInList = 0
Case "/UL"
blnUL = False
If Not blnTwoCrlf Then
sOut = sOut & vbCrLf & vbCrLf
iLineCount = 0
blnTwoCrlf = True
End If
End Select

End If 'instr(stag, "/")
End If 'blnbodystart

Else 'not a tag
sChar = Mid(sHTML, lngCtr, 1)
If blnBodyTag Then
Select Case sChar
Case "<" 'another new tag
If Not blnInComment And Not blnInScript Then
lngCtr = lngCtr - 1 'go back and let top of loop handle tag
sTag = ""
sWkg = ""
End If

Case " "
'only one space is processed in HTML
'rest are ignored
If blnPrevSpace = False Then
If Not blnInComment And Not blnInScript Then sOut = sOut & sChar
blnPrevSpace = True
iLineCount = iLineCount + 1

If iLineCount >= MAX_LINE_LENGTH Then
sOut = sOut & vbCrLf
iLineCount = 0
End If
End If
Case "-" 'see if this is the end of the comment
If blnBodyStart Then
If blnInComment Then
sTemp = ""


lTempCtr = lngCtr
lTempCtr2 = 0

Do
sTemp = sTemp & Mid(sHTML, lTempCtr, 1)

If Mid(sHTML, lTempCtr, 1) = ">" Then
sTemp2 = Remove*********(sTemp)
If Right$(sTemp2, 3) = "-->" Then
blnInComment = False
Exit Do
End If
End If
If lTempCtr = lLen Then Exit For
lTempCtr = lTempCtr + 1
lTempCtr2 = lTempCtr2 + 1
Loop
If lTempCtr < lLen Then lngCtr = lngCtr + lTempCtr2
Else

blnPrevSpace = False
sOut = sOut & "-"
blnOneCrLf = False
blnTwoCrlf = False
iLineCount = iLineCount + 1
End If
End If
Case "&" 'special character code, or maybe just an ampersand

sTemp = ""
blnFlag = False

For lTempCtr = (lngCtr + 1) To (lngCtr + 7)
sTemp = Mid(sHTML, lTempCtr, 1)
If sTemp = ";" Then
blnFlag = True
Exit For
ElseIf sTemp = "&" Then
blnFlag = False
Exit For
End If

Next

If blnFlag Then
sCharCode = ""
lngCtr = lngCtr + 1
Do
sChar = Mid(sHTML, lngCtr, 1)
If sChar = ";" Then Exit Do
sCharCode = sCharCode + sChar
lngCtr = lngCtr + 1

Loop
'special character. must end with ";"
If Not blnInComment And Not blnInScript Then
sTemp2 = HTMLSpecChar2ASCII(sCharCode)
sOut = sOut & sTemp2
blnPrevSpace = False
blnOneCrLf = False
blnTwoCrlf = False
iLineCount = iLineCount + Len(sTemp2)
End If
Else
If Not blnInComment And Not blnInScript Then
sOut = sOut & "&"
blnPrevSpace = False
blnOneCrLf = False
blnTwoCrlf = False
iLineCount = iLineCount + 1
End If
End If


Case Else
blnBodyStart = True
'asc below 31 = nonprintable
If Asc(sChar) < 31 Then
If blnPrevSpace = False Then
If Not blnInComment And Not blnInScript Then sOut = sOut & " "
iLineCount = iLineCount + 1
blnPrevSpace = True

If iLineCount >= MAX_LINE_LENGTH Then
sOut = sOut & vbCrLf
iLineCount = 0
End If
End If
Else
If Not blnInComment And Not blnInScript And Asc(sChar) > 31 Then
sOut = sOut & sChar

blnPrevSpace = False
blnOneCrLf = False
blnTwoCrlf = False
iLineCount = iLineCount + 1

End If
End If
End Select
End If 'blnbodystart
End If 'sChar = "<"

DoEvents


Next lngCtr



'return output
HTML2Text = sOut

If SaveAsFile <> "" Then
On Error GoTo ErrorHandler
'save output to string
iFileNum = FreeFile
Open SaveAsFile For Output As #iFileNum
Print #iFileNum, sOut
Close #iFileNum

End If


Exit Function
ErrorHandler:

On Error Resume Next
Close #iFileNum
Exit Function

End Function

Private Function Remove*********(ByVal InputString As String) _
As String

Dim sAns As String
Dim lLen As String
Dim lctr As Long, lCtr2 As Long
Dim sChar As String


lLen = Len(InputString)
sAns = InputString
lCtr2 = 1

For lctr = 1 To lLen
sChar = Mid(InputString, lctr, 1)
If sChar <> " " Then
Mid(sAns, lCtr2, 1) = sChar
lCtr2 = lCtr2 + 1
End If
Next

If lCtr2 > 1 Then
sAns = Left(sAns, lCtr2 - 1)
Else
sAns = ""
End If

Remove********* = sAns
End Function

Private Function HTMLSpecChar2ASCII(ByVal HTMLCode As String) As String

Dim sAns As String, sInput As String

sInput = LCase(HTMLCode)
If Left$(sInput, 1) = "#" Then
sInput = Mid(sInput, 2)
End If

If IsNumeric(sInput) Then
sAns = Chr$(Val(sInput))
Else
Select Case sInput
Case "quot"
sAns = ""
Case "amp"
sAns = "&"
Case "lt"
sAns = "<"
Case "gt"
sAns = ">"
Case "nbsp"
sAns = Chr$(160)
Case "iexcl"
sAns = Chr$(161)
Case "cent"
sAns = Chr$(162)
Case "pound"
sAns = Chr$(163)
Case "curren"
sAns = Chr$(164)
Case "yen"
sAns = Chr$(165)
Case "brvbar"
sAns = Chr$(166)
Case "sect"
sAns = Chr$(167)
Case "uml"
sAns = Chr$(168)
Case "copy"
sAns = Chr$(169)
Case "ordf"
sAns = Chr$(170)
Case "laquo"
sAns = Chr$(171)
Case "not"
sAns = Chr$(172)
Case "shy"
sAns = Chr$(173)
Case "reg"
sAns = Chr$(174)
Case "macr"
sAns = Chr$(175)
Case "deg"
sAns = Chr$(176)
Case "plusmn"
sAns = Chr$(177)
Case "sup2"
sAns = Chr$(178)
Case "sup3"
sAns = Chr$(179)
Case "acute"
sAns = Chr$(180)
Case "micro"
sAns = Chr$(181)
Case "para"
sAns = Chr$(182)
Case "middot"
sAns = Chr$(183)
Case "cedil"
sAns = Chr$(184)
Case "supl"
sAns = Chr$(185)
Case "ordm"
sAns = Chr$(186)
Case "raquo"
sAns = Chr$(187)
Case "frac14"
sAns = Chr$(188)
Case "frac12"
sAns = Chr$(189)
Case "frac34"
sAns = Chr$(190)
Case "iquest"
sAns = Chr$(191)
Case "agrave"
sAns = IIf(BinaryEqualityTest(sInput, HTMLCode) = True, Chr$(224), Chr$(192))
Case "aacute"
sAns = IIf(BinaryEqualityTest(sInput, HTMLCode) = True, Chr$(225), Chr$(193))
Case "acirc"
sAns = IIf(BinaryEqualityTest(sInput, HTMLCode) = True, Chr$(226), Chr$(194))
Case "atilde"
sAns = IIf(BinaryEqualityTest(sInput, HTMLCode) = True, Chr$(227), Chr$(195))
Case "auml"
sAns = IIf(BinaryEqualityTest(sInput, HTMLCode) = True, Chr$(228), Chr$(196))
Case "aring"
sAns = IIf(BinaryEqualityTest(sInput, HTMLCode) = True, Chr$(229), Chr$(197))
Case "aelig"
sAns = IIf(BinaryEqualityTest(sInput, HTMLCode) = True, Chr$(230), Chr$(198))
Case "ccedil"
sAns = IIf(BinaryEqualityTest(sInput, HTMLCode) = True, Chr$(231), Chr$(199))
Case "egrave"
sAns = IIf(BinaryEqualityTest(sInput, HTMLCode) = True, Chr$(232), Chr$(200))
Case "eacute"
sAns = IIf(BinaryEqualityTest(sInput, HTMLCode) = True, Chr$(233), Chr$(201))
Case "ecirc"
sAns = IIf(BinaryEqualityTest(sInput, HTMLCode) = True, Chr$(234), Chr$(202))
Case "euml"
sAns = IIf(BinaryEqualityTest(sInput, HTMLCode) = True, Chr$(235), Chr$(203))
Case "igrave"
sAns = IIf(BinaryEqualityTest(sInput, HTMLCode) = True, Chr$(236), Chr$(204))
Case "iacute"
sAns = IIf(BinaryEqualityTest(sInput, HTMLCode) = True, Chr$(237), Chr$(205))
Case "icirc"
sAns = IIf(BinaryEqualityTest(sInput, HTMLCode) = True, Chr$(238), Chr$(206))
Case "iuml"
sAns = IIf(BinaryEqualityTest(sInput, HTMLCode) = True, Chr$(239), Chr$(207))
Case "eth"
sAns = IIf(BinaryEqualityTest(sInput, HTMLCode) = True, Chr$(240), Chr$(208))
Case "ntilde"
sAns = IIf(BinaryEqualityTest(sInput, HTMLCode) = True, Chr$(241), Chr$(209))
Case "ograve"
sAns = IIf(BinaryEqualityTest(sInput, HTMLCode) = True, Chr$(242), Chr$(210))
Case "oacute"
sAns = IIf(BinaryEqualityTest(sInput, HTMLCode) = True, Chr$(243), Chr$(211))
Case "ocirc"
sAns = IIf(BinaryEqualityTest(sInput, HTMLCode) = True, Chr$(244), Chr$(212))
Case "otilde"
sAns = IIf(BinaryEqualityTest(sInput, HTMLCode) = True, Chr$(245), Chr$(213))
Case "otilde"
sAns = IIf(BinaryEqualityTest(sInput, HTMLCode) = True, Chr$(245), Chr$(213))
Case "ouml"
sAns = IIf(BinaryEqualityTest(sInput, HTMLCode) = True, Chr$(246), Chr$(214))
Case "times"
sAns = Chr$(215)
Case "oslash"
sAns = IIf(BinaryEqualityTest(sInput, HTMLCode) = True, Chr$(248), Chr$(216))
Case "ugrave"
sAns = IIf(BinaryEqualityTest(sInput, HTMLCode) = True, Chr$(249), Chr$(217))
Case "uacute"
sAns = IIf(BinaryEqualityTest(sInput, HTMLCode) = True, Chr$(250), Chr$(218))
Case "ucirc"
sAns = IIf(BinaryEqualityTest(sInput, HTMLCode) = True, Chr$(251), Chr$(219))
Case "uuml"
sAns = IIf(BinaryEqualityTest(sInput, HTMLCode) = True, Chr$(252), Chr$(220))
Case "yacute"
sAns = IIf(BinaryEqualityTest(sInput, HTMLCode) = True, Chr$(253), Chr$(221))
Case "thorn"
sAns = IIf(BinaryEqualityTest(sInput, HTMLCode) = True, Chr$(254), Chr$(222))
Case "szlig"
sAns = Chr$(223)
Case "divide"
sAns = Chr$(247)
Case "yuml"
sAns = Chr$(255)


End Select
End If

HTMLSpecChar2ASCII = sAns
End Function


Private Function BinaryEqualityTest(String1 As String, _
String2 As String) As Boolean

BinaryEqualityTest = (StrComp(String1, String2, _
vbBinaryCompare) = 0)

End Function

' to write the information into a html file
Sub ReadAllData()
Dim bDoLoop As Boolean
Dim lNumberOfBytesRead As Long
Dim sReadBuffer As String * 2048
Dim sBuffer As String
bDoLoop = True
Open App.Path & "\myfile.htm" For Binary As #1
While bDoLoop
sReadBuffer = vbNullString
bDoLoop = InternetReadFile(hRequest, sReadBuffer, Len(sReadBuffer), lNumberOfBytesRead)
'Text1.Text = Text1.Text & Left$(sReadBuffer, lNumberOfBytesRead)
If Not CBool(lNumberOfBytesRead) Then bDoLoop = False
Put #1, , sReadBuffer
Wend

Close #1
End Sub

Private Sub AddHeader()
Dim dwTimeOut As Long
Dim sHeader As String

sHeader = "Accept-Language: en" & vbCrLf
Call HttpAddRequestHeaders(hHttpOpenRequest, sHeader, Len(sHeader), HTTP_ADDREQ_FLAG_REPLACE Or HTTP_ADDREQ_FLAG_ADD)

sHeader = "User-Agent: " & sUserAgent & vbCrLf ' Mozilla/4.0 (compatible; MSIE 5.0; Windows 98; DigExt)"
Call HttpAddRequestHeaders(hHttpOpenRequest, sHeader, Len(sHeader), HTTP_ADDREQ_FLAG_REPLACE Or HTTP_ADDREQ_FLAG_ADD)

sHeader = "Content-Type: application/x-www-form-urlencoded" & vbCrLf
Call HttpAddRequestHeaders(hHttpOpenRequest, sHeader, Len(sHeader), HTTP_ADDREQ_FLAG_REPLACE Or HTTP_ADDREQ_FLAG_ADD)

sHeader = "Connection: Keep-Alive" & vbCrLf
Call HttpAddRequestHeaders(hHttpOpenRequest, sHeader, Len(sHeader), HTTP_ADDREQ_FLAG_REPLACE Or HTTP_ADDREQ_FLAG_ADD)

dwTimeOut = 120000 ' time out is set to 2 minutes
Call InternetSetOption(hHttpOpenRequest, INTERNET_OPTION_CONNECT_TIMEOUT, _
dwTimeOut, 4)

Call InternetSetOption(hHttpOpenRequest, INTERNET_OPTION_RECEIVE_TIMEOUT, _
dwTimeOut, 4)

iRetVal = InternetSetOption(hHttpOpenRequest, INTERNET_OPTION_SEND_TIMEOUT, _
dwTimeOut, 4)
End Sub