'10-Nov-2010
'http://www.mrexcel.com/forum/showthread.php?t=507871
'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.remotedatacentre.com
'to IE's Trusted sites (Tools - Internet Options - Security - Trusted sites - Sites).
Option Explicit
Public Const baseURL As String = "http://www.remotedatacentre.com/co-so/cbstateall.aspx?dist=Chennai-North"
Public Sub Test_Download()
Dim URL As String
'Construct complete URL from the base URL and the dates parameter (mm/d/yyyy format)
'Example fixed date
URL = baseURL & "&dates=11/9/2010"
'Today's date
'URL = baseURL & "&dates=" & Format(Date, "mm/d/yyyy")
Download_File URL, "", ""
End Sub
Public Sub Download_File(URL As String, saveInFolder As String, saveFilename As String)
Dim IE As Object
Set IE = Get_IE_Window_LB(URL)
If IE Is Nothing Then
Set IE = CreateObject("InternetExplorer.Application")
End If
With IE
.Visible = True
.Navigate URL
While .busy Or .ReadyState <> 4: DoEvents: Wend
'Click the 'Export To Excel' button
'< input type="submit" name="ctl00$ContentPlaceHolder1$ExportToExcel1" value="Export To Excel"
'id="ctl00_ContentPlaceHolder1_ExportToExcel1" />
.Document.all("ctl00_ContentPlaceHolder1_ExportToExcel1").Click
End With
File_Download_Click_Save
Save_As_Set_Filename saveInFolder, saveFilename
Save_As_Click_Save
Download_complete_Click_Close
Debug.Print "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 miiliseconds seems to be the minimum that works
SendMessage hWnd, BM_CLICK, 0, 0
End If
End Sub
Private Sub Test_Save_As_Set_Filename()
'Test setting the Save As filename. The Save As window must be displayed before running this
Dim theFolder As String, theFilename As String
theFolder = "C:\temp\Excel\"
theFilename = "test " & Format(Now, "hh_mm_ss") & ".xls"
Save_As_Set_Filename theFolder, theFilename
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 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
' "FileName2011_11_11_11_00_26", ComboBoxEx32 (default value in combobox)
' "", ComboBox
' "FileName2011_11_11_11_00_26"", Edit (default value in combobox's edit box)
Dim hWnd As Long
Dim timeout As Date
Dim fullFilename As String
Debug.Print "Save_As_Set_Filename " & folder
'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 folder <> "" And Right(folder, 1) <> "\" Then folder = folder & "\" 'if specified, ensure folder ends with \
fullFilename = folder & filename
Debug.Print "Full filename " & fullFilename
'Populate the Edit window with the full file name
Sleep 200
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
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 Sub Save_As_Click_Save()
'Click the Save button in the Save As dialogue
Dim hWnd 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")
DoEvents
Sleep 200
Loop Until hWnd Or Now > timeout
If hWnd Then
SetForegroundWindow (hWnd)
'Get the child Save button
hWnd = FindWindowEx(hWnd, 0, "Button", "&Save")
Debug.Print " Save button "; hWnd
End If
If hWnd Then
'Click the Save button
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 bigger 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 miiliseconds seems to be the minimum that works
SendMessage hWnd, BM_CLICK, 0, 0
End If
End Sub
Public Function Get_IE_Window_LB(sUrl As String, Optional sProtocol As String = "http") As Object
'Look for an IE window or tab already open at the specified URL (excluding sub paths) and, if found, return that browser
'as an InternetExplorer object. Otherwise return Nothing
Dim sDomain As String
Dim Shell As Object
Dim IE As Object
Dim i As Variant 'Integer
If Left(sUrl, Len(sProtocol)) <> sProtocol Then sUrl = sProtocol & sUrl
sDomain = Left(sUrl, InStr(Len(sProtocol) + 1, sUrl, "/"))
Set Shell = CreateObject("Shell.Application")
i = 0
Set Get_IE_Window_LB = Nothing
While i < Shell.Windows.Count And Get_IE_Window_LB Is Nothing
Set IE = Shell.Windows.Item(i)
If Not IE Is Nothing Then
If TypeName(IE.Document) = "HTMLDocument" Then
If InStr(IE.LocationURL, sDomain) > 0 Then
Set Get_IE_Window_LB = IE
End If
End If
End If
i = i + 1
Wend
End Function
