dokken
asked on
Program freezes up...
I'm currently working on a program that connects to a web site and saves it as a text file. I use the wininet.bas from Microsoft along with it. The problem is, the program freezes up when it starts and unfreezes when it has finished. Is there any way to fix this problem? Here is my code:
Option Explicit
Private hInternetSession As Long
Private hInternetConnect As Long
Private hHttpOpenRequest As Long
Private txtURL As String
Private Sub cmdGO_Click()
hInternetSession = 0
hHttpOpenRequest = 0
hInternetConnect = 0
hInternetSession = InternetOpen(scUserAgent,
INTERNET_OPEN_TYPE_PRECONF IG, vbNullString, vbNullString, 0)
If CBool(hInternetSession) Then
txtHTML = "Ready"
Else
txtHTML = "InternetOpen failed."
End If
txtURL = txtUrls.Text
'------------------------- ---------- ---------- ---------- ---------- ----------
---------
Dim iRetVal As Integer
Dim sBuffer As String * 1024
Dim lBufferLen As Long
Dim vDllVersion As tWinInetDLLVersion
Dim sStatus As String
Dim sOptionBuffer As String
Dim lOptionBufferLen As Long
lBufferLen = Len(sBuffer)
If CBool(hInternetSession) Then
' SetStatus "InternetQueryOption"
InternetQueryOption hInternetSession, INTERNET_OPTION_VERSION,
vDllVersion, Len(vDllVersion)
hInternetConnect = InternetConnect(hInternetS ession, CheckUrl,
INTERNET_DEFAULT_HTTP_PORT , _
"", "", INTERNET_SERVICE_HTTP, 0, 0)
If hInternetConnect > 0 Then
'SetStatus "HttpOpenRequest"
'If optGet.Value = True Then
sOptionBuffer = vbNullString
lOptionBufferLen = 0
hHttpOpenRequest = HttpOpenRequest(hInternetC onnect,
"GET", GetUrlObject, "HTTP/1.0", vbNullString, 0, _
INTERNET_FLAG_RELOAD Or INTERNET_FLAG_KEEP_CONNECT ION,
0)
'Else
' sOptionBuffer = txtPost.Text
' lOptionBufferLen = Len(sOptionBuffer)
' hHttpOpenRequest = HttpOpenRequest(hInternetC onnect,
"POST", GetUrlObject, "HTTP/1.0", vbNullString, 0, _
' INTERNET_FLAG_RELOAD Or INTERNET_FLAG_MULTIPART, 0)
'End If
If CBool(hHttpOpenRequest) Then
'SetStatus "HttpSendRequest"
Debug.Print sOptionBuffer
Dim sHeader As String
'sHeader = "Accept: image/gif, image/x-xbitmap, image/jpeg,
image/pjpeg, application/vnd." & vbCrLf
'iRetVal = HttpAddRequestHeaders(hHtt pOpenReque st, sHeader,
Len(sHeader), HTTP_ADDREQ_FLAG_REPLACE Or HTTP_ADDREQ_FLAG_ADD)
'Debug.Print iRetVal & " " & Len(sHeader)
sHeader = "Accept-Language: en" & vbCrLf
iRetVal = HttpAddRequestHeaders(hHtt pOpenReque st, sHeader,
Len(sHeader), HTTP_ADDREQ_FLAG_REPLACE Or HTTP_ADDREQ_FLAG_ADD)
Debug.Print iRetVal & " " & Len(sHeader)
sHeader = "Connection: Keep-Alive" & vbCrLf
iRetVal = HttpAddRequestHeaders(hHtt pOpenReque st, sHeader,
Len(sHeader), HTTP_ADDREQ_FLAG_REPLACE Or HTTP_ADDREQ_FLAG_ADD)
Debug.Print iRetVal & " " & Len(sHeader);
sHeader = "Content-Type: application/x-www-form-url encoded"
& vbCrLf
iRetVal = HttpAddRequestHeaders(hHtt pOpenReque st, sHeader,
Len(sHeader), HTTP_ADDREQ_FLAG_REPLACE Or HTTP_ADDREQ_FLAG_ADD)
Debug.Print iRetVal & " " & Len(sHeader);
'sHeader = "Content-Type: text/html" & vbCrLf ' "Accept =
image/gif, image/x-xbitmap, image/jpeg, image/pjpeg, application/vnd." &
vbCrLf
'iRetVal = HttpAddRequestHeaders(hHtt pOpenReque st, sHeader,
Len(sHeader), HTTP_ADDREQ_FLAG_REPLACE Or HTTP_ADDREQ_FLAG_ADD)
'Debug.Print iRetVal & " " & Len(sHeader)
'Actually only INTERNET_OPTION_RECEIVE_TI MEOUT works. More info see the
following KB:
'BUG: InternetSetOption Does Not Set Timeout Values [axsdk]
'ID: Q176420 CREATED: 06-NOV-1997 MODIFIED: 06-NOV-1997
Dim dwTimeOut As Long
dwTimeOut = 30000
iRetVal = InternetSetOption(hHttpOpe nRequest,
INTERNET_OPTION_CONNECT_TI MEOUT, _
dwTimeOut, 4)
Debug.Print iRetVal & " " & Err.LastDllError & " " &
"INTERNET_OPTION_CONNECT_T IMEOUT"
iRetVal = InternetSetOption(hHttpOpe nRequest,
INTERNET_OPTION_RECEIVE_TI MEOUT, _
dwTimeOut, 4)
Debug.Print iRetVal & " " &
"INTERNET_OPTION_RECEIVE_T IMEOUT"
iRetVal = InternetSetOption(hHttpOpe nRequest,
INTERNET_OPTION_SEND_TIMEO UT, _
dwTimeOut, 4)
Debug.Print iRetVal & " " & "INTERNET_OPTION_SEND_TIME OUT"
Resend:
iRetVal = HttpSendRequest(hHttpOpenR equest, vbNullString, 0,
sOptionBuffer, lOptionBufferLen)
Dim dwStatus As Long, dwStatusSize As Long
dwStatusSize = Len(dwStatus)
HttpQueryInfo hHttpOpenRequest, HTTP_QUERY_FLAG_NUMBER Or
HTTP_QUERY_STATUS_CODE, dwStatus, dwStatusSize, 0
Select Case dwStatus
Case HTTP_STATUS_PROXY_AUTH_REQ
'make sure change it to your user name and password.
'Note Poxy authentication only works for IE40 wininet.
For IE3.0x, you need to
'manually add Proxy-Authentication header.
iRetVal = InternetSetOptionStr(hHttp OpenReques t,
INTERNET_OPTION_PROXY_USER NAME, _
"IUSR_WEIHUA1", Len("IUSR_WEIHUA1") + 1)
iRetVal = InternetSetOptionStr(hHttp OpenReques t,
INTERNET_OPTION_PROXY_PASS WORD, _
"IUSR_WEIHUA1", Len("IUSR_WEIHUA1") + 1)
Case HTTP_STATUS_DENIED
iRetVal = InternetSetOptionStr(hHttp OpenReques t,
INTERNET_OPTION_USERNAME, _
"IUSR_WEIHUA1", Len("IUSR_WEIHUA1") + 1)
iRetVal = InternetSetOptionStr(hHttp OpenReques t,
INTERNET_OPTION_PASSWORD, _
"IUSR_WEIHUA1", Len("IUSR_WEIHUA1") + 1)
GoTo Resend
End Select
If iRetVal Then
Else
' HttpSendRequest failed
sStatus = "HttpSendRequest call failed; Error code: " &
Err.LastDllError & "."
End If
Else
' HttpOpenRequest failed
sStatus = "HttpOpenRequest call failed; Error code: " &
Err.LastDllError & "."
End If
Else
' InternetConnect failed
sStatus = "InternetConnect call failed; Error code: " &
Err.LastDllError & "."
End If
Else
' hInternetSession handle not allocated
sStatus = "InternetOpen call failed: Error code: " &
Err.LastDllError & "."
End If
GetPage
InternetCloseHandle (hHttpOpenRequest)
InternetCloseHandle (hInternetConnect)
InternetCloseHandle (hInternetSession)
End Sub
Private Function GetPage()
Dim bDoLoop As Boolean
Dim sReadBuffer As String * 2048
Dim lNumberOfBytesRead As Long
Dim sBuffer As String
On Error Resume Next
bDoLoop = True
While bDoLoop
sReadBuffer = vbNullString
bDoLoop = InternetReadFile(hHttpOpen Request, sReadBuffer,
Len(sReadBuffer), lNumberOfBytesRead)
sBuffer = sBuffer & Left$(sReadBuffer, lNumberOfBytesRead)
If Not CBool(lNumberOfBytesRead) Then bDoLoop = False
'If CBool(Val(lblContentLength )) Then ProgressBar1.Value =
ProgressBar1.Value + lNumberOfBytesRead
Wend
txtHTML = sBuffer
'ProgressBar1.Value = 0
End Function
Private Function CheckUrl() As String
If Len(txtURL) = 0 Then txtURL = "www.microsoft.com"
Dim posSlash As Long
posSlash = InStr(txtURL, "/")
If InStr(txtURL, "/") <> 0 Then
CheckUrl = Left(txtURL, InStr(txtURL, "/") - 1)
Else
CheckUrl = txtURL
End If
End Function
Private Function GetUrlObject() As String
If InStr(txtURL, "/") <> 0 Then
GetUrlObject = Right(txtURL, Len(txtURL) - InStr(txtURL, "/") + 1)
Else
GetUrlObject = ""
End If
End Function
--------------------------
I probably have extra un-needed code in there also... I got the code from a web site and don't have alot of experience with API calls so I haven't cleaned it up.
Any ideas how to fix this problem?
Option Explicit
Private hInternetSession As Long
Private hInternetConnect As Long
Private hHttpOpenRequest As Long
Private txtURL As String
Private Sub cmdGO_Click()
hInternetSession = 0
hHttpOpenRequest = 0
hInternetConnect = 0
hInternetSession = InternetOpen(scUserAgent,
INTERNET_OPEN_TYPE_PRECONF
If CBool(hInternetSession) Then
txtHTML = "Ready"
Else
txtHTML = "InternetOpen failed."
End If
txtURL = txtUrls.Text
'-------------------------
---------
Dim iRetVal As Integer
Dim sBuffer As String * 1024
Dim lBufferLen As Long
Dim vDllVersion As tWinInetDLLVersion
Dim sStatus As String
Dim sOptionBuffer As String
Dim lOptionBufferLen As Long
lBufferLen = Len(sBuffer)
If CBool(hInternetSession) Then
' SetStatus "InternetQueryOption"
InternetQueryOption hInternetSession, INTERNET_OPTION_VERSION,
vDllVersion, Len(vDllVersion)
hInternetConnect = InternetConnect(hInternetS
INTERNET_DEFAULT_HTTP_PORT
"", "", INTERNET_SERVICE_HTTP, 0, 0)
If hInternetConnect > 0 Then
'SetStatus "HttpOpenRequest"
'If optGet.Value = True Then
sOptionBuffer = vbNullString
lOptionBufferLen = 0
hHttpOpenRequest = HttpOpenRequest(hInternetC
"GET", GetUrlObject, "HTTP/1.0", vbNullString, 0, _
INTERNET_FLAG_RELOAD Or INTERNET_FLAG_KEEP_CONNECT
0)
'Else
' sOptionBuffer = txtPost.Text
' lOptionBufferLen = Len(sOptionBuffer)
' hHttpOpenRequest = HttpOpenRequest(hInternetC
"POST", GetUrlObject, "HTTP/1.0", vbNullString, 0, _
' INTERNET_FLAG_RELOAD Or INTERNET_FLAG_MULTIPART, 0)
'End If
If CBool(hHttpOpenRequest) Then
'SetStatus "HttpSendRequest"
Debug.Print sOptionBuffer
Dim sHeader As String
'sHeader = "Accept: image/gif, image/x-xbitmap, image/jpeg,
image/pjpeg, application/vnd." & vbCrLf
'iRetVal = HttpAddRequestHeaders(hHtt
Len(sHeader), HTTP_ADDREQ_FLAG_REPLACE Or HTTP_ADDREQ_FLAG_ADD)
'Debug.Print iRetVal & " " & Len(sHeader)
sHeader = "Accept-Language: en" & vbCrLf
iRetVal = HttpAddRequestHeaders(hHtt
Len(sHeader), HTTP_ADDREQ_FLAG_REPLACE Or HTTP_ADDREQ_FLAG_ADD)
Debug.Print iRetVal & " " & Len(sHeader)
sHeader = "Connection: Keep-Alive" & vbCrLf
iRetVal = HttpAddRequestHeaders(hHtt
Len(sHeader), HTTP_ADDREQ_FLAG_REPLACE Or HTTP_ADDREQ_FLAG_ADD)
Debug.Print iRetVal & " " & Len(sHeader);
sHeader = "Content-Type: application/x-www-form-url
& vbCrLf
iRetVal = HttpAddRequestHeaders(hHtt
Len(sHeader), HTTP_ADDREQ_FLAG_REPLACE Or HTTP_ADDREQ_FLAG_ADD)
Debug.Print iRetVal & " " & Len(sHeader);
'sHeader = "Content-Type: text/html" & vbCrLf ' "Accept =
image/gif, image/x-xbitmap, image/jpeg, image/pjpeg, application/vnd." &
vbCrLf
'iRetVal = HttpAddRequestHeaders(hHtt
Len(sHeader), HTTP_ADDREQ_FLAG_REPLACE Or HTTP_ADDREQ_FLAG_ADD)
'Debug.Print iRetVal & " " & Len(sHeader)
'Actually only INTERNET_OPTION_RECEIVE_TI
following KB:
'BUG: InternetSetOption Does Not Set Timeout Values [axsdk]
'ID: Q176420 CREATED: 06-NOV-1997 MODIFIED: 06-NOV-1997
Dim dwTimeOut As Long
dwTimeOut = 30000
iRetVal = InternetSetOption(hHttpOpe
INTERNET_OPTION_CONNECT_TI
dwTimeOut, 4)
Debug.Print iRetVal & " " & Err.LastDllError & " " &
"INTERNET_OPTION_CONNECT_T
iRetVal = InternetSetOption(hHttpOpe
INTERNET_OPTION_RECEIVE_TI
dwTimeOut, 4)
Debug.Print iRetVal & " " &
"INTERNET_OPTION_RECEIVE_T
iRetVal = InternetSetOption(hHttpOpe
INTERNET_OPTION_SEND_TIMEO
dwTimeOut, 4)
Debug.Print iRetVal & " " & "INTERNET_OPTION_SEND_TIME
Resend:
iRetVal = HttpSendRequest(hHttpOpenR
sOptionBuffer, lOptionBufferLen)
Dim dwStatus As Long, dwStatusSize As Long
dwStatusSize = Len(dwStatus)
HttpQueryInfo hHttpOpenRequest, HTTP_QUERY_FLAG_NUMBER Or
HTTP_QUERY_STATUS_CODE, dwStatus, dwStatusSize, 0
Select Case dwStatus
Case HTTP_STATUS_PROXY_AUTH_REQ
'make sure change it to your user name and password.
'Note Poxy authentication only works for IE40 wininet.
For IE3.0x, you need to
'manually add Proxy-Authentication header.
iRetVal = InternetSetOptionStr(hHttp
INTERNET_OPTION_PROXY_USER
"IUSR_WEIHUA1", Len("IUSR_WEIHUA1") + 1)
iRetVal = InternetSetOptionStr(hHttp
INTERNET_OPTION_PROXY_PASS
"IUSR_WEIHUA1", Len("IUSR_WEIHUA1") + 1)
Case HTTP_STATUS_DENIED
iRetVal = InternetSetOptionStr(hHttp
INTERNET_OPTION_USERNAME, _
"IUSR_WEIHUA1", Len("IUSR_WEIHUA1") + 1)
iRetVal = InternetSetOptionStr(hHttp
INTERNET_OPTION_PASSWORD, _
"IUSR_WEIHUA1", Len("IUSR_WEIHUA1") + 1)
GoTo Resend
End Select
If iRetVal Then
Else
' HttpSendRequest failed
sStatus = "HttpSendRequest call failed; Error code: " &
Err.LastDllError & "."
End If
Else
' HttpOpenRequest failed
sStatus = "HttpOpenRequest call failed; Error code: " &
Err.LastDllError & "."
End If
Else
' InternetConnect failed
sStatus = "InternetConnect call failed; Error code: " &
Err.LastDllError & "."
End If
Else
' hInternetSession handle not allocated
sStatus = "InternetOpen call failed: Error code: " &
Err.LastDllError & "."
End If
GetPage
InternetCloseHandle (hHttpOpenRequest)
InternetCloseHandle (hInternetConnect)
InternetCloseHandle (hInternetSession)
End Sub
Private Function GetPage()
Dim bDoLoop As Boolean
Dim sReadBuffer As String * 2048
Dim lNumberOfBytesRead As Long
Dim sBuffer As String
On Error Resume Next
bDoLoop = True
While bDoLoop
sReadBuffer = vbNullString
bDoLoop = InternetReadFile(hHttpOpen
Len(sReadBuffer), lNumberOfBytesRead)
sBuffer = sBuffer & Left$(sReadBuffer, lNumberOfBytesRead)
If Not CBool(lNumberOfBytesRead) Then bDoLoop = False
'If CBool(Val(lblContentLength
ProgressBar1.Value + lNumberOfBytesRead
Wend
txtHTML = sBuffer
'ProgressBar1.Value = 0
End Function
Private Function CheckUrl() As String
If Len(txtURL) = 0 Then txtURL = "www.microsoft.com"
Dim posSlash As Long
posSlash = InStr(txtURL, "/")
If InStr(txtURL, "/") <> 0 Then
CheckUrl = Left(txtURL, InStr(txtURL, "/") - 1)
Else
CheckUrl = txtURL
End If
End Function
Private Function GetUrlObject() As String
If InStr(txtURL, "/") <> 0 Then
GetUrlObject = Right(txtURL, Len(txtURL) - InStr(txtURL, "/") + 1)
Else
GetUrlObject = ""
End If
End Function
--------------------------
I probably have extra un-needed code in there also... I got the code from a web site and don't have alot of experience with API calls so I haven't cleaned it up.
Any ideas how to fix this problem?
HATCHET: Good Point.
Can you Please email me the code topull down HTML code from a Web Page and save it to a .txt file .
Please thank you.
Can you Please email me the code topull down HTML code from a Web Page and save it to a .txt file .
Please thank you.
ASKER
I would have made it more points but thats all I have at the moment. Could I have the 5 line code? and if it goes through it more than once will it freeze the program until it has finished?
Thanks.
Thanks.
ASKER CERTIFIED SOLUTION
membership
This solution is only available to members.
To access this solution, you must be a member of Experts Exchange.
ASKER
mark2150,
That worked perfect! I forgot about the DoEvents.
Thanks.
That worked perfect! I forgot about the DoEvents.
Thanks.
Here's the 5 lines of code that I mentioned to save a file on the internet to a file on your computer. You can replace the http:// with ftp:// and get a file from an FTP server too. Hope this helps a fe people. =]
Dim strSaveThisInfo as String
Inet1.AccessType = icUseDefault
strSaveThisInfo =
Inet1.OpenURL("http://www.microsoft.com/index.html")
Open "C:\Test.txt" For Output As #1
Print #1, strSaveThisInfo
Close #1
HATCHET
Dim strSaveThisInfo as String
Inet1.AccessType = icUseDefault
strSaveThisInfo =
Inet1.OpenURL("http://www.microsoft.com/index.html")
Open "C:\Test.txt" For Output As #1
Print #1, strSaveThisInfo
Close #1
HATCHET
ASKER
I used that code like that before... the reason I switched was so I could set the UserAgent. With the Internet Control, Internet Log files show: MS URL Control 5.0 or something like that.
Do you honestly expect someone to weed through your program and fix it for you for 25 points?! That code is a MESS!! State what you need done and wait for responses. Restate the question as needed based upon feedback. Don't just dump your code out here and say "WILL SOMEONE FIX THIS FOR ME?!"
If you're trying to pull down HTML code from a Web Page and save it to a .txt file, I have a snippit of code about 5 lines long that will do it quick ly and efficiently, but I'm not gunna bother with your code up there for 25 points, sorry.
HATCHET