Rajkumar_h
New Member
- Joined
- Oct 4, 2013
- Messages
- 20
Hello,
This is the first time am trying out web scraping using VBA. with the help of WiseOwl blog i was able to write the below and am successful till macro clicks to download the file.
I would required help for two things:
Below is the entire code for your reference:
Required an experts help to resolve this.
Waiting for reply from an expert soon.
Thanks in advance,
Raj Gerard
This is the first time am trying out web scraping using VBA. with the help of WiseOwl blog i was able to write the below and am successful till macro clicks to download the file.
I would required help for two things:
- Mainly for downloading the XLS file where i presume we need to use API functionality. I have no experience in it. Collected some information on API from Mr.Excel forum (https://www.mrexcel.com/forum/excel...ng-ie-automation-using-vba-3.html#post2805320), tried it but not getting the result.
- Secondly when the loop completes and starts a new loop I am getting a Webpage not found error. and
- Thirdly if you could help me out with dynamic Shellwin.counts.
Below is the entire code for your reference:
Code:
Option Explicit
Public Declare Sub Sleep Lib "kernel32" _
(ByVal dwMilliseconds As Long)
Public Declare Function FindWindow Lib "user32" Alias "FindWindowA" _
(ByVal lpClassName As String, ByVal lpWindowName As String) As Long
Public Declare Function FindWindowEx Lib "user32" Alias "FindWindowExA" _
(ByVal hWnd1 As Long, ByVal hWnd2 As Long, ByVal lpsz1 As String, ByVal lpsz2 As String) As Long
Public Declare Function SetForegroundWindow Lib "user32" _
(ByVal hWnd As Long) As Long
Public Declare Function SendMessage Lib "user32" Alias "SendMessageA" _
(ByVal hWnd As Long, ByVal wMsg As Long, ByVal wParam As Long, lParam As Any) As Long
Public Declare Function SendMessageByString Lib "user32" Alias "SendMessageA" _
(ByVal hWnd As Long, ByVal wMsg As Long, ByVal wParam As Long, ByVal lParam As String) As Long
Public Const BM_CLICK = &HF5
Public Const WM_SETTEXT = &HC
Public Const WM_GETTEXT = &HD
Public Const WM_GETTEXTLENGTH = &HE
'=============================================================================================
Public Const baseURL As String = "http://wasbprbvl.corp.kjhasfdjhf-jlkahsfdlh.com/asfdsafdsaf/main.do"""
[URL=https://www.mrexcel.com/forum/usertag.php?do=list&action=hash&hash=If]#If[/URL] VBA7 Then
Private Declare PtrSafe Function URLDownloadToFile Lib "urlmon" Alias "URLDownloadToFileA" ( _
ByVal pCaller As LongPtr, _
ByVal szURL As String, _
ByVal szFileName As String, _
ByVal dwReserved As LongPtr, _
ByVal IpfnCB As LongPtr) As LongPtr
[URL=https://www.mrexcel.com/forum/usertag.php?do=list&action=hash&hash=Else]#Else[/URL]
Private Declare PtrSafe Function URLDownloadToFile Lib "urlmon" Alias "URLDownloadToFileA" ( _
ByVal pCaller As Long, _
ByVal szURL As String, _
ByVal szFileName As String, _
ByVal dwReserved As Long, _
ByVal IpfnCB As Long) As Long
[URL=https://www.mrexcel.com/forum/usertag.php?do=list&action=hash&hash=End]#End[/URL] If
Sub Browse()
Dim IE As SHDocVw.InternetExplorer
'Dim IE As InternetExplorer
Dim ie2 As SHDocVw.InternetExplorer
Dim HTMLDoc As MSHTML.HTMLDocument
Dim HTMLInputU As MSHTML.IHTMLElement, HTMLInputP As MSHTML.IHTMLElement
Dim HTMLAs As MSHTML.IHTMLElementCollection, HTMLAss As MSHTML.IHTMLElementCollection
Dim HTMLA As MSHTML.IHTMLElement ', HTMLRep As MSHTML.IHTMLElement
Dim HTMLTable As MSHTML.IHTMLTable
Dim Report As Variant
Dim cell As Range, x As Variant
Dim DestinationFile As Variant
Set ie2 = Nothing
Dim DataRange As Range
Dim MyArr() As Variant
Set DataRange = Range("B2").CurrentRegion
ReDim MyArr(DataRange.Cells.Count)
For Each cell In DataRange.Cells
MyArr(x) = cell.Value
x = x + 1
Next cell
For x = LBound(MyArr) To UBound(MyArr)
Set IE = New SHDocVw.InternetExplorer
DestinationFile = "\\na1.ofc.loc\dfsusa\homedir\afdasfasfd\home\Desktop\Trial" & MyArr(x) & ".xls"
'theFolder = "\\na1.ofc.loc\dfsusa\homedir\afdasfasfd\home\Desktop\Trial"
'theFilename = MyArr(x) & ".xls"
IE.Visible = True
IE.navigate "abweb.corp.kjhasfdjhf-jlkahsfdlh.com/dss/scripts/warehousing.asp"
Do While IE.readyState <> READYSTATE_COMPLETE
Loop
Set HTMLDoc = IE.document
Set HTMLAs = HTMLDoc.getElementsByTagName("a")
For Each HTMLA In HTMLAs
Debug.Print HTMLA.getAttribute("href"), HTMLA.innerText
If HTMLA.innerText = MyArr(x) Then
HTMLA.Click
Application.Wait Now + TimeValue("00:00:3")
IE.navigate "wasbprbvl.corp.kjhasfdjhf-jlkahsfdlh.com/asfdsafdsaf/Login"
Do While IE.readyState <> READYSTATE_COMPLETE
Loop
IE.document.forms("Login").elements("j_username").Value = "Y921304"
IE.document.forms("Login").elements("j_password").Value = "India@2020"
Set tagNames = HTMLDoc.getElementsByTagName("INPUT")
i = 0
While i < tagNames.length
If tagNames(i).Type = "submit" And tagNames(i).Value = "Submit" Then
Set objelement = tagNames(i)
objelement.Click
Application.Wait Now + TimeValue("00:00:05")
GoTo clickCode
End If
i = i + 1
Wend
clickCode:
Set ie2 = New SHDocVw.InternetExplorer
Dim shellWins As ShellWindows
Set shellWins = New ShellWindows
If shellWins.Count > 0 Then
Set ie2 = shellWins.Item(3)
End If
Set HTMLDocs = ie2.document
Set HTMLAss = HTMLDocs.getElementsByTagName("a")
For Each HTMLAA In HTMLAss
If HTMLAA.innerText = "Reports" Then
HTMLAA.Click
GoTo NextReport
End If
Next
NextReport:
Set shellWins = New ShellWindows
If shellWins.Count > 0 Then
Set ie2 = shellWins.Item(3)
End If
Set HTMLDocs = ie2.document
Set HTMLAss = HTMLDocs.getElementsByTagName("a")
For Each HTMLAA In HTMLAss
If HTMLAA.innerText = "Shipment Reports" Then
HTMLAA.Click
GoTo shipmentReport
End If
Next
shipmentReport:
'Application.Wait Now + TimeValue("00:00:03")
Set shellWins = New ShellWindows
If shellWins.Count > 0 Then
Set ie2 = shellWins.Item(3)
End If
Set HTMLDocs = ie2.document
Set HTMLAss = HTMLDocs.getElementsByTagName("a")
For Each HTMLAA In HTMLAss
If HTMLAA.innerText = "Inbound Shipment Report" Then
HTMLAA.Click
GoTo InboundShip
End If
Next
InboundShip:
Set shellWins = New ShellWindows
If shellWins.Count > 0 Then
Set ie2 = shellWins.Item(3)
End If
Set HTMLDocs = ie2.document
With ie2.document
.forms("foInboundShipmentPrompt").getElementsByTagName("Select")("lstShipmentType").Value = "5"
.forms("foInboundShipmentPrompt").getElementsByTagName("Select")("lstSelectByDate").Value = "1"
.getElementsByName("txtStartDate")(0).Value = Format(Range("E2"), "Short Date")
.getElementsByName("txtEndDate")(0).Value = Format(Range("E3"), "Short Date")
End With
Set taggNames = ie2.document.getElementsByTagName("INPUT")
i = 0
While i < taggNames.length
If taggNames(i).Name = "cmdGenerateXLS" And taggNames(i).Value = "Generate XLS" Then
Set objelement = taggNames(i)
objelement.Click
Application.Wait Now + TimeValue("00:00:10")
GoTo NextCode
End If
i = i + 1
Wend
NextCode:
'Click Save as button to save the file in system
' Report = Application.GetSaveAsFilename("Inbound Shipment Report_Report_2019FEB08_0304.xls", "Excel Files (*.xls), *.xls")
If URLDownloadToFile(0, "http://wasbprbvl.corp.kjhasfdjhf-jlkahsfdlh.com/asfdsafdsaf/welcomeFiles/index.jsp?device_type=DT", DestinationFile, 0, 0) = 0 Then
Debug.Print "File Download Started", URLDownloadToFile(0, "http://wasbprbvl.corp.kjhasfdjhf-jlkahsfdlh.com/asfdsafdsaf/main.do", DestinationFile, 0, 0)
' Application.SendKeys "%{O}"
Else
Debug.Print "File Download not Started"
End If
File_Download_Click_Save
Save_As_Set_Filename "\\na1.ofc.loc\dfsusa\homedir\afdasfasfd\home\Desktop\Trial", MyArr(x) & ".xls"
Save_As_Click_Save
Download_complete_Click_Close
Debug.Print "Finished"
GoTo Loopnext
End If
Next HTMLA
'close the IE session
Loopnext:
IE.Quit
ie2.Quit
Set IE = Nothing
Set ie2 = Nothing
Next x
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:10")
Do
hWnd = FindWindow("[URL=https://www.mrexcel.com/forum/usertag.php?do=list&action=hash&hash=32770]#32770[/URL] ", "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 = "\\na1.ofc.loc\dfsusa\homedir\afdasfasfd\home\Desktop\Trial"
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", [URL=https://www.mrexcel.com/forum/usertag.php?do=list&action=hash&hash=32770]#32770[/URL] 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("[URL=https://www.mrexcel.com/forum/usertag.php?do=list&action=hash&hash=32770]#32770[/URL] ", "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("[URL=https://www.mrexcel.com/forum/usertag.php?do=list&action=hash&hash=32770]#32770[/URL] ", "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
Required an experts help to resolve this.
Waiting for reply from an expert soon.
Thanks in advance,
Raj Gerard