Option Explicit
'Note - IE may block the download, displaying its Information Bar at the top of the tab, and preventing this program from
'automatically downloading the file. To prevent this, add http://www.nrldc.org to IE's Trusted sites (Tools - Internet Options -
'Security - Trusted sites - Sites)
Public Sub Main_Download()
Dim URL As String
Dim startDate As Date
Dim saveInFolder As String, saveAsFilename As String
URL = "http://www.nrldc.org/WBS/injsch.aspx"
saveInFolder = "C:\temp\Excel\"
saveAsFilename = "" 'use default filename
startDate = Date
IE_Navigate_and_Download URL, startDate, saveInFolder, saveAsFilename
End Sub
Private Sub IE_Navigate_and_Download(URL As String, startDate As Date, saveInFolder As String, saveAsFilename As String)
Dim IE As Object
Dim dateInput As Object
'Use existing IE window or open a new IE window
Set IE = Get_IE_Window()
If IE Is Nothing Then
Set IE = CreateObject("InternetExplorer.Application")
End If
With IE
SetForegroundWindow .hWnd
.Visible = True
.Navigate URL
While .Busy Or .ReadyState <> 4: DoEvents: Wend
'Populate HTML text box with specified date and refresh page
Set dateInput = .Document.forms(0).elements("txtStartDate")
If Not dateInput Is Nothing Then
dateInput.Value = Format(startDate, "dd-mm-yyyy")
.Navigate "javascript:__doPostBack('txtStartDate','')"
While .Busy Or .ReadyState <> READYSTATE_COMPLETE: DoEvents: Wend
Else
MsgBox "txtStartDate HTML element not found - unable to set specified date"
End If
'Click the download ncr link
.Navigate "javascript:__doPostBack('downloadncr','')"
End With
Download_File saveInFolder, saveAsFilename
SetForegroundWindow Application.hWnd
End Sub
Private Sub Download_File(saveInFolder As String, saveAsFilename As String)
'Handles the whole IE download file sequence
Dim fileExists As Boolean
'File Download window, with Open, Save and Cancel buttons - click Save
File_Download_Click_Save
'Save As window - set full filename
Save_As_Set_Filename saveInFolder, saveAsFilename
'Save As window - click Save and replace file if the '<file> already exists' popup window appears
fileExists = Save_As_Click_Save
If fileExists Then
File_Already_Exists Replace:=True
End If
'Optional Download complete window, with Open, Open Folder and Close buttons - click Close, or time out if window is not present
'This window also has a checkbox 'Close this dialog box when download completes'. This checkbox setting is controlled
'by 'Notify when downloads complete' in IE advanced options. If this checkbox is ticked, the following line is not required,
'though it shouldn't matter if it is left in as the routine will time out if the window isn't found.
Download_complete_Click_Close
Debug.Print "Download finished"
End Sub
Private Sub File_Download_Click_Save()
Dim hWnd As Long
Dim timeout As Date
Debug.Print "File_Download_Click_Save"
'Find the File Download window, waiting a maximum of 30 seconds for it to appear
timeout = Now + TimeValue("00:00:30")
Do
hWnd = FindWindow("#32770", "File Download")
DoEvents
Sleep 200
Loop Until hWnd Or Now > timeout
Debug.Print " File Download window "; Hex(hWnd)
If hWnd Then
'Find the child Save button
hWnd = FindWindowEx(hWnd, 0, "Button", "&Save")
Debug.Print " Save button "; Hex(hWnd)
End If
If hWnd Then
'Click the Save button
SetForegroundWindow hWnd
Sleep 600 'this sleep is required and 600 milliseconds seems to be the minimum that works
SendMessage hWnd, BM_CLICK, 0, 0
End If
End Sub
Private Sub Save_As_Set_Filename(folder As String, filename As String)
'Populate the 'File name:' edit window in the Save As dialogue with the specified folder and/or filename.
'If folder = "" a folder path is not prepended to the filename and therefore the default save folder is used.
'If filename = "" the default file name (already populated) is used.
'The Save As window has the following child window hierarchy:
' "Save As", #32770 Dialog
' "FileName", ComboBoxEx32 (FileName is the default File name value in combobox)
' "", ComboBox
' "FileName", Edit (FileName is the default File name value in combobox's edit box)
Dim hWnd As Long
Dim timeout As Date
Dim fullFilename As String
Debug.Print "Save_As_Set_Filename"
Debug.Print "folder = " & folder
Debug.Print "filename = " & filename
'Find the Save As window, waiting a maximum of 10 seconds for it to appear
timeout = Now + TimeValue("00:00:10")
Do
hWnd = FindWindow("#32770", "Save As")
DoEvents
Sleep 200
Loop Until hWnd Or Now > timeout
If hWnd Then
SetForegroundWindow hWnd
'Find the child ComboBoxEx32 window
hWnd = FindWindowEx(hWnd, 0, "ComboBoxEx32", vbNullString)
Debug.Print " ComboBoxEx32 "; Hex(hWnd)
End If
If hWnd Then
'Find the child ComboBox window
hWnd = FindWindowEx(hWnd, 0, "ComboBox", "")
Debug.Print " ComboBox "; Hex(hWnd)
End If
If hWnd Then
SetForegroundWindow hWnd
'Find the child Edit window
hWnd = FindWindowEx(hWnd, 0, "Edit", "")
Debug.Print " Edit "; Hex(hWnd)
End If
If hWnd Then
If filename = "" Then
'Get default filename (already populated in Edit window)
filename = Get_Window_Text(hWnd)
End If
'If specified, ensure folder ends with \
If folder <> "" And Right(folder, 1) <> "\" Then folder = folder & "\"
fullFilename = folder & filename
Debug.Print "Full filename " & fullFilename
'Populate the Edit window with the full file name
Sleep 200
SetForegroundWindow hWnd
SendMessageByString hWnd, WM_SETTEXT, Len(fullFilename), fullFilename
End If
End Sub
Private Function Get_Window_Text(hWnd As Long) As String
'Returns the text in the specified window
Dim Buffer As String
Dim length As Long
Dim result As Long
SetForegroundWindow hWnd
length = SendMessage(hWnd, WM_GETTEXTLENGTH, 0, 0)
Buffer = Space(length + 1) '+1 for the null terminator
result = SendMessage(hWnd, WM_GETTEXT, Len(Buffer), ByVal Buffer)
Debug.Print "Edit File name = " & Left(Buffer, length)
Debug.Print " length = " & length
Get_Window_Text = Left(Buffer, length)
End Function
Private Function Save_As_Click_Save() As Boolean
'Click the Save button in the Save As dialogue, returning True if the '<file> already exists'
'window appears, otherwise False
Dim hWnd As Long, hWndSaveAs As Long
Dim timeout As Date
Debug.Print "Save_As_Click_Save"
'Find the Save As window, waiting a maximum of 10 seconds for it to appear
timeout = Now + TimeValue("00:00:10")
Do
hWnd = FindWindow(vbNullString, "Save As")
hWndSaveAs = hWnd
DoEvents
Sleep 200
Loop Until hWnd Or Now > timeout
Debug.Print " Save As window "; Hex(hWnd)
If hWnd Then
SetForegroundWindow hWnd
'Get the child Save button
hWnd = FindWindowEx(hWnd, 0, "Button", "&Save")
Debug.Print " Save button "; Hex(hWnd)
End If
If hWnd Then
'Click the Save button
'This can cause the '<file> already exists' popup window to be displayed. The button click is sent with PostMessage
'because SendMessage doesn't return until the window is closed (by clicking Yes or No)
'PostMessage - http://msdn.microsoft.com/en-us/library/ms644944%28v=VS.85%29.aspx
'Places (posts) a message in the message queue associated with the thread that created the specified window and returns
'without waiting for the thread to process the message.
'SendMessage - http://msdn.microsoft.com/en-us/library/ms644950%28VS.85%29.aspx
'The SendMessage function calls the window procedure for the specified window and does not return until the
'window procedure has processed the message.
'SendMessage hWnd, BM_CLICK, 0, 0
Sleep 100
SetForegroundWindow hWnd
PostMessage hWnd, BM_CLICK, 0, 0
Debug.Print " Clicked Save button"
End If
If hWnd Then
'Set function return value depending on whether or not the '<file> already exists' popup window exists
'Note - the popup window is a modal dialogue box and a child of the main Save As window. Both windows have the
'same class (#32770) and caption (Save As). This may present a problem in finding the popup window, however in all tests
'FindWindow has correctly found the popup window. Therefore the additional FindWindowEx, which looks for the Yes button
'as a child of the popup window is not necessary
Sleep 500
hWnd = FindWindow("#32770", "Save As")
'This alternative FindWindowEx call, which looks for the popup window as a child of the main Save As window, doesn't find it,
'returning 0 for hWnd
'hWnd = FindWindowEx(hWndSaveAs, 0, "#32770", "Save As")
Debug.Print " Save As - <file> already exists popup window "; Hex(hWnd)
'hWnd = FindWindowEx(hWnd, 0, "Button", "&Yes")
If hWnd Then
Save_As_Click_Save = True
Else
Save_As_Click_Save = False
End If
End If
End Function
Private Sub File_Already_Exists(Replace As Boolean)
'Click Yes or No in the '<file> already exists. Do you want to replace it?' window
Dim hWnd As Long
Debug.Print "File_Already_Exists("; Replace; ")"
hWnd = FindWindow("#32770", "Save As")
Debug.Print " Save As popup window "; Hex(hWnd)
If hWnd Then
If Replace Then
hWnd = FindWindowEx(hWnd, 0, "Button", "&Yes")
Debug.Print " Yes button "; Hex(hWnd)
Else
hWnd = FindWindowEx(hWnd, 0, "Button", "&No")
Debug.Print " No button "; Hex(hWnd)
End If
End If
If hWnd Then
SendMessage hWnd, BM_CLICK, 0, 0
End If
End Sub
Private Sub Download_complete_Click_Close()
Dim hWnd As Long
Dim timeout As Date
Debug.Print "Download_complete_Click_Close"
'Find the Download complete window, waiting a maximum of 30 seconds for it to appear. Timeout value is
'dependent on the size of the download, so make it longer for larger files.
timeout = Now + TimeValue("00:00:30")
Do
hWnd = FindWindow("#32770", "Download complete")
DoEvents
Sleep 200
Loop Until hWnd Or Now > timeout
Debug.Print " Download complete window "; Hex(hWnd)
If hWnd Then
'Find the child Close button
hWnd = FindWindowEx(hWnd, 0, "Button", "Close")
Debug.Print " Close button "; Hex(hWnd)
End If
If hWnd Then
'Click the Close button
SetForegroundWindow hWnd
Sleep 600 'this sleep is required and 600 milliseconds seems to be the minimum that works
SendMessage hWnd, BM_CLICK, 0, 0
End If
End Sub
Private Function Get_IE_Window() As Object
'Look for an IE browser window and, if found, return that browser as an InternetExplorer object. Otherwise return Nothing
Dim Shell As Object
Dim IE As Object
Dim i As Variant 'Integer
Set Shell = CreateObject("Shell.Application")
i = 0
Set Get_IE_Window = Nothing
While i < Shell.Windows.Count And Get_IE_Window Is Nothing
Set IE = Shell.Windows.Item(i)
If Not IE Is Nothing Then
If TypeName(IE.Document) = "HTMLDocument" Then
Set Get_IE_Window = IE
'Activate this tab (the first tab) by pressing Ctrl+1
SetForegroundWindow Get_IE_Window.hWnd
PressKeys VK_CONTROL, Asc("1")
End If
End If
i = i + 1
Wend
End Function
Private Sub PressKeys(vKey1 As Long, vKey2 As Long)
KeyEvent vKey1, True, False 'key1 down
Sleep 10
KeyEvent vKey2, True, True 'key2 down and up
Sleep 10
KeyEvent vKey1, False, True 'key1 up
End Sub
Private Sub KeyEvent(ByVal vKey As Long, ByVal keyDown As Boolean, ByVal keyUp As Boolean)
If keyDown Then keybd_event vKey, 0, VK_KEYDOWN, -11
If keyUp Then keybd_event vKey, 0, VK_KEYUP, -11
End Sub
'---------- Testing and debugging ---------
Private Sub Test_Save_As_Set_Filename()
'Set the folder and filename in the Save As window. The Save As window must be already displayed
Dim folder As String, filename As String
folder = "" 'use IE's default download folder
filename = "test " & Format(Now, "hh_mm_ss") & ".xls"
Save_As_Set_Filename folder, filename
End Sub
Private Sub Test_Save_As_Click_Save()
'Click Save in the Save As window and replace file if it already exists. The Save As window must be already displayed
Dim fileExists As Boolean
fileExists = Save_As_Click_Save
If fileExists Then
File_Already_Exists True
End If
Download_complete_Click_Close
End Sub
