VBA Excel Login auf Webseite und Download und Save

Option Explicit
Private Sub Workbook_Open()
Dim IEApp As InternetExplorer
Dim ieDoc As Object
Dim ieTable As Object
Dim sSource, sTable As String
Dim saveInFolder As String, saveAsFilename As String
Dim dlWb As Workbook
'create a new instance of ie
Set IEApp = New InternetExplorer
IEApp.Visible = True
'assume we?re not logged in and just go directly to the login page
IEApp.Navigate "https://login.test.de/"
Do While IEApp.Busy: DoEvents: Loop
Do Until IEApp.ReadyState = READYSTATE_COMPLETE: DoEvents: Loop
Set ieDoc = IEApp.Document
'fill in the login form ? View Source from your browser to get the control names
With ieDoc.forms(0)
.partnernummer.Value = "XXXXX"
.kennwort.Value = "YYYYYY"
.submit
End With
Do While IEApp.Busy: DoEvents: Loop
Do Until IEApp.ReadyState = READYSTATE_COMPLETE: DoEvents: Loop
IEApp.Navigate "https://partnerlogin.test/download.php?datom_von=01.01.2018&datum_bis=31.12. _
2019"
Do While IEApp.Busy: DoEvents: Loop
Do Until IEApp.ReadyState = READYSTATE_COMPLETE: DoEvents: Loop
saveInFolder = "C:\Users\name\Desktop\Test2"
saveAsFilename = "Downloaded Excel data.xls"
Download_File saveInFolder, saveAsFilename
Set dlWb = Workbooks.Open(saveInFolder & saveAsFilename)
'Here, copy data from downloaded workbook to destination workbook
dlWb.Close False
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 ' 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 ' 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 ' 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 ' 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 -  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 ' 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 

Option Explicit
Public Declare PtrSafe Sub Sleep Lib "kernel32" _
(ByVal dwMilliseconds As LongPtr)
Public Declare PtrSafe Function FindWindow Lib "USER32" Alias "FindWindowA" _
(ByVal lpClassName As String, ByVal lpWindowName As String) As LongPtr
Private 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 SetForegroundWindow Lib "USER32" _
(ByVal hwnd As LongPtr) As Long
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
Public Declare PtrSafe Function SendMessageByString Lib "USER32" Alias "SendMessageA" _
(ByVal hwnd As LongPtr, ByVal wMsg As Long, ByVal wParam As LongPtr, ByVal lParam As String) _
_
As LongPtr
Private Declare PtrSafe Function PostMessage Lib "USER32" Alias "PostMessageA" _
(ByVal hwnd As LongPtr, ByVal wMsg As Long, ByVal wParam As LongPtr, ByVal lParam As  _
LongPtr) As Long
Public Declare PtrSafe Sub keybd_event Lib "USER32" _
(ByVal bVk As Byte, ByVal bScan As Byte, ByVal dwFlags As LongPtr, ByVal dwExtraInfo As  _
LongPtr)
Public Const BM_CLICK = &HF5
Public Const WM_SETTEXT = &HC
Public Const WM_GETTEXT = &HD
Public Const WM_GETTEXTLENGTH = &HE
Public Const VK_KEYDOWN = &H0
Public Const VK_KEYUP = &H2
Public Const VK_CONTROL = &H11