VBA pass cell value to Print dialogue box - vba

This is the Sub that I have built so far:
Sub Grab_Screencap()
'Open URL
With CreateObject("InternetExplorer.Application")
.Visible = True
.Navigate _
Worksheets("Queue").Range("A3").Value
Application.Wait (Now + #12:00:02 AM#)
SendKeys "^p", True
Application.Wait (Now + #12:00:02 AM#)
SendKeys "{UP}", True
SendKeys "{UP}", True
SendKeys "~", True
Application.Wait (Now + #12:00:02 AM#)
SendKeys "+{TAB}", True
SendKeys "+{TAB}", True
SendKeys "+{TAB}", True
SendKeys "+{TAB}", True
SendKeys "+{TAB}", True
SendKeys "~", True
End With
End Sub
I am sure there are much better ways to do it, but I am still on the kiddie side of the pool.
This takes a URL that I have in a spreadsheets, and then opens IE, navigates to that page, opens the Print dialogue box, selects XPS Document Writer, navigates to the pathway field, and then highlights the value.
Now I want to pass a base directory, and a file name from a cell, something like
"C:\users\user1\desktop\" & Worksheets("Queue").Range("A5").Value
Tinkering around but cant find any existing documentation that lines up with what I'm trying to do that I can comprehend.

In order to print the content of the external file (for example, C:\Temp\TestFile.txt) from Excel VBA macro you can use ShellExecute() function as shown below.
First, insert the VBA Module (e.g. Module1) and place the following declarations and Sub into that Module1:
Public Declare Function ShellExecute Lib "shell32.dll" Alias _
"ShellExecuteA" (ByVal hwnd As Long, ByVal lpOperation _
As String, ByVal lpFile As String, ByVal lpParameters _
As String, ByVal lpDirectory As String, ByVal nShowCmd _
As Long) As Long
Public Const SW_SHOWNORMAL = 1
Public Sub ShellExecuteSample()
'shown as example: it will open the text file C:\Temp\TestFile.txt
OpenFile = ShellExecute(hwnd, "open", "C:\Temp\TestFile.txt", "", "C:\", SW_SHOWNORMAL)
'this will print the content of the text file C:\Temp\TestFile.txt
PrintFile = ShellExecute(hwnd, "print", "C:\Temp\TestFile.txt", "", "C:\", SW_SHOWNORMAL)
End Sub
When called, this Sub ShellExecuteSample() will print the content and (optionally) open the text file: C:\Temp\TestFile.txt. Pertinent to your case, it could be the file specified by your string:
"C:\users\user1\desktop\" & Worksheets("Queue").Range("A5").Value
Apparently, you do not need a PrintDialog to complete this task.
Hope this may help.

So, im sure this isn't nearly the most elegant way to achieve the task, but this is what I was able to write that does what I want it to do:
Sub Grab_Screencap()
Dim i As Integer
i = 3
Do Until IsEmpty(Cells(i, 2))
'Copy Screencap Name
Sheets("Queue").Cells(i, 6).Copy
'Open URL
Set IE = CreateObject("InternetExplorer.Application")
With IE
.Visible = True
.Navigate _
Worksheets("Queue").Cells(i, 2).Value
Application.Wait (Now + #12:00:02 AM#)
SendKeys "^p", True
Application.Wait (Now + #12:00:02 AM#)
SendKeys "{UP}", True
SendKeys "{UP}", True
SendKeys "~", True
Application.Wait (Now + #12:00:02 AM#)
SendKeys "{TAB}", True
SendKeys "{TAB}", True
SendKeys "{TAB}", True
SendKeys "{TAB}", True
SendKeys "{TAB}", True
Application.Wait (Now + #12:00:02 AM#)
SendKeys "~", True
SendKeys "C:\Users\Johnny\Desktop\Job Listings\"
Application.Wait (Now + #12:00:02 AM#)
SendKeys "+{TAB}", True
SendKeys "+{TAB}", True
SendKeys "+{TAB}", True
SendKeys "+{TAB}", True
SendKeys "+{TAB}", True
Application.Wait (Now + #12:00:02 AM#)
SendKeys "^v", True
Application.Wait (Now + #12:00:02 AM#)
SendKeys "%s", True
Application.Wait (Now + #12:00:02 AM#)
IE.Quit
End With
i = i + 1
Loop
End Sub
The 101 lesson was that SendKeys can send an entire string, not just a single key. I didnt need to merge the file name with the pathway. I just needed to drop the pathway, tab back to file name, and drop the file name, which I could copy before opening IE.
I think there is a way to do this task just by opening the print dialogue and activating print to file, but I have not tried to figure that out yet.

Related

Save an active notepad at a specific folder using sendkeys

i'm trying to copy screen info from 5250 green screen application, paste into text file then save it into a specific path location (C:\Desktop\testing).
Sub Savetxt()
AppActivate 5250Screen
SendKeys "%", True
SendKeys "EC", True
Call Shell("NOTEPAD.EXE", 1) 'open notepad
SendKeys "^v", True 'paste to notepad
SendKeys "^s", True 'save notepad
Item.SaveAs "C:\Desktop\testing" & filename & ".txt", olTXT
SendKeys "{enter}", True
SendKeys "%{F4}", True
End Sub

Using current instance of Internet Explorer for GetObject

I am trying to use SendKeys to navigate & enter data with Internet Explorer. The first section of code has a loop during which the webpage (ending in .php) refreshes itself to get the entry in. As I'm using SendKeys once the browser is opened, I'm looking for a way to pause the script until the page is loaded and ready to receive input. I'm currently using a small time delay of 3 seconds which works well but if the browser lags, everything goes haywire.
So, is there anything that can facilitate this or at least allow me to use the GetObject command to set a current instance of Internet Explorer as an object.
AppActivate "Explorer"
Dim CCount As Integer
Dim DCount As Integer
Dim LCount As Integer
LCount = 1
CCount = 2
DCount = ActiveSheet.Range("O2").Value
Dim LoopP As Integer
LoopP = 1
For LoopP = 1 To DCount
SendKeys ActiveSheet.Range("A" & CCount).Value, True
SendKeys "{Tab}", True
SendKeys Format(ActiveSheet.Range("C" & CCount).Value, "#,###"), True
SendKeys "{Tab}", True
' Breakdown IF
If ActiveSheet.Range("K" & CCount).Value = 1 Then
SendKeys ActiveSheet.Range("D" & CCount).Value, True
Else
End If
SendKeys "{Tab}"
' Remark IF
If ActiveSheet.Range("L" & CCount).Value = 1 Then
SendKeys ActiveSheet.Range("E" & CCount).Value, True
Else
End If
SendKeys "{Tab}", True
SendKeys "{Enter}", True
CCount = CCount + 1
' While IE.Busy Or IE.readyState <> 4: DoEvents: Wend
' While IE.readyState <> 4 Or IE.Busy: DoEvents: Wend
' Do While IE.readyState <> 4: WScript.Sleep 100: Loop
Application.Wait (Now + TimeValue("0:00:01"))
Next LoopP

"Save as other" in pdf by vba

I am trying to create a VBA macro to copy data from a PDF file to an Excel file but the data always merges into 1 column instead of 2 columns same as pdf file.
It is difficult to get data for next steps.
So, I would like to use tab "Save as other" ->Text in Pdf file to save file as txt file with 2 columns. I use SendKeys "%fhx" to show Save as dialog but I can't change the path and file name.
Please help me to solve this.
The code is as follows:
Do While filepdf <> ""
task = Shell("C:\Program Files (x86)\Adobe\Reader 11.0\Reader\AcroRd32.exe " & filename, 1)
Application.Wait Now + TimeValue("00:00:2")
SendKeys "%fhx" AppActivate (task) --- I dont know how to select Save as dialog to change path and file name ---
SendKeys "%s" Application.Wait Now + TimeValue("00:00:2")
SendKeys "%{F4}", True
filepdf = Dir(path & "*.pdf")
Loop
Two disclaimers before my answer:
I do not have Acrobat Reader, that's why I have used Notepad.exe. But the idea is the same, you will manage to adapt it.
Sending keys is not a good practise in general. But everyone uses it, so...
That's the code, the comments are hopefully explanatory.
You should find a way to put it in your loop.
Have fun:
Option Explicit
Public Sub TestMe()
Dim task As Variant
task = Shell("C:/Windows/Notepad.exe", 1)
AppActivate task
'save as
SendKeys "%fa", True
'name in the save as
SendKeys "vityata.txt", True
'press enter
SendKeys "{ENTER}", True
'exit notepad
SendKeys "%fx", True
End Sub
Edit:
If you want to change the destionation path, then change it like this:
'name in the save as
SendKeys "C:\Users\lili\ivanova\ale\new\vityata.txt", True
I tried the below code and found that it was ok :
Sub SaveAsPdf()
Dim task
task = Shell("C:\Program Files (x86)\Adobe\Reader 11.0\Reader\AcroRd32.exe " & namepdf, 1)
SendKeys "%fhx"
AppActivate (task)
SendKeys nametxt, True
SendKeys "{TAB}"
SendKeys "{TAB}"
SendKeys "{TAB}"
SendKeys "{TAB}"
SendKeys "{TAB}"
SendKeys "{TAB}"
SendKeys "{ENTER}"
SendKeys path, True
SendKeys "{ENTER}"
SendKeys "%s"
End sub

Copy and Paste contents from another workbook into current workbook

I have some code that downloads an excel file from the web. I need it to copy and paste its contents into my current workbook, but I get the "Subscript out of range" error. Code is below, and thanks in advance!
Sub dwnld()
Set IE = New SHDocVw.InternetExplorer
IE.Visible = True
IE.navigate "http://broomfield.flatironslibrary.org/"
While IE.Busy
DoEvents
Wend
Do Until Not IE.Busy And IE.readyState = 4
DoEvents
Loop
IE.document.getElementsByClassName("hidden-xs header-button header-primary")(0).Click
Application.Wait (Now + #12:00:02 AM#)
IE.document.getElementById("username").Value = "user"
IE.document.getElementById("password").Value = "pass"
IE.document.getElementsByClassName("btn btn-primary extraModalButton")(0).Click
Application.Wait (Now + #12:00:02 AM#)
IE.navigate ("http://broomfield.flatironslibrary.org/MyAccount/CheckedOut?exportToExcel")
Application.Wait (Now + #12:00:02 AM#)
Application.SendKeys ("%o")
Application.Wait (Now + #12:00:05 AM#)
Call CopyingRange
End Sub
Copying Range Code:
Sub CopyingRange()
Workbooks("CheckedOutItems").Sheets("Checked Out").Range("A3:E62").Copy Range("B2")
End Sub
Please try this code below for CopyingRange
Sub CopyingRange()
Workbooks("CheckedOutItems").Sheets("Checked Out").Range("A3:E62").Copy ThisWorkBook.ActiveSheet.Range("B2")
End Sub
Good luck!

Run VBA automation for pulling internetexplorer source data in background

I work in an engine maintenance department and for alot of our big projects (i.e. diesel engine rebuilds) we have to request alot of parts through our inventory intranet site. all of our parts have an assigned identification/catalog number. Unfortunately the site only lets you search for one part at a time. I created this macro to speed up the process and check our inventory for all catalog numbers I enter into the spreadsheet.
I wrote a macro in VBA that would access the site, use the catalog numbers (I have entered in the A-Column of my worksheet) and plug it into the search inventory page. My Macro would then retrieve the part description, manufacturer part number, number available, number on order and return it to my spreadsheet.
In order for this macro to work I pretty much have to leave my computer alone until the whole process is finished (i.e. no opening up any new windows, no minimizing the macro-opened internet explorer...)
I was wondering if there's any way to make it so that I can use my computer while this macro is running through its thing.
Sub ICSsearch()
Range("A2").Select
Dim IE As Object
Set IE = CreateObject("InternetExplorer.Application")
IE.Visible = True
'Go to this Web Page!
IE.navigate "http://dd2.deepwater.com/t-sso-v206/sso/logon.aspx?baseurl=http://dd2.deepwater.com/ics/home.aspx"
'Check for good connection to web page loop!
Do
If IE.readyState = 4 Then
IE.Visible = True
Exit Do
Else
DoEvents
End If
Loop
'Wait for window to open!
Application.Wait (Now + TimeValue("0:00:01"))
IE.Visible = True
'Send logon information
Application.Wait (Now + TimeValue("0:00:01"))
SendKeys "ENTER USERNAME", True
SendKeys "{TAB}", True
SendKeys "ENTER PASSWORD", True
Application.Wait (Now + TimeValue("0:00:01"))
SendKeys "{Enter}", True
'Go to this Web Page for Search Inventory (also start of search loop)!
Do
Application.Wait (Now + TimeValue("0:00:02"))
IE.navigate "http://dd2.deepwater.com/ics/stocksearch.aspx"
'Enter ICN number
Application.Wait (Now + TimeValue("0:00:02"))
IE.Document.getelementbyid("ctl05_TextBoxSCN").Value = Range("A" & (ActiveCell.Row))
Application.Wait (Now + TimeValue("0:00:02"))
SendKeys "{Enter}", True
'Extract ICS Results
Application.Wait (Now + TimeValue("0:00:02"))
Range("B" & (ActiveCell.Row)) = IE.Document.getelementbyid("ctl05_LabelPartNumber").innerText
Range("C" & (ActiveCell.Row)) = IE.Document.getelementbyid("ctl05_LabelDescription").innerText
Range("D" & (ActiveCell.Row)) = IE.Document.getelementbyid("ctl05_LabelUsableQty").innerText
Range("E" & (ActiveCell.Row)) = IE.Document.getelementbyid("ctl05_LabelOnOrderQuantity").innerText
Range("A" & (ActiveCell.Row)).Select
ActiveCell.Offset(1, 0).Select
If Range("A" & (ActiveCell.Row)).Value = "" Then
Exit Do
Else
DoEvents
End If
Loop
End Sub
If we using "SendKeys" Method system wont allow you to work.. Instead you can find out your site UserName and PassWord input box ids or Name and the use below code.
IE.Document.getElementByID("YourIDID").value = UserName
IE.Document.getelementByID("YouPWDID").vlaue = PWD
IE.Document.getelementByID("ButtonID").click
By using this way there is no dependency between excel and other applications so you can use your system.
If you use send key there is a possibility it can type anywhere instead of input box.
This is done in IE Window only, you can use your computer?
'
' Do IE wait: waiting for IE query return:
' inputs:
' objIe: IE object
'
Function sofDoIeWait(ByVal objIe)
While (objIe.Busy Or objIe.readyState <> 4)
DoEvents
Wend
sofDoIeWait = 1
End Function
Sub sof20160137ICSsearch()
Dim iRow As Long, IE As Object
Set IE = CreateObject("InternetExplorer.Application")
IE.Visible = True
'Go to this Web Page!
IE.navigate "http://dd2.deepwater.com/t-sso-v206/sso/logon.aspx?baseurl=http://dd2.deepwater.com/ics/home.aspx"
'Check for good connection to web page loop!
sofDoIeWait IE
'Wait for window to open!
' Application.Wait (Now + TimeValue("0:00:01"))
' IE.Visible = True
'Send logon information
' Application.Wait (Now + TimeValue("0:00:01"))
SendKeys "ENTER USERNAME", True
SendKeys "{TAB}", True
SendKeys "ENTER PASSWORD", True
' Application.Wait (Now + TimeValue("0:00:01"))
SendKeys "{Enter}", True
sofDoIeWait IE
'
' now we are logged in, so go to the search page:
'
IE.navigate "http://dd2.deepwater.com/ics/stocksearch.aspx"
sofDoIeWait IE
'
Range("A2").Select
iRow = ActiveCell.Row
'
'Go to this Web Page for Search Inventory (also start of search loop)!
'
Do
'Application.Wait (Now + TimeValue("0:00:02"))
'Enter ICN number
'Application.Wait (Now + TimeValue("0:00:02"))
'
' do search the value of the ActiveCell:
'
IE.Document.getElementById("ctl05_TextBoxSCN").Value = Range("A" & iRow)
'Application.Wait (Now + TimeValue("0:00:02"))
SendKeys "{Enter}", True
sofDoIeWait IE
'
'Extract ICS Results
'Application.Wait (Now + TimeValue("0:00:02"))
'
Range("B" & iRow) = IE.Document.getElementById("ctl05_LabelPartNumber").innerText
Range("C" & iRow) = IE.Document.getElementById("ctl05_LabelDescription").innerText
Range("D" & iRow) = IE.Document.getElementById("ctl05_LabelUsableQty").innerText
Range("E" & iRow) = IE.Document.getElementById("ctl05_LabelOnOrderQuantity").innerText
Range("A" & iRow).Select
ActiveCell.Offset(1, 0).Select
iRow = ActiveCell.Row
If Range("A" & iRow).Value = "" Then
Exit Do
Else
DoEvents
End If
Loop
End Sub