3
\$\begingroup\$

first time using Code Review, although I have been active on StackOverflow, hope I'm in the right place.

I am putting together Excel VBA code that using information from various columns on a worksheet to search for a document on a company intranet site, and save the document as a PDF, then move on to the next line and repeat.

My issue is that the code works well for the first 80-100 lines or so, then Excel stops responding. I'm pretty sure this is because I have room to increase efficiency in my code, but I'm a VBA beginner, especially when it comes to using VBA with IE. I may be in a bit over my head.

In short, my question is, is there a noticeable error I am making that would cause Excel to regularly "Stop Responding" after looping through so many lines?

I have been searching for advice on StackOverflow, but have not come across a solution that works for me yet. I saw that an array could help? Not sure how to put 5 or so columns of data into a single array for my loop.

The code:

Option Explicit

Declare PtrSafe Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As Long)

Public Const BM_CLICK = &HF5
Public Declare PtrSafe Function FindWindow Lib "user32" Alias "FindWindowA" (ByVal lpClassName As String, ByVal lpWindowName As String) As LongPtr
Public Declare PtrSafe Function FindWindowEx Lib "user32" Alias "FindWindowExA" (ByVal hWnd1 As LongPtr, ByVal hWnd2 As LongPtr, ByVal lpsz1 As String, ByVal lpsz2 As String) As LongPtr
Public Declare PtrSafe Function SendMessage Lib "user32" Alias "SendMessageA" (ByVal hwnd As LongPtr, ByVal wMsg As Long, ByVal wParam As LongPtr, lParam As Any) As LongPtr
#If VBA7 Then
    Private Declare PtrSafe Sub keybd_event Lib "user32.dll" (ByVal bVk As Byte, ByVal bScan As Byte, _
                                                              ByVal dwFlags As LongPtr, ByVal dwExtraInfo As LongPtr)
    Private Declare PtrSafe Function GetKeyboardState Lib "user32.dll" (ByVal lpKeyState As LongPtr) As Boolean
#Else
    Private Declare PtrSafe Sub keybd_event Lib "user32.dll" (ByVal bVk As Byte, ByVal bScan As Byte, _
                                                      ByVal dwFlags As Long, ByVal dwExtraInfo As Long)
    Private Declare PtrSafe Function GetKeyboardState Lib "user32.dll" (ByVal lpKeyState As Long) As Boolean
#End If
Private Const KEYEVENTF_EXTENDEDKEY As Long = &H1
Private Const KEYEVENTF_KEYUP As Long = &H2
Private Const VK_NUMLOCK As Byte = &H90
Private Const NumLockScanCode As Byte = &H45

Public Sub Papervision()
Dim ieApp As InternetExplorerMedium Dim ee As Variant, htmldoc Dim wb As Workbook 
Dim FilePath As String 
Dim oShell As Object 
Dim oShellWindows As Object 
Dim oShellWindow As Object 
Dim sPartialURL As String 
Dim F As Range 
'***** Setting variables for Windows API. Will be used to find the proper windows box by name ***** 
Dim windowHWND As LongPtr 
Dim WinHwnd As LongPtr 
Dim buttonHWND As LongPtr 
Dim hwnd As String 
Dim hwindow2 As String 
'***** Declaring our Loop variables ***** 
Dim wsSheet As Worksheet, Rows1 As Long, Invoices As Range, Invoice As Range '***** Setting the workbook and worksheet ***** 
Set wb = ThisWorkbook Set wsSheet = wb.Sheets("Email Check Pull") 
'***** Finding the last used rows ***** 
Rows1 = wsSheet.Cells(wsSheet.Rows.Count, "G").End(xlUp).Row 
'***** Set range for the loop ***** 
Set Invoices = wsSheet.Range("G2:G" & Rows1) 
'***** Set the browser ***** 
Set ieApp = New InternetExplorerMedium 
FilePath = "C:\Users\username\Documents\Downloads\" 
Dim inCounter As Integer

'***** Navigating to our Papervision link and setting the size of the IE window *****
                With ieApp
                    .Navigate "http://ctdayppv02/PVE.aspx"
                    .Visible = True
                    .AddressBar = 0
                    .StatusBar = 0
                    .Toolbar = 0
                    .MenuBar = 0
                    .Height = 700
                    .Width = 950

        '***** Waiting for IE to load the page *****
                Do While ieApp.Busy: DoEvents: Loop
                Do Until ieApp.ReadyState = READYSTATE_COMPLETE: DoEvents: Loop

        '***** Setting an additional variant to be used to click the Login button *****
                Set htmldoc = ieApp.Document

        '***** Using the HTML elements to enter the username and password *****
                ieApp.Document.all.Item("txtUserName").Value = "name"
                ieApp.Document.all.Item("txtPassword").Value = "pass"

        '***** The login button was not simply defined as a login button, so we search for relevant buttons by the HTML tag name *****
        '***** When we find a clickable button, we click it and then sleep for 1 second *****
                For Each ee In htmldoc.getElementsByTagName("span")
                    If ee.ClassName = "dijitReset dijitInline dijitButtonNode" And InStr(ee.innerHTML, "btnLogin") > 0 Then
                     ee.Click: DoEvents: Sleep 2000
                     Exit For
                    End If
                Next ee

        '***** This finds the project HTML element in the navigation sidebar and clicks it, then sleeps for 1 second *****
                ieApp.Document.all.Item("project118").Click: DoEvents: Sleep 1000

        '***** This finds the Search Type dropdown box from the Project Search Options and selects the "AND" option, then sleeps for 1 second *****
                ieApp.Document.getElementById("lstSearchType").Value = "And": DoEvents: Sleep 1000

                End With

        '***** Setting the Loop to do the following steps and then repeat for the next item *****

            For Each Invoice In Invoices.Cells
                If Invoice.Offset(0, 1).Value <> "" Then GoTo NxtInv

            With ieApp
            '***** Inputting the Invoice # from Column G into the INV# input box *****
                    ieApp.Document.all.Item("txtFrom4").Value = Invoice

            '***** Inputting the Vendor # from Column A into the VEN# input box *****
                    ieApp.Document.all.Item("txtFrom1").Value = "*" & Invoice.Offset(0, -6).Value

            '***** Clearing the VEN LOC input box *****
                    ieApp.Document.all.Item("txtFrom2").Value = ""

            '***** Inputting the Amount into the input box *****
                    ieApp.Document.all.Item("txtFrom6").Value = Invoice.Offset(0, 2).Value
                    Application.Wait Now + TimeValue("0:00:01")

            '***** Click the Search button *****
                    ieApp.Document.all.Item("btnSubmitProjectSearch").Click: DoEvents: Sleep 1000

            On Error GoTo Handler
            '***** Click the Print button *****
                    ieApp.Document.all.Item("printLink").Click
            On Error GoTo 0
                    Do While ieApp.Busy Or ieApp.ReadyState <> READYSTATE_COMPLETE
                        Sleep 250
                    Loop

            ''***** Will click the Print button. MUST HAVE MICROSOFT PDF AS DEFAULT PRINTER *****
                    If getWindowPointer("Print", "#32770") = 0 Then
                        Do While ieApp.Busy Or ieApp.ReadyState <> READYSTATE_COMPLETE
                            Sleep 250
                        Loop
                    End If

                    windowHWND = getWindowPointer("Print", "#32770")

                    If windowHWND > 0 Then
                    '***** Add a small delay to allow the window to finish rendering if needed *****
                        Sleep 250
                        buttonHWND = FindWindowEx(windowHWND, 0, "Button", "&Print")
                        If buttonHWND > 0 Then
                        SendMessage buttonHWND, BM_CLICK, 0, 0
                        Else
                            Debug.Print "didn't find button!"
                        End If
                    End If

            '***** Locate the "Save Print Output As" window, enter the filepath/filename and press ENTER *****
                    hwnd = FindWindow(vbNullString, "Save Print Output As")
                    Do
                    DoEvents
                    hwindow2 = FindWindow(vbNullString, "Save Print Output As")
                    Loop Until hwindow2 > 0

                    SendKeys FilePath & Invoice
                    DoEvents
                    SendKeys "{Enter}"
                    DoEvents

            '***** Locate the Viewer Control box that appears after saving and press ENTER to advance *****
                    hwnd = FindWindow(vbNullString, "PaperVision Document Viewer Control")
                    Do
                    DoEvents
                    hwindow2 = FindWindow(vbNullString, "PaperVision Document Viewer Control")
                    Loop Until hwindow2 > 0

                    SendKeys "{Enter}"
                    DoEvents

            '***** Here we locate any IE instance that includes the partial URL provided, and will close those IE instances *****
                    sPartialURL = "http://ctdayppv02/PVEShowDocPopup.aspx?"

                    Set oShell = CreateObject("Shell.Application")
                    Set oShellWindows = oShell.Windows

                    For Each oShellWindow In oShellWindows
                        If oShellWindow.Name = "Internet Explorer" Then
                            If InStr(oShellWindow.Document.URL, sPartialURL) > 0 Then
                                Exit For
                            End If
                        End If
                    Next oShellWindow

                    If Not oShellWindow Is Nothing Then
                        oShellWindow.Quit
                        DoEvents
                    Else
                    End If

                    Set oShell = Nothing
                    Set oShellWindows = Nothing
                    Set oShellWindow = Nothing

            '***** This will click the link to go back to the search screen in Papervision
                    ieApp.Document.all.Item("btnSearchResults").Click: DoEvents: Sleep 1000

            '***** Finding the last used row in the Final Email List worksheet and putting the PDF file path and Invoice number on that sheet *****
            '***** This will later be used to send the appropriate PDF to its corresponding email address *****
                    Set F = ThisWorkbook.Worksheets("Final Email List").Cells(Rows.Count, 1).End(xlUp) 'last cell in Column A with data
                    If Len(F.Value) > 0 Then Set F = F.Offset(1)
                    F.Value = Invoice
                    DoEvents
                    Set F = F.Offset(0, 1)
                    F.Value = FilePath & Invoice
                    DoEvents
                    inCounter = inCounter + 1
                    End With
                    DoEvents
            '***** Repeat with the next item in the loop *****
                GoTo NxtInv

    '***** This is used to resume the For Each loop and begin the process for the next invoice ***** 

NxtInv:
        If Invoice.Offset(1, 0) Is Nothing Then GoTo Finished
        Next Invoice    '***** This is the start of the Error Handler. We use it to move to the next invoice and to ensure the error handling is properly ended ***** 
Handler: 
        Resume NxtInv

'***** Notify user when downloads are complete ***** 
Finished:
        ieApp.Quit
        Set ieApp = Nothing
        ToggleNumlock True
        MsgBox ("Papervison search completed!")

End Sub

Private Function getWindowPointer(WindowName As String, Optional ClassName As String = vbNullString) As LongPtr
'***** This function is used to find the named window in the above sub *****
        Dim i As Byte
        Dim hwnd As LongPtr
        'Wait for the window to exist then return the pointer
        For i = 1 To 100
            hwnd = FindWindow(ClassName, WindowName)
            If hwnd > 0 Then
                getWindowPointer = hwnd
                Exit For
            End If
            DoEvents
            Sleep 200
        Next
    End Function

Private Sub ToggleNumlock(enabled As Boolean)
    Dim keystate(255) As Byte
    'Test current keyboard state.
    GetKeyboardState (VarPtr(keystate(0)))
    If (Not keystate(VK_NUMLOCK) And enabled) Or (keystate(VK_NUMLOCK) And Not enabled) Then
        'Send a keydown
        keybd_event VK_NUMLOCK, NumLockScanCode, KEYEVENTF_EXTENDEDKEY, 0&
        'Send a keyup
        keybd_event VK_NUMLOCK, NumLockScanCode, KEYEVENTF_EXTENDEDKEY Or KEYEVENTF_KEYUP, 0&
    End If
End Sub

Any advice or guidance on what may be causing Excel to work for the first bunch of rows and then stop responding would be greatly appreciated, thank you!

\$\endgroup\$
3
  • 1
    \$\begingroup\$ With all the DoEvents in there, anything else happening on your PC while this is running will steal the CPU from it. Using sleep with a very small period may be more effective. \$\endgroup\$
    – FreeMan
    Nov 5, 2018 at 21:02
  • \$\begingroup\$ Your declarations section needs fixing as you have pasted with several Dim statements on one line and a missing type declaration for one variable. \$\endgroup\$
    – QHarr
    Nov 15, 2018 at 17:28
  • \$\begingroup\$ Did you try just sending a web request with the credentials to the URL with the file location stackoverflow.com/a/29441633/4839827. Also you could try URLDownloadToFile Api. stackoverflow.com/a/26186347/4839827 \$\endgroup\$ Dec 24, 2018 at 18:38

0

Your Answer

By clicking “Post Your Answer”, you agree to our terms of service, privacy policy and cookie policy

Browse other questions tagged or ask your own question.