WinInet Code Crashes Excel

clindner

New Member
Joined
Jul 18, 2006
Messages
4
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... Sorry about the formatting, I suck at ubb stuff.

Rich (BB code):
------------------- 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
 

Excel Facts

How to find 2nd largest value in a column?
MAX finds the largest value. =LARGE(A:A,2) will find the second largest. =SMALL(A:A,3) will find the third smallest

Forum statistics

Threads
1,213,528
Messages
6,114,154
Members
448,553
Latest member
slaytonpa

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Back
Top