Home |
Search |
Today's Posts |
#1
Posted to microsoft.public.excel.programming
|
|||
|
|||
VBA WinInet Code Crashes Excel
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 a 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 |
Reply |
Thread Tools | Search this Thread |
Display Modes | |
|
|
Similar Threads | ||||
Thread | Forum | |||
Excel crashes when adding code using vbproject object? | Excel Programming | |||
Code that Crashes Excel without fail - Excel 97 SR2 WinNT | Excel Programming | |||
Simple code crashes Excel | Excel Programming | |||
VBA File in EXCEL 2000 Crashes in code that I have made no changes | Excel Programming | |||
Code in ThisWorkbook crashes Excel | Excel Programming |