I have 40 links imported in an excel sheet. Each link, when clicked, will lead to (Print as file) window for the page.
Is there anyway to open the multiple links and save the page as PDF with specific format (Year_Month_date) with one click ?
Create PDF-File with Timestamp
this should work for you! you can delete "hhmmss" for only Year_Month_Day !
Sub PDFCreate()
Sheets("Tabelle1").PageSetup.Orientation = 1 ' 1=portrait, 2=landscape
With Sheets("Tabelle1")
.PageSetup.PrintArea = "$A$1:$I$21"
.ExportAsFixedFormat xlTypePDF, "C:\Users\username\Documents\foldername\" & Format(Now, "yyyymmdd hhmmss") & "pdfname.pdf", , , False
End With
End Sub
Print and Open Webpage from VBA Code
Sub print_PDF()
Dim Explorer As Object
Dim eQuery As Long ' return value
Dim i As Integer
Dim fTime As Single
Set Explorer = CreateObject("InternetExplorer.Application") ' Connect to Explorer
Dim url As String
url = ThisWorkbook.ActiveSheet.Range("A1").Value
Explorer.Navigate url ' Open document from local or web!
TryAgain:
'Wait 2 seconds to let IE load
fTime = Timer
Do While fTime > Timer - 2
DoEvents
Loop
eQuery = Explorer.QueryStatusWB(6) ' print command
If eQuery And 2 Then
Explorer.ExecWB 6, 2, "", "" ' Print (6), displaying dialog (2)
'Wait for 2 seconds while IE prints
fTime = Timer
Do While fTime > Timer - 2
DoEvents
Loop
Else
GoTo TryAgain
End If
End Sub
UPDATE: Added Insert Option
u are able to insert link into input dialog, it automatically changes link in Sub pdf_Print()
Sub Insert()
Dim myValue As Variant
myValue = InputBox("Need Input")
Range("A1").Value = myValue
End Sub
Related
Through a sub i download an excel file from a website. when the download button is clicked, it both opens the excel file and also let the file get downloaded. i dont need it to get opened so as soon as it gets opened and before srart of next subs, i need to close it. By some codes i tried to do it but I failed.
The problem is that the Do Loop i wrote, can not catch the file and hangs.
It just works well when i debug it through F8. Then i thought maybe by application.wait method I can let the sub to wait till the workbook appears, like what happens in debug mode but it didnt help as well.
Also i need to add that since everytime the file gets downloaded its name changes by the webiste then i used Like operator.
Sub Test()
Dim wb As Workbook
Dim wbName As String
Dim Cnt As Integer
wbName = "transactions_history_"
'Application.Wait Now + TimeValue("00:00:10") ' it didnt help so i commented it
Do
Application.Wait Now + TimeValue("00:00:01")
For Each wb In Application.Workbooks
If wb.Name Like wbName & "*" Then
Cnt = 1
Exit Do
End If
Next wb
Loop Until Cnt = 1
wb.Close
End Sub
Anybody has any idea? thanks.
FaneDuru,
I copy here the code which downloads the workbook from the website. it worked very well until the website changed something and when the file gets downloaded it gets opened too. I need to close it to let the rest of the programms work without problem but i coudlnt manage it so far.
Sub TBC()
' declerations
Dim myBrowser As Selenium.ChromeDriver
Dim FindBy As New Selenium.by
Dim objFSO As Object
Dim objFolder As Object
Dim objFile As Object
Dim A, I As Integer
Dim FileName, BankFolderAddress As String
Dim N As Byte
' initializations
BankFolderAddress = "D:\Projects\Excel\Main Program\Bank Statements\"
Set FindBy = New Selenium.by
Set myBrowser = New WebDriver
I = 0
A = 0
Sheet2.Cells.ClearContents
Set objFSO = CreateObject("Scripting.FileSystemObject")
Set objFolder = objFSO.GetFolder(BankFolderAddress)
For Each objFile In objFolder.Files
Sheet2.Cells(I + 1, 1) = objFile.Name
Sheet2.Cells(I + 1, 2) = objFile.Path
I = I + 1
Next objFile
If Sheet2.Cells(1, 1) <> "" Then
For N = 1 To I
Kill Sheet2.Cells(N, 2).value
Next N
End If
Start:
myBrowser.SetProfile Environ("LOCALAPPDATA") & "\GOOGLE\CHROME\USER DATA"
myBrowser.AddArgument "profile-directory=Default"
myBrowser.Start "chrome"
Application.DisplayAlerts = False
'Address e website
myBrowser.Get "https://tbconline.ge/tbcrd/login?t=false"
myBrowser.Window.Maximize
A = 0
Do
Application.Wait Now + TimeValue("00:00:01")
A = A + 1
If A = 10 Then GoTo Finish
Loop Until myBrowser.IsElementPresent(FindBy.XPath("//button"))
If myBrowser.IsElementPresent(FindBy.Css("input[formcontrolname='username']")) Then
myBrowser.FindElementByXPath("//button").Click
Else
GoTo JMP
End If
JMP:
'For removing PopUps
If myBrowser.IsElementPresent(FindBy.XPath("//div[#id='mainLoadingLayer']/ui-view/ui-view/div/div[2]/div/div/div/div/div[3]/button")) Then
myBrowser.FindElementByXPath("//div[#id='mainLoadingLayer']/ui-view/ui-view/div/div[2]/div/div/div/div/div[3]/button").Click
End If
' Choosing Transaction Menu
A = 0
Do
Application.Wait Now + TimeValue("00:00:01")
A = A + 1
If A = 10 Then GoTo Finish
Loop Until myBrowser.IsElementPresent(FindBy.XPath("//a[contains(text(),'Transactions')]"))
If myBrowser.IsElementPresent(FindBy.XPath("//a[contains(text(),'Transactions')]")) Then
myBrowser.FindElementByXPath("//a[contains(text(),'Transactions')]").Click
End If
'choosing Transaction submenu
A = 0
Do
Application.Wait Now + TimeValue("00:00:01")
A = A + 1
If A = 10 Then GoTo Finish
Loop Until myBrowser.IsElementPresent(FindBy.XPath("//span[contains(.,'Transactions')]"))
If myBrowser.IsElementPresent(FindBy.XPath("//span[contains(.,'Transactions')]")) Then
myBrowser.FindElementByXPath("//span[contains(.,'Transactions')]").Click
End If
'Clicking on Download icon
Do
Application.Wait Now + TimeValue("00:00:01")
Loop Until myBrowser.IsElementPresent(FindBy.XPath("//ib-controls/div/div[2]/div[2]"))
If myBrowser.IsElementPresent(FindBy.XPath("//ib-controls/div/div[2]/div[2]")) Then
myBrowser.FindElementByXPath("//ib-controls/div/div[2]/div[2]").Click
End If
' clicking on excel option to download it
Do
Application.Wait Now + TimeValue("00:00:01")
Loop Until myBrowser.IsElementPresent(FindBy.XPath("//a[contains(.,'Excel')]"))
If myBrowser.IsElementPresent(FindBy.XPath("//a[contains(.,'Excel')]")) Then
myBrowser.FindElementByXPath("//a[contains(.,'Excel')]").Click
End If
'checking if the file is downloaded
Do
Application.Wait Now + TimeValue("00:00:02")
Loop Until Dir(BankFolderAddress & "transactions_history_*.xlsx") <> ""
' get the file name
FileName = Dir(BankFolderAddress & "transactions_history_*.xlsx", vbDirectory)
' check if the downloaded file size
Do
Application.Wait Now + TimeValue("00:00:05") '03 bood
Loop Until FileLen(BankFolderAddress & FileName) > 10000
Finish:
' close the Browser
myBrowser.close
' ## I added this code to close the workbook but failed
' call Test()
Dim wb As Workbook
Dim wbName As String
Dim Cnt As Integer
wbName = FileName
Do
Application.Wait Now + TimeValue("00:00:01")
For Each wb In Application.Workbooks
If wb.Name=FileName Then
Cnt = 1
wb.Close
Exit Do
End If
Next wb
Loop Until Cnt = 1
call BankDataExtraction()
End Sub
the problem is that if i do not stop the sub before the loop in debug mode, the downloaded workbook neither appears on the screen nor in task manager, and the loop can not catch it and close it, it hangs then. wait methode doesnt help too. I tried you code but it gave me automation error invalid syntax, while executing Set sessEx = GetObject(wbFullName).Application
I passed the complete file address to it, If Not sameExSession(FileName).
If you are sure that the wbName is the name of the workbook searching for, your code must do what you need, but only if the workbook in discussion is open IN THE SAME EXCEL SESSION. I asked about the code opening it, but no clarification received. Please, use the next function to check if the workbook is open in the same session (with the workbook keeping the checking code). If its second parameter is True, it closes the workbook, even in a different session and quit that session. Many codes searches for an existing Excel session and use it, but open a new session if no such a session has been found. Others, uses a new session:
Function sameExSession(wbFullName As String, Optional boolClose As Boolean) As Boolean
Dim sessEx As Excel.Application, wb As Workbook
Set sessEx = GetObject(wbFullName).Application
If sessEx.hwnd = Application.hwnd Then
sameExSession = True
Else
sameExSession = False
If boolClose Then
sessEx.Workbooks(Right(wbFullName, Len(wbFullName) - InStrRev(wbFullName, "\"))).Close False
sessEx.Quit: Set sessEx = Nothing
End If
End If
End Function
It can be called from your existing code in this way:
Sub Test()
Dim wb As Workbook, wbName As String, Cnt As Integer
wbName = "transactions_history_"
If Not sameExSession Then Exit Sub 'take care to use the workbook FULL NAME!
Do
Application.Wait Now + TimeValue("00:00:01")
For Each wb In Application.Workbooks
If wb.Name Like wbName & "*" Then
Cnt = 1
Exit Do
End If
Next wb
Loop Until Cnt = 1
wb.Close
End Sub
If you do not know the workbook extension (since you do not use it in your above code), you can obtain the workbook name using:
Dim strFullName As String, foldName As String
foldName = "path to the folder where the workbook is downloaded"
strFullName = dir(foldName & "\" & vbname & "*.*")
If strFullName <> "" Then
If Not sameExSession Then Exit Sub
Else
MsgBox "Strange...": Stop 'Just in case. It must be found, if foldName and vbName are correct...
End If
It may fail if in the same folder there are more then one such a workbook having a name containing the used string. It will return the first of them, in alphabetical order. But, if such a case, you are the one who is needed to bring some clarifications... Of course, if opening in the other session is the correct assumption. In such a case a piece of code can iterate between all those workbooks having the same string in their name, to determine the last saved one.
You can be sure about this aspect (other session), manually searching for the workbook, copying its Full name and create a testing Sub which only calls the function I supplied, using the determined its full name.
Can anyone figure out what I am doing wrong?
When I try to submit data to an online MS Form the submission fails upon clicking the submit button because the data in the input text box disappears.
The code I am using:
Sub Hello()
Dim objIE As Object
Dim URL As String
Dim doc As HTMLDocument
Dim oServ As Object
Dim cProc As Variant
Dim oProc As Object
URL = "https://forms.office.com/Pages/ResponsePage.aspx?id=1tUOxOPgeU2DDHmR8zp8jnPOq1Zxq2ZMgF9BFdtxEI9UNTJUSlpaNVU3S0pYRDI0MzE3UkZZQzdZNi4u"
Set objIE = CreateObject("InternetExplorer.Application")
objIE.Visible = True
objIE.navigate URL
Do While objIE.Busy = True Or objIE.readyState <> 4: DoEvents: Loop
Set doc = objIE.document
Set oServ = GetObject("winmgmts:")
Set cProc = oServ.ExecQuery("Select * from Win32_Process")
Dim input_text As String
input_text = "Hello!"
doc.getElementsByTagName("input")(0).Value = input_text
doc.getElementsByTagName("input")(0).setAttribute("value") = input_text
'Let us wait 5 secconds to see if the text was entered into the textbox
Application.Wait (Now() + TimeValue("00:00:05"))
doc.getElementsByTagName("button")(2).Click
'Let us wait 10 secconds to see the results before terminating IE
Application.Wait (Now() + TimeValue("00:00:10"))
Set objIE = Nothing
For Each oProc In cProc
If oProc.Name = "iexplore.exe" Then
'MsgBox "KILL" ' used to display a message for testing pur
oProc.Terminate 'kill exe
End If
Next
End Sub
I wouldn't recommend using IE for automating VBA form submission.
Here's my experience: You spend a lot of time trying to solve this kind of 'what happened the click was supposed to work' errors. Or why did the page not load all the way errors? or how do I wait for the page to load and click what it needs.
TBS: having spent too much time trying to make this sort of thing work, and oftentimes getting a good result. I'd suggest using your DevTools (f12 in IE) while on the page. First click the button normally and see what happens. Next Click the button using JavaScript run in the console section. It'll be something very similar to your click syntax. Take note of what element is actually being clicked by using the inspector in dev tools and what script is running with the event.
IE does have ways to run the exact javascript on the page, you might need to replicate the form click event and javascript using this syntax:
Call IE.document.parentWindow.execScript("document.all.myElement.focus();buttonMovimenti();", "JavaScript")
Source
I've had a lot better success using execScript to trigger OnClick(); events on the page / parentwindow. Just keep in mind iFrames can be a pain to figure out which document you're selecting so be sure to inspect the source to see if there's multiple html documents on the test page.
Alternatively you could attempt to use HTTP post / get methods to submit the form with VBA's MSXML2.XMLHTTP request object, and replicating the headers / form submission that you see in DevTools under Network tab when you click the button. This would take the timing of the page loads out of the equation, and make a more streamlined submission.
EDIT EXAMPLES:
Here's the sub I used to use for this purpose of executing scripts.
Test the script in the console of IE first. In your comment you're referencing the entire minimized JS library. What you want to do is find the function from the window that does the form submission.
Public Sub RunScriptZ(IeObjectDoc As Object, sJavaScript As String)
'run any java script on a page
Dim CurrentWindow As HTMLWindowProxy
Set CurrentWindow = IeObjectDoc.parentWindow
Call CurrentWindow.execScript(sJavaScript)
End Sub
Usually a form is submitted with a basic function like 'submitForm()'. So open DevTools with the page open, then go to Console, and type Document.submitForm(); in the console, and see what happens. Hopefully the form submits with this. Then you could something like:
Call RunScriptZ(objie.Document, "submitForm()")
If this doesn't work, sometimes a site needs you to click / hover to submit the form. You can try these variations alone or combined to see if it replicates on the web page.
Idea 1, Fire Event Method
Dim ieo As New SHDocVw.InternetExplorerMedium
Set ieoDoc = ieo.Document
ieoDoc.getElementById("buttonId").FireEvent ("Onclick")
Idea 2: Basic Exec Script
Dim ieo As New SHDocVw.InternetExplorerMedium
Set ieoDoc = ieo.Document
Dim CurrentWindow As HTMLWindowProxy
Set CurrentWindow = ieoDoc.parentWindow
Call CurrentWindow.execScript("submitForm()") ''or whatever the JS function
'name is that runs in console and triggers the event
Idea 3: test the button to see if it's clickable. sometimes web forms filled out with programming, dont register as filled in, especially if you're just assigning values. I know a lot of forms i dealt with used to require a click event on the input in order to register that a change had occurred, so check the submit button to make sure it's even clickable with this code:
Public Function TestLinkClick(linkelement As HTMLButtonElement, ForceClick
As Boolean) As Boolean
If ForceClick = True Then GoTo clickawaylabel
If IsNull(linkelement.OnClick) = False Then
clickawaylabel:
TestLinkClick = True
Debug.Print "the link is clickable"
Else 'the linkelement is not clickable
TestLinkClick = False
Debug.Print "the link is not clickable"
End If
End Function
Idea 4: Fill in a box
Public Sub FillInBox(TextValue As String, BoxName As String, IECVdoc As Object)
'fill in a box on a html page
Dim tries As Integer
tries = 0
On Error GoTo errorhandler
If tries >= 3 Then GoTo HappyEnd
startAgain:
With IECVdoc
.getElementById(BoxName).Value = TextValue
.getElementById(BoxName).FireEvent ("onchange")
End With
GoTo HappyEnd
errorhandler:
''Call a wait timer I'm using a wait sub: WaitForLoadSETx(IECVdoc, 2, 3)
tries = tries + 1
GoTo startAgain
HappyEnd:
End Sub
Idea 5: Wait for Load
Public Sub WaitForLoadSETx(ieo As Object, Maxtime As Integer, Maxtime2 As Integer)
' Wait for page to load before continuing
Dim sngTime As Single
'Const Maxtime As Integer = 5
'Const Maxtime2 As Integer = 10
sngTime = VBA.Timer ' a snapshot of the timer at the time the subroutine starts
' Wait until the webpage is doing something ... 'READYSTATE_COMPLETE <<< replaced 9/16/13 to click quicker with interactive
Do Until ieo.ReadyState <> READYSTATE_COMPLETE
DoEvents
If VBA.Timer > sngTime + Maxtime And VBA.Left(ieo.statusText, 4) = "Done" Then Exit Sub
If VBA.Timer > sngTime + Maxtime2 And ieo.ReadyState = 4 Or ieo.ReadyState = "complete" Then Exit Sub 'added this to make a real max time 1-12-15 'aded OR complete 1/14/15
' If VBA.Left(IEo.StatusText, 4) = "" Then GoTo outloop
Debug.Print "ONE LOOP Page Loading [" & VBA.Timer & "]/[" & sngTime + Maxtime & "]" & " [" & ieo.ReadyState & "]" & " [" & ieo.statusText & "]" '<<<< added 1/02/14
Loop
'outloop:
' ... and then wait for it to finish 'READYSTATE_INTERACTIVE <<< replaced 9/18/13 to click quicker with interactive
Do Until ieo.ReadyState = READYSTATE_COMPLETE
DoEvents
On Error GoTo 0
' If VBA.Timer > sngTime + Maxtime And VBA.Left(ieo.statusText, 4) = "Done" Then Exit Sub 'removed 1/14/15 because or error 438 not found on .statusText
If VBA.Timer > sngTime + Maxtime2 And ieo.ReadyState = 4 Or ieo.ReadyState = "complete" Then Exit Sub 'added this to make a real max time 1-12-15 'aded OR complete 1/14/15
Debug.Print "TWO LOOP Page Loading [" & VBA.Timer & "]/[" & sngTime + Maxtime & "]" & " [" & ieo.ReadyState & "]" '& " [" & 'ieo.statusText & "]" '<<<< added 1/02/14
Loop
0:
End Sub
Best of luck!
I tried with Sendkeys() and it solved the issue.
You need to replace these lines of code.
doc.getElementsByTagName("input")(0).Value = input_text
doc.getElementsByTagName("input")(0).setAttribute("value") = input_text
with lines of code below.
doc.getElementsByTagName("input")(0).Focus
SendKeys (input_text)
Full modified code:
Sub Hello()
Dim objIE As Object
Dim URL As String
Dim doc As HTMLDocument
Dim oServ As Object
Dim cProc As Variant
Dim oProc As Object
URL = "https://forms.office.com/Pages/ResponsePage.aspx?id=1tUOxOPgeU2DDHmR8zp8jnPOq1Zxq2ZMgF9BFdtxEI9UNTJUSlpaNVU3S0pYRDI0MzE3UkZZQzdZNi4u"
Set objIE = CreateObject("InternetExplorer.Application")
objIE.Visible = True
objIE.navigate URL
Do While objIE.Busy = True Or objIE.readyState <> 4: DoEvents: Loop
Set doc = objIE.document
Set oServ = GetObject("winmgmts:")
Set cProc = oServ.ExecQuery("Select * from Win32_Process")
Dim input_text As String
input_text = "Hello!"
' doc.getElementsByTagName("input")(0).Value = input_text
' doc.getElementsByTagName("input")(0).setAttribute("value") = input_text
doc.getElementsByTagName("input")(0).Focus
SendKeys (input_text)
'Let us wait 5 secconds to see if the text was entered into the textbox
Application.Wait (Now() + TimeValue("00:00:05"))
doc.getElementsByTagName("button")(2).Click
'Let us wait 10 secconds to see the results before terminating IE
Application.Wait (Now() + TimeValue("00:00:10"))
Set objIE = Nothing
For Each oProc In cProc
If oProc.Name = "iexplore.exe" Then
'MsgBox "KILL" ' used to display a message for testing pur
oProc.Terminate 'kill exe
End If
Next
End Sub
Output:
I have a macro which navigates to a series of web pages, downloads an excel from those pages, and then merges the data onto the open workbook. However, my code fails because it cannot find the newly downloaded workbook. When i step through the code, there is no problem. Presumably my code continues to run but as the newly downloaded workbook is not open yet, it fails.
I have tried to create a loop which waits until the downloaded workbook opens, but it seems that the workbook cannot open while the loop is running.
How can I 'wait' within my code until the workbook is open and my code can proceed?
any inputs appreciated, thank you!
appIE.document.getElementById("_id3805:_id3806:0:_id4177").Click 'click website download button
Dim o As IUIAutomation
Dim e As IUIAutomationElement, download_check As IUIAutomationElement
Set o = New CUIAutomation
Dim h As LongLong
h = appIE.Hwnd
h = FindWindowEx(h, 0, "Frame Notification Bar", vbNullString)
If h = 0 Then Exit Sub
Set e = o.ElementFromHandle(ByVal h)
Dim iCnd As IUIAutomationCondition
Set iCnd = o.CreatePropertyCondition(UIA_NamePropertyId, "Open")
Dim Button As IUIAutomationElement
Set Button = e.FindFirst(TreeScope_Subtree, iCnd)
Dim InvokePattern As IUIAutomationInvokePattern
Set InvokePattern = Button.GetCurrentPattern(UIA_InvokePatternId)
InvokePattern.Invoke
Debug.Print "Download Successful, Click OK"
Application.Wait (Now + TimeValue("00:00:02"))
DoEvents
' This part searching active workbook
Dim xWBName As String
Dim GetBook As String
Dim xWb As Workbook
Do Until Application.Workbooks.Count > 1
' 'I am waiting for something to happen
DoEvents
Application.Wait (Now + TimeValue("00:00:01"))
Sleep 1000
Loop
For Each xWb In Application.Workbooks
'xWBName = xWb.Name 'xWBName & xWb.Name & vbCrLf
DoEvents
If InStr(xWb.Name, "Data") Then
GetBook = xWb.Name
End If
Next
DoEvents
'Activate the required workbook
**Set wb2 = Workbooks(GetBook)**
I think your approach with sleep and doEvents is a good way to solve it. Bevore opening the downloaded workbook, check in your sleep loop if it exists, then exit the loop.
If Dir(pathToFile) <> "" Then
'File has been found
end if
EDIT:
I dont see the part where you are trying to open the file.
The order in which things should happen in your case is:
1. Download file
2. Waiting-loop in which you check if the file has been downloaded
3. Open file
the sleep loop could look something like this:
'Download the file here
dim fileFound as boolean
while not fileFound
sleep(1000)
DoEvents
If Dir(pathToFile) <> "" Then
fileFound = true
end if
wend
'Open the file here
I'm working on the Selenium Basic Wrapper for Excel VBA, but upon clicking a button that opens a new tab, I am unable to get the selenium web-driver to switch focus onto the new tab that is opened, and to close the original tab.. Believe this should be achievable using the Java Selenium, but is there any way to do it through the Selenium Basic wrapper on excel VBA?
Have tried using bot.switchtopreviouswindow/nextwindow to no avail, Selenium does not even seem to detect the new tab/window opened as an existing window, also tried using switchwindow using title to no avail...
Private Sub CommandButton1_Click()
Dim bot As New ChromeDriver
Dim merchant As String
Dim promocode As Object
Dim number As Long
Dim test As Object
Dim testnumber As Integer
lastColumn = Sheets("Merchants").Range("B" & Rows.Count).End(xlUp).Row
For i = 2 To lastColumn
bot.Get (Sheets("Merchants").Range("B" & i).Value)
merchant = Sheets("Merchants").Range("A" & i).Value
For Each promocode In bot.FindElementByClass("main_vouchers").FindElementsByClass("c")
number = Right(promocode.Attribute("id"), 6)
If IsEmpty(promocode) = True Then Exit For
promocode.FindElementByClass("go").Click
#This is the part I have problems with as after click, original page re-directs to another page, and new tab opens (which is the place I want focus on). Also, I need the original tab closed so that Chrome doesn't end up opening too many tabs due to the loop running. Appreciate the help!
Next promocode
Next i
End Sub
Just need Selenium to switch focus onto newly opened tab and for old/original tab to be closed..
The following works for me where you use switchToNextWindow and then you take 1 off the current window count (you might want to check more .windows.count > 1 first), and close that item in windows collection.
You can also .SwitchToWindowByName and .SwitchToWindowByTitle if either of those are known in advance | can be extracted from the current page.
'Ensure latest applicable driver e.g. ChromeDriver.exe in Selenium folder
'VBE > Tools > References > Add reference to selenium type library
Public Sub Example()
Dim d As WebDriver
Set d = New ChromeDriver
Const URL = "https://www.cuponation.com.sg/agoda-discount-code"
With d
.get URL
Debug.Print .Window.Title
.FindElementByCss(".go").Click
.SwitchToNextWindow
Debug.Print .URL '<= includes voucher code
'do something with new window
Debug.Print .Window.Title
.Windows.item(.Windows.Count - 1).Close 'close prior window
Debug.Print .Window.Title
Stop
.Quit
End With
End Sub
Sub DownloadFileFromLaquintaca2()
Dim cd As New selenium.ChromeDriver
Dim DefaultChromeDownloadFolder As String
Dim MyURL As String
' Start Chrome
Set cd = New ChromeDriver
cd.Start
' Navigate to
cd.get "https://www.laquintaca.gov/connect/short-term-vacation-rentals"
Const URL = "https://www.cuponation.com.sg/agoda-discount-code"
Dim FindBy As New selenium.By
Dim imgElement As selenium.WebElement
' Check if element is present with CSS
If Not cd.IsElementPresent(FindBy.Css("img[alt='ACTIVE & SUSPENDED PERMITS BOX']")) Then
MsgBox "Could not find image box"
Exit Sub
End If
cd.FindElementByCss("img[alt='ACTIVE & SUSPENDED PERMITS BOX']").Click
Application.Wait (Now + TimeValue("0:00:3"))
'Get URL Address in Second Chorme Tab
With cd
.get URL
.SwitchToNextWindow
MyURL = .URL
'Debug.Print .Window.Title
'Debug.Print myURL
.Windows.Item(.Windows.Count - 1).Close 'close prior window
End With
'Write PDF File into Location with file Name STVR.PDF ---D:\MyDownLoads\STVR.pdf
Dim WinHttpReq As Object
Set WinHttpReq = CreateObject("Microsoft.XMLHTTP")
WinHttpReq.Open "GET", MyURL, False, "username", "password"
WinHttpReq.send
If WinHttpReq.Status = 200 Then
Set oStream = CreateObject("ADODB.Stream")
oStream.Open
oStream.Type = 1
oStream.Write WinHttpReq.responseBody
oStream.SaveToFile "D:\MyDownLoads\STVR.pdf", 2 ' 1 = no overwrite, 2 = overwrite
oStream.Close
End If
End Sub
I am trying to open excel files downloded from internet and then copy the data into another excel file during vba runs with their commands.
But the command that open the excel file is executed after the ends of vba code regardless of their position.
For example, below code shows whole process of downloading and opening the excel file from a site. But at the "open_excel" function "InvokePattern.Invoke" actually occurs after the execution of all vba codes.
How do I execute this at first? Could I give some priority on that command?
Or how to wait on "InvokePattern.Invoke" until that finished?
(I try wait time or kinds of time manipulation which doesn't work)
Sub crawler_main() ' this is main function
.....
Call ieopen(ie, url_futures) 'internet explorer is opened with some url
Call click_excel(ie)
Call open_excel(ie)
Call copy_data(wbname)
.....
End Sub
Sub ieopen(ie As InternetExplorer, url As String) ' open ie
Set ie = CreateObject("InternetExplorer.Application")
ie.Visible = True
ie.navigate url
Do Until (ie.readyState = 4 And Not ie.Busy)
DoEvents
Loop
Application.Wait (Now + TimeValue("00:00:05"))
End Sub
Sub click_excel(ie As InternetExplorer) 'download excel
Dim inquiry As Object
Set inquiry = ie.document.getElementsByClassName("btn-board btn-board-search")(0)
inquiry.Click
Do Until (ie.readyState = 4 And Not ie.Busy)
DoEvents
Loop
'Application.Wait (Now + TimeValue("00:00:05"))
Dim Buttons_Excel As Object
Dim Button As Object
Set Buttons_Excel = ie.document.getElementsByTagName("button")
For Each Button In Buttons_Excel
If Button.innerHTML = "Excel" Then
Button.FireEvent ("onclick")
Exit For
End If
Next
End Sub
Sub open_excel(ie As InternetExplorer) 'click open in dialog open/save
Dim e As IUIAutomationElement
Dim o As CUIAutomation
Set o = New CUIAutomation
Dim h As Long
h = ie.hwnd
h = FindWindowEx(h, 0, "Frame Notification Bar", vbNullString)
If h = 0 Then Exit Sub
Set e = o.ElementFromHandle(ByVal h)
Dim iCnd As IUIAutomationCondition
Set iCnd = o.CreatePropertyCondition(UIA_NamePropertyId, "열기")
Dim Button_Download As IUIAutomationElement
Set Button_Download = e.FindFirst(TreeScope_Subtree, iCnd)
Dim InvokePattern As IUIAutomationInvokePattern
Set InvokePattern = Button_Download.GetCurrentPattern(UIA_InvokePatternId)
InvokePattern.Invoke
End Sub
Sub copy_data(wbname As String) 'copy data from recently opened file.
'But here is problematic since file is open after the execution of all vba codes
For Each wb In Application.Workbooks
If wb.Name Like "dat" & "*" Then
Set wb_data = Workbooks(wb.Name)
Exit For
End If
Next wb
............
End Sub
This might be relevant: http://msdn.microsoft.com/en-us/libr...87(VS.85).aspx
Note that you can use realtime which is higher but you will have to set permissions to do so...
Code:
Sub SetPriority()
Const ABOVE_NORMAL = 32768
Const HIGH = 128
strComputer = "."
Set objWMIService = GetObject("winmgmts:" _
& "{impersonationLevel=impersonate}!\\" _
& strComputer & "\root\cimv2")
Set colProcesses = objWMIService.ExecQuery _
("Select * from Win32_Process Where Name = 'excel.exe'")
For Each objProcess In colProcesses
objProcess.SetPriority (HIGH)
Next
End Sub