VBA WinInet Code Crashes Excel

C

curt.lindner

The following code has starting to cause Excel to lock up upon exit. I
have trapped the execution, starting at the beginning, and the crash
occurs only if the code executes to the first "InternetOpenURL"
command. Otherwise, the code steps down a column of URLs, extracts an
HTTP PDF file link from the HTML source produced by each URL and
downloads the file using the SaveFile routine. This program will run
for hours, allow each file to saved after the macro stops executing,
but freezes the moment I try to exit from Excel?

The obvious culprit is in the InternetOpenURL command, but I swear this
code worked just fine yesterday. I thought I might have changed
something ever so slightly in the declarations or the usage of the
subroutine, but I've double checked against my references, and
everything seems OK.

I'm using Excel 2003 SP2, but the same problems occur when using Excel
2000. My references are:

Visual Basic for Applications
Excel 11 Object Library
OLE Automation
Office 11 Object Library
Forms 2.0 Object Library
VBScript Regular Expressions 1.0
Microsoft Internet Transfer Control 6.0

Thanks for any expert solutions you guys can come up with...

-------------------- Module 1
Public hOpen As Long, hOpenUrl As Long, bRet As Boolean
Public sBuffer As String * 2048, bytesread As Long, bDoLoop As Boolean
Public Declare Function InternetOpen Lib "wininet" Alias
"InternetOpenA" _
(ByVal sAgent As String, ByVal lAccessType As Long, ByVal sProxyName As
String, _
ByVal sProxyBypass As String, ByVal lFlags As Long) As Long
Public Declare Function InternetOpenUrl Lib "wininet" Alias
"InternetOpenUrlA" _
(ByVal hOpen As Long, ByVal sURL As String, ByVal sHeaders As String, _
ByVal lLength As Long, ByVal lFlags As Long, ByVal lContext As Long) As
Long
Public Declare Function InternetReadFile Lib "wininet" _
(ByVal hFile As Long, ByVal tmp As String, ByVal lNumBytesToRead As
Long, _
bytesread As Long) As Integer
Public Declare Function InternetCloseHandle Lib "wininet" _
(ByVal hInet As Long) As Integer
Public Declare Function HttpQueryInfo Lib "wininet" Alias
"HttpQueryInfoA" _
(ByVal hOpen As Long, ByVal infotype As Long, _
ByVal iBuffer As String, ByRef bufferlength As Long, ByVal Index As
Long) As Long

------------------- Module 2
[THE FUNCTION BEGINS HERE]
Sub GetFiles()

Dim URL As String, FileData As String, sLink As String
Dim ie_doc As Object, objRegExp As RegExp, objMatch As Object
Dim i As Long

Do
URL = ActiveCell.Value
hOpen = InternetOpen("VB OpenUrl", 0, vbNullString, vbNullString,
0)
[IF THE CODE IS STOPPED HERE, EXCEL CAN QUIT NORMALLY]
hOpenUrl = InternetOpenUrl(hOpen, URL, vbNullString, 0, &H80000000,
0)
[FROM HERE ON, EXCEL FREEZES WHEN I TRY TO EXIT]
DoEvents

bDoLoop = True
While bDoLoop
sBuffer = vbNullString
bRet = InternetReadFile(hOpenUrl, sBuffer, Len(sBuffer),
bytesread)
FileData = FileData & Left$(sBuffer, bytesread)
If Not CBool(bytesread) Then bDoLoop = False
Wend

If hOpenUrl <> 0 Then InternetCloseHandle (hOpenUrl)
If hOpen <> 0 Then InternetCloseHandle (hOpen)

Set objRegExp = New RegExp
objRegExp.IgnoreCase = True
objRegExp.Global = True

objRegExp.Pattern = "http://(.*?)pdf"

For Each objMatch In objRegExp.Execute(FileData)
ActiveCell.Offset(0, 1).Range("A1").Value = objMatch
sLink = objMatch
Next

SaveFile (sLink) [THIS CODE IN MODULE3]
ActiveCell.Offset(1, 0).Select
DoEvents
FileData = ""

Loop Until ActiveCell.Value = ""

End Sub

-------------------- Module 3
Sub SaveFile(loc As String)

Dim URL As String, FileData As String, FileName As String
Dim TotalSize As Long, TimerBase As Long, TimeElapsed As Long
Dim DataBuff As String * 12, BuffLen As Long, FileSize As Long
Dim FileSpeed As Long, FileRemaining As Long, TimeRemaining As Long
Dim bReadError As Boolean

URL = loc
BuffLen = Len(DataBuff)

hOpen = InternetOpen("VB OpenUrl", 0, vbNullString, vbNullString, 0)
hOpenUrl = InternetOpenUrl(hOpen, URL, vbNullString, 0, &H80000000,
0)
hQuery = HttpQueryInfo(hOpenUrl, 5, DataBuff, BuffLen, 0)

FileSize = Val(DataBuff) / 1000

UserForm2.Show
UserForm2.lblFileName.Caption = FileName & ActiveCell.Offset(0,
-2).Value & " (" & _
ActiveCell.Offset(0, -1).Value & ").pdf"
UserForm2.Frame2.Width = 0 ' Max Width = 295

TimerBase = Timer - 1

bDoLoop = True
bReadError = False

While bDoLoop
iBuffer = vbNullString
bRet = InternetReadFile(hOpenUrl, iBuffer, Len(iBuffer),
bytesread)
If bRet Then
FileData = FileData & Left(iBuffer, bytesread)
TotalSize = TotalSize + bytesread / 1000
FileRemaining = FileSize - TotalSize
TimeElapsed = Timer - TimerBase
FileSpeed = Round(TotalSize / TimeElapsed, 1)
TimeRemaining = Round(FileRemaining / FileSpeed, 0)
UserForm2.Frame2.Width = 295 * (TotalSize / FileSize)
UserForm2.lblProgress.Caption = Format(TotalSize,
"###,###,###")
UserForm2.lblSpeed.Caption = Format(FileSpeed, "##0.0")
UserForm2.lblFileRemaining.Caption = Format(FileRemaining,
"###,###,###")
UserForm2.lblTimeRemaining.Caption = TimeRemaining
Else
ActiveCell.Offset(0, 1).Value = "<< File Read Error >>"
bReadError = True
bDoLoop = False
End If
DoEvents
If Not CBool(bytesread) Then bDoLoop = False
Wend

If hOpenUrl <> 0 Then InternetCloseHandle (hOpenUrl)
If hOpen <> 0 Then InternetCloseHandle (hOpen)

' To save to disk (add required extension):

If Not bReadError Then
FileName = "C:\files\downloads\"
FileName = FileName & ActiveCell.Offset(0, -2).Value & " (" & _
ActiveCell.Offset(0, -1).Value & ").pdf"
Open FileName For Binary Access Write As #1
Put #1, , FileData
Close #1
End If

UserForm2.Hide
Unload UserForm2

End Sub

-------------------- End of Code
 
T

Tim Williams

You could try this instead. A bit less code....
Tim

****************************************
Sub DownloadFile(sURL As String, sPath As String)

Dim oXHTTP As Object
Dim oStream As Object

Set oXHTTP = CreateObject("MSXML2.XMLHTTP")
Set oStream = CreateObject("ADODB.Stream")


oXHTTP.Open "GET", sURL, False
oXHTTP.send

oStream.Type = adTypeBinary
oStream.Open
oStream.Write oXHTTP.responseBody
oStream.SaveToFile sPath, adSaveCreateOverWrite
oStream.Close

Set oXHTTP = Nothing
Set oStream = Nothing

End Sub
******************************************
--
Tim Williams
Palo Alto, CA


The following code has starting to cause Excel to lock up upon exit. I
have trapped the execution, starting at the beginning, and the crash
occurs only if the code executes to the first "InternetOpenURL"
command. Otherwise, the code steps down a column of URLs, extracts an
HTTP PDF file link from the HTML source produced by each URL and
downloads the file using the SaveFile routine. This program will run
for hours, allow each file to saved after the macro stops executing,
but freezes the moment I try to exit from Excel?

The obvious culprit is in the InternetOpenURL command, but I swear this
code worked just fine yesterday. I thought I might have changed
something ever so slightly in the declarations or the usage of the
subroutine, but I've double checked against my references, and
everything seems OK.

I'm using Excel 2003 SP2, but the same problems occur when using Excel
2000. My references are:

Visual Basic for Applications
Excel 11 Object Library
OLE Automation
Office 11 Object Library
Forms 2.0 Object Library
VBScript Regular Expressions 1.0
Microsoft Internet Transfer Control 6.0

Thanks for any expert solutions you guys can come up with...

-------------------- Module 1
Public hOpen As Long, hOpenUrl As Long, bRet As Boolean
Public sBuffer As String * 2048, bytesread As Long, bDoLoop As Boolean
Public Declare Function InternetOpen Lib "wininet" Alias
"InternetOpenA" _
(ByVal sAgent As String, ByVal lAccessType As Long, ByVal sProxyName As
String, _
ByVal sProxyBypass As String, ByVal lFlags As Long) As Long
Public Declare Function InternetOpenUrl Lib "wininet" Alias
"InternetOpenUrlA" _
(ByVal hOpen As Long, ByVal sURL As String, ByVal sHeaders As String, _
ByVal lLength As Long, ByVal lFlags As Long, ByVal lContext As Long) As
Long
Public Declare Function InternetReadFile Lib "wininet" _
(ByVal hFile As Long, ByVal tmp As String, ByVal lNumBytesToRead As
Long, _
bytesread As Long) As Integer
Public Declare Function InternetCloseHandle Lib "wininet" _
(ByVal hInet As Long) As Integer
Public Declare Function HttpQueryInfo Lib "wininet" Alias
"HttpQueryInfoA" _
(ByVal hOpen As Long, ByVal infotype As Long, _
ByVal iBuffer As String, ByRef bufferlength As Long, ByVal Index As
Long) As Long

------------------- Module 2
[THE FUNCTION BEGINS HERE]
Sub GetFiles()

Dim URL As String, FileData As String, sLink As String
Dim ie_doc As Object, objRegExp As RegExp, objMatch As Object
Dim i As Long

Do
URL = ActiveCell.Value
hOpen = InternetOpen("VB OpenUrl", 0, vbNullString, vbNullString,
0)
[IF THE CODE IS STOPPED HERE, EXCEL CAN QUIT NORMALLY]
hOpenUrl = InternetOpenUrl(hOpen, URL, vbNullString, 0, &H80000000,
0)
[FROM HERE ON, EXCEL FREEZES WHEN I TRY TO EXIT]
DoEvents

bDoLoop = True
While bDoLoop
sBuffer = vbNullString
bRet = InternetReadFile(hOpenUrl, sBuffer, Len(sBuffer),
bytesread)
FileData = FileData & Left$(sBuffer, bytesread)
If Not CBool(bytesread) Then bDoLoop = False
Wend

If hOpenUrl <> 0 Then InternetCloseHandle (hOpenUrl)
If hOpen <> 0 Then InternetCloseHandle (hOpen)

Set objRegExp = New RegExp
objRegExp.IgnoreCase = True
objRegExp.Global = True

objRegExp.Pattern = "http://(.*?)pdf"

For Each objMatch In objRegExp.Execute(FileData)
ActiveCell.Offset(0, 1).Range("A1").Value = objMatch
sLink = objMatch
Next

SaveFile (sLink) [THIS CODE IN MODULE3]
ActiveCell.Offset(1, 0).Select
DoEvents
FileData = ""

Loop Until ActiveCell.Value = ""

End Sub

-------------------- Module 3
Sub SaveFile(loc As String)

Dim URL As String, FileData As String, FileName As String
Dim TotalSize As Long, TimerBase As Long, TimeElapsed As Long
Dim DataBuff As String * 12, BuffLen As Long, FileSize As Long
Dim FileSpeed As Long, FileRemaining As Long, TimeRemaining As Long
Dim bReadError As Boolean

URL = loc
BuffLen = Len(DataBuff)

hOpen = InternetOpen("VB OpenUrl", 0, vbNullString, vbNullString, 0)
hOpenUrl = InternetOpenUrl(hOpen, URL, vbNullString, 0, &H80000000,
0)
hQuery = HttpQueryInfo(hOpenUrl, 5, DataBuff, BuffLen, 0)

FileSize = Val(DataBuff) / 1000

UserForm2.Show
UserForm2.lblFileName.Caption = FileName & ActiveCell.Offset(0,
-2).Value & " (" & _
ActiveCell.Offset(0, -1).Value & ").pdf"
UserForm2.Frame2.Width = 0 ' Max Width = 295

TimerBase = Timer - 1

bDoLoop = True
bReadError = False

While bDoLoop
iBuffer = vbNullString
bRet = InternetReadFile(hOpenUrl, iBuffer, Len(iBuffer),
bytesread)
If bRet Then
FileData = FileData & Left(iBuffer, bytesread)
TotalSize = TotalSize + bytesread / 1000
FileRemaining = FileSize - TotalSize
TimeElapsed = Timer - TimerBase
FileSpeed = Round(TotalSize / TimeElapsed, 1)
TimeRemaining = Round(FileRemaining / FileSpeed, 0)
UserForm2.Frame2.Width = 295 * (TotalSize / FileSize)
UserForm2.lblProgress.Caption = Format(TotalSize,
"###,###,###")
UserForm2.lblSpeed.Caption = Format(FileSpeed, "##0.0")
UserForm2.lblFileRemaining.Caption = Format(FileRemaining,
"###,###,###")
UserForm2.lblTimeRemaining.Caption = TimeRemaining
Else
ActiveCell.Offset(0, 1).Value = "<< File Read Error >>"
bReadError = True
bDoLoop = False
End If
DoEvents
If Not CBool(bytesread) Then bDoLoop = False
Wend

If hOpenUrl <> 0 Then InternetCloseHandle (hOpenUrl)
If hOpen <> 0 Then InternetCloseHandle (hOpen)

' To save to disk (add required extension):

If Not bReadError Then
FileName = "C:\files\downloads\"
FileName = FileName & ActiveCell.Offset(0, -2).Value & " (" & _
ActiveCell.Offset(0, -1).Value & ").pdf"
Open FileName For Binary Access Write As #1
Put #1, , FileData
Close #1
End If

UserForm2.Hide
Unload UserForm2

End Sub

-------------------- End of Code
Click to expand...
 
C

curt.lindner

Thanks, I'll give it a shot. Is that just any of the MS XML Libraries?

Most of my code was for the user form and reporting the status. The
downloads are over a fairly slow VPN connection, and some of the files
are approaching 100MB, so the status reporting is helpful.

Is there a way to retrieve the file size from HTTP headers using this
code?
 
T

Tim Williams

Sorry - I didn't go through your code in detail so I didn't notice the requirement for progress reporting.

You may be able to do a HEAD request on the file to find it's size if the server reports it.
Typically I've used this code for smallish downloads, so can't guarantee how it would work for larger files of around the size
you're dealing with.

Tim



Thanks, I'll give it a shot. Is that just any of the MS XML Libraries?

Most of my code was for the user form and reporting the status. The
downloads are over a fairly slow VPN connection, and some of the files
are approaching 100MB, so the status reporting is helpful.

Is there a way to retrieve the file size from HTTP headers using this
code?
Click to expand...
 

Ask a Question

Want to reply to this thread or ask your own question?

You'll need to choose a username for the site, which only take a couple of moments. After that, you can post your question and our members will help you out.

Ask a Question

Similar Threads

parsing Html page 6
For the Pro's 0
InternetReadFile issue (bad char issue cont.) 1
Internet Connection Issue 1
Usage of InternetOpen from Outlook VB Add-in 1
FTPGetFile strange problem 0
How to save the Current Excel file to FTP server 0
Print with VBA 4

Top