LinkBack URL
About LinkBacksThe 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
Register To Reply
Bookmarks