my functional code was normally in office 32bits, after updating to office 365 64 lost typing in the window
my code:
TryAgain:
On Error GoTo err_handler
hwnd = FindWindow("#32770", "Exportar file")
If hwnd = 0 Then
If I < 5 Then 'Caso não encontre o FileDialog(SAP) retorna para o inicio da Macro e Tenta 5 vezes com intervalo de 2 segundos.
I = I + 1
Application.Wait Now + TimeValue(TGTime_CFD)
GoTo TryAgain
Else
MsgBox "'Save As'-dialog not found"
Exit Sub
End If
End If
Childhwnd = **FindWindowEx** (hwnd, ByVal 0&, "ComboBoxEx32", vbNullString)
If Childhwnd = 0 Then
MsgBox "ComboBoxEx32 not found"
Exit Sub
End If
Childhwnd = FindWindowEx(Childhwnd, ByVal 0&, "ComboBox", vbNullString)
If Childhwnd = 0 Then
MsgBox "ComboBox control not found"
Exit Sub
End If
Childhwnd = FindWindowEx(Childhwnd, ByVal 0&, "Edit", vbNullString)
If Childhwnd = 0 Then
MsgBox "Edit control not found"
Exit Sub
End If
ActivateWindow (StrPtr(hwnd))
Related
I have a macro in that creates a ListBox.
The first item should be selected as default.
I tried
UserForm.ListBox.Selected(0) = True
I get
How can I control the Listbox from the keyboard? I need to scroll up and down with "UP" and "DOWN" keys and if "ENTER" is pressed the selected Item should be taken.
I tried the following, but this captures every "ENTER" during the code (not only when the UserForm (ListBox) is loaded).
Public Sub Listbox_Enter()
'DO Something
End Sub
Current code:
Option Explicit
Public WithEvents GExplorer As Outlook.Explorer
Public WithEvents GMailItem As Outlook.MailItem
Public WithEvents objInspectors As Outlook.Inspectors
Public WithEvents objTask As Outlook.TaskItem
'Start Outlook
Private Sub Application_Startup()
Set GExplorer = Outlook.Application.ActiveExplorer
Set objInspectors = Outlook.Application.Inspectors
End Sub
'Capture every change, but on same ActiveExplorer (Window)
Private Sub GExplorer_SelectionChange()
Dim xItem As Object
On Error Resume Next
Set xItem = GExplorer.Selection.Item(1)
If xItem.Class <> olMail Then Exit Sub
Set GMailItem = xItem
End Sub
'Reply pressed
Private Sub GMailItem_Reply(ByVal Response As Object, Cancel As Boolean)
AutoAddGreetingtoReply Response
End Sub
'ReplyAll pressed
Private Sub GMailItem_ReplyAll(ByVal Response As Object, Cancel As Boolean)
AutoAddGreetingtoReply Response
End Sub
'Forward pressed
Private Sub GMailItem_Forward(ByVal Response As Object, Cancel As Boolean)
AutoAddGreetingtoReply Response
End Sub
Sub AutoAddGreetingtoReply(Item As Object)
Dim xGreetStr As String: Dim xReplyMail As MailItem
Dim xSenderName As String: Dim lSpace As Long
Dim xRecipient As Recipient: Dim obj As Outlook.MailItem
Dim EmailAdress As String: Dim EmailNameBeforeAtIkon As String:
Dim c As ContactItem
Dim names As String
On Error Resume Next:
Set obj = Outlook.ActiveExplorer.Selection.Item(1)
'This part finds the receipients
If Item.Class <> olMail Then Exit Sub 'Quits if no email is chosen
Set xReplyMail = Item
For Each xRecipient In xReplyMail.Recipients
If xSenderName = "" Then
xSenderName = xRecipient.name
Else
xSenderName = xSenderName & ", " & xRecipient.name
End If
Next xRecipient
Dim lSpace_f As Variant
Dim stFirstNAme As String
Dim st_FirstName As String
Dim currentNAme As String
lSpace_f = InStr(1, xSenderName, " ", vbTextCompare)
If lSpace_f > 0 Then
stFirstNAme = Trim(Split(xSenderName, ",")(1))
st_FirstName = Split(stFirstNAme, " ")(0)
currentNAme = st_FirstName + ","
End If
'Writes a greeting
With UserForm1.Listbox_Auswahl
.AddItem "Hello " + currentNAme
.AddItem "Good morning " + currentNAme
End With
UserForm1.Caption = ("Greeting")
Load UserForm1
UserForm1.StartUpPosition = 2
UserForm1.Show
'Creates the email
With xReplyMail
.Display
.HTMLBody = "<HTML><Body><span style=""color:#0e4a80"">" + markierterEintrag + "</span style=""color:#0e4a80""></HTML></Body>" & .HTMLBody
Sendkeys "{DOWN}", True
Sendkeys "{ENTER}", True
Call Sendkeys("", False)
.Close olSave
End With
End Sub
Public Sub Sendkeys(text As Variant, Optional wait As Boolean = False)
Dim WshShell As Object
Set WshShell = CreateObject("wscript.shell")
WshShell.Sendkeys CStr(text), wait
Set WshShell = Nothing
End Sub
'-------------------------------------
Public Sub Listbox_Auswahl_Click()
If UserForm1.Listbox_Auswahl.ListIndex > -1 Then
markierterEintrag = UserForm1.Listbox_Auswahl.List(UserForm1.Listbox_Auswahl.ListIndex)
End If
Unload UserForm1
End Sub
'Public Sub Listbox_Auswahl_Enter()
' If UserForm1.Listbox_Auswahl.ListIndex > -1 Then
' markierterEintrag = UserForm1.Listbox_Auswahl.List(UserForm1.Listbox_Auswahl.ListIndex)
' End If
'
' Unload UserForm1
'End Sub
This worked for me:
Public Sub Listbox_Auswahl_Click()
If UserForm1.Listbox_Auswahl.ListIndex > -1 Then
markierterEintrag = UserForm1.Listbox_Auswahl.List(UserForm1.Listbox_Auswahl.ListIndex)
End If
End Sub
Public Sub Listbox_Auswahl_KeyPress(ByVal KeyAscii As MSForms.ReturnInteger)
If KeyAscii = 13 Then
With Me.Listbox_Auswahl
If .ListIndex > -1 Then
markierterEintrag = .List(.ListIndex)
End If
End With
Unload UserForm1
End If
End Sub
Public Sub Listbox_Auswahl_MouseDown(ByVal Button As Integer, ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single)
If Button = 1 Then
'pressed_key_flag = 1
If UserForm1.Listbox_Auswahl.ListIndex > -1 Then
markierterEintrag = UserForm1.Listbox_Auswahl.List(UserForm1.Listbox_Auswahl.ListIndex)
Unload UserForm1
End If
End If
End Sub
Using VBA, how can I click the orange LOGIN button on the below page:
https://www.solaraccreditation.com.au/login.html
Inspect element shows:
<input class="button bg-orange" value="Login" type="submit">
So far my code is:
Option Explicit
Private Declare Sub ShowWindow Lib "user32" _
(ByVal hWnd As Long, ByVal nCmdShow As Long)
Const strTMP As String = "Excel VBA"
Private Const SW_MAXIMIZE = 3
Public Sub Test()
Dim objWindow As Object
Dim objIEApp As Object
Dim objShell As Object
Dim objItem As Object
Dim objInputs As Object
Dim ele As Object
On Error GoTo Fin
Set objShell = CreateObject("Shell.Application")
Set objWindow = objShell.Windows()
For Each objItem In objWindow
If LCase(objItem.FullName Like "*iexplore*") Then
Set objIEApp = objItem
End If
Next objItem
If objIEApp Is Nothing Then
Set objIEApp = CreateObject("InternetExplorer.Application")
objIEApp.Visible = True
End If
With objIEApp
.Visible = True
ShowWindow .hWnd, SW_MAXIMIZE
.Navigate "https://www.solaraccreditation.com.au/login.html"
While Not .ReadyState = 4
DoEvents
Wend
.document.All("username").Value = _
ThisWorkbook.Sheets("sheet1").Range("a1")
.document.All("password").Value = _
ThisWorkbook.Sheets("sheet1").Range("a2")
End With
' <input class="button bg-orange" type="submit" value="Login" />
Fin:
If Err.Number <> 0 Then MsgBox "Error: " & _
Err.Number & " " & Err.Description
Set objWindow = Nothing
Set objShell = Nothing
End Sub
Mary Poppins "Classic Disney" soundtrack. ... Um diddle diddle, diddle um, diddle ay x2 ? Now, you can say it backwards, which is docious-ali-expi-listic-frag
i-cali-rupus.
You could try identifying the button as the first in its class.
.document.getelementsbyclass("button bg-orange")(0).click
But it might be more expedient to simply force the form to submit.
.document.getelementbyid("loginForm").submit
I have a number of macros where I want it run some code, then prompt the user to export an Excel workbook from another program, then run more code once the export has been opened. The tricky part is that some programs export to a new instance of Excel, while other programs export to the current instance.
The current workflow is (code at bottom):
Call the central 'Capture' Module with the name of the export (some
programs export 'Book[x]' some do 'workbook[x]', etc.) and the
procedure you want to run once the export is found.
Capture Module gets a list of all existing workbook names from all
Excel instances and saves as a Module-level string.
Capture Module uses Application.OnTime so that every 3 seconds, it
scans the list of all workbooks across all Excel instances.
If it finds a workbook that is not in the previously saved list of
all existing workbook names, and that contains the name of the
export, it stores that workbook as a public module level variable,
and runs the saved procedure from Step 1, which can the reference
the store workbook.
This works very well in all circumstances, EXCEPT for one. If I already have Book1.xlsx open in my current instance of Excel, and the 3rd party program exports Book1.xlsx to a NEW instance of Excel, the program doesn't recognize this as the export, since Book1.xlsx is in the existing workbook names string array already.
My solution is to find some way of uniquely identifying each workbook that's better than 'Name' or 'Path'. I tried saving each workbook name in the existing workbook names string as [application.hwnd]![workbook name] but this was an unstable fix and frequently broke (I don't really understand how hwnd works so I can't say why).
Any ideas? Thanks!
Sample Procedures That Use MCaptureExport
Public Sub GrabFXAllExport()
Const sSOURCE As String = "GrabFXAllExport"
On Error GoTo ErrorHandler
If Not TAAA.MCaptureExport.bCaptureExport("FXALL", "TAAA.FXAllEmail.ProcessFXAllExport") Then Err.Raise glHANDLED_ERROR
ErrorExit:
Exit Sub
ErrorHandler:
If bCentralErrorHandler(msMODULE, sSOURCE, , True) Then
Stop
Resume
Else
Resume ErrorExit
End If
End Sub
Public Sub ProcessFXAllExport()
Const sSOURCE As String = "ProcessFXAllExport"
On Error GoTo ErrorHandler
If MCaptureExport.mwbCaptured Is Nothing Then
MsgBox "Exported Workbook Not Found. Please try again.", vbCritical, gsAPP_NAME
GoTo ErrorExit
End If
Dim wsSourceSheet As Worksheet
Set wsSourceSheet = MCaptureExport.mwbCaptured.Worksheets(1)
Set MCaptureExport.mwbCaptured = Nothing
[I now have the export and can work with it as a I please]
ErrorExit:
Exit Sub
ErrorHandler:
If bCentralErrorHandler(msMODULE, sSOURCE, , True) Then
Stop
Resume
Else
Resume ErrorExit
End If
End Sub
MCaptureExport Module
Option Explicit
Option Base 1
' Description: This module contains the central error
' handler and related constant declarations.
Private Const msMODULE As String = "MCaptureExport"
Private sExistingWorkbookList() As String
Public mwbCaptured As Workbook
Public msCaptureType As String
Private sReturnProcedure As String
Private bListening As Boolean
Public Function bCaptureExport(sCaptureType As String, sRunAfterCapture As String) As Boolean
Dim bReturn As Boolean
Const sSOURCE As String = "bCaptureExport()"
On Error GoTo ErrorHandler
bReturn = True
If Not bWorkbookNamesAsArray(sExistingWorkbookList, True, False) Then Err.Raise glHANDLED_ERROR
sReturnProcedure = sRunAfterCapture
bListening = True
msCaptureType = sCaptureType
TAAA.MCaptureExport.WaitForCapture sCaptureTypeToNameContains(msCaptureType)
MsgBox "Waiting for " & msCaptureType & " Export", vbInformation, gsAPP_NAME
ErrorExit:
bCaptureExport = bReturn
Exit Function
ErrorHandler:
bReturn = False
If bCentralErrorHandler(msMODULE, sSOURCE) Then
Stop
Resume
Else
Resume ErrorExit
End If
End Function
Private Sub WaitForCapture(sNameContains As String)
Const sSOURCE As String = "WaitForCapture"
On Error GoTo ErrorHandler
Dim wbCaptureCheck As Workbook
If Not bCaptureCheck(sNameContains, wbCaptureCheck) Then Err.Raise glHANDLED_ERROR
If wbCaptureCheck Is Nothing Then
If bListening Then _
Application.OnTime Now + TimeSerial(0, 0, 3), "'TAAA.MCaptureExport.WaitForCapture " & Chr(34) & sNameContains & Chr(34) & "'"
Else
Dim bSameApp As Boolean
If Not bWorkbooksInSameApp(ThisWorkbook, wbCaptureCheck, bSameApp) Then Err.Raise glHANDLED_ERROR
If Not bSameApp Then
Dim sTempFilePath As String
sTempFilePath = ThisWorkbook.Path & "\temp_" & Format(Now, "mmddyyhhmmss") & ".xls"
wbCaptureCheck.SaveCopyAs sTempFilePath
wbCaptureCheck.Close SaveChanges:=False
Set wbCaptureCheck = Application.Workbooks.Open(sTempFilePath)
End If
Set mwbCaptured = wbCaptureCheck
bListening = False
Application.Run sReturnProcedure
End If
ErrorExit:
Exit Sub
ErrorHandler:
If bCentralErrorHandler(msMODULE, sSOURCE, , True) Then
Stop
Resume
Else
Resume ErrorExit
End If
End Sub
Private Function sCaptureTypeToNameContains(sCaptureType As String) As String
sCaptureTypeToNameContains = "*"
On Error Resume Next
Select Case UCase(sCaptureType)
Case "SOTER": sCaptureTypeToNameContains = "workbook"
Case "THOR": sCaptureTypeToNameContains = "Book"
Case "FXALL": sCaptureTypeToNameContains = "search_results_export"
End Select
End Function
Private Function bCaptureCheck(sNameContains As String, wbResult As Workbook) As Boolean
Dim bReturn As Boolean
Const sSOURCE As String = "bCaptureCheck()"
On Error GoTo ErrorHandler
bReturn = True
Dim i As Long, wb As Workbook
Dim xlApps() As Application
If Not bGetAllExcelInstances(xlApps) Then Err.Raise glHANDLED_ERROR
For i = LBound(xlApps) To UBound(xlApps)
For Each wb In xlApps(i).Workbooks
If wb.Name Like "*" & sNameContains & "*" _
And Not bIsInArray(wb.Name, sExistingWorkbookList) Then
Set wbResult = wb
GoTo ErrorExit
End If
Next
Next
ErrorExit:
bCaptureCheck = bReturn
Exit Function
ErrorHandler:
bReturn = False
If bCentralErrorHandler(msMODULE, sSOURCE) Then
Stop
Resume
Else
Resume ErrorExit
End If
End Function
Utility Functions Used by MCaptureExport
Public Function bWorkbookNamesAsArray(sResult() As String, Optional bAllInstances As Boolean = True) As Boolean
Dim bReturn As Boolean
Const sSOURCE As String = "bWorkbookNamesAsArray()"
On Error GoTo ErrorHandler
bReturn = True
Dim i As Long, wb As Workbook
Dim xlApps() As Application
Dim ResultArray() As String
Dim Ndx As Integer, wbCount As Integer
If bAllInstances Then
If Not bGetAllExcelInstances(xlApps) Then Err.Raise glHANDLED_ERROR
Else
ReDim xlApps(0)
Set xlApps(0) = Application
End If
For i = LBound(xlApps) To UBound(xlApps)
For Each wb In xlApps(i).Workbooks
wbCount = wbCount + 1
Next
Next
ReDim ResultArray(1 To wbCount)
For i = LBound(xlApps) To UBound(xlApps)
For Each wb In xlApps(i).Workbooks
Ndx = Ndx + 1
ResultArray(Ndx) = wb.Name
Next
Next
sResult = ResultArray()
ErrorExit:
bWorkbookNamesAsArray = bReturn
Exit Function
ErrorHandler:
bReturn = False
If bCentralErrorHandler(msMODULE, sSOURCE) Then
Stop
Resume
Else
Resume ErrorExit
End If
End Function
Public Function bGetAllExcelInstances(xlApps() As Application) As Boolean
Dim bReturn As Boolean
Const sSOURCE As String = "bGetAllExcelInstances()"
On Error GoTo ErrorHandler
bReturn = True
Dim n As Long
Dim hWndMain As LongPtr
Dim app As Application
' Cater for 100 potential Excel instances, clearly could be better
ReDim xlApps(1 To 100)
hWndMain = FindWindowEx(0&, 0&, "XLMAIN", vbNullString)
Do While hWndMain <> 0
If Not bGetExcelObjectFromHwnd(hWndMain, app) Then Err.Raise glHANDLED_ERROR
If Not (app Is Nothing) Then
If n = 0 Then
n = n + 1
Set xlApps(n) = app
ElseIf bCheckHwnds(xlApps, app.Hwnd) Then
n = n + 1
Set xlApps(n) = app
End If
End If
hWndMain = FindWindowEx(0&, hWndMain, "XLMAIN", vbNullString)
Loop
If n Then
ReDim Preserve xlApps(1 To n)
'GetAllExcelInstances = n
Else
Erase xlApps
End If
ErrorExit:
bGetAllExcelInstances = bReturn
Exit Function
ErrorHandler:
bReturn = False
If bCentralErrorHandler(msMODULE, sSOURCE) Then
Stop
Resume
Else
Resume ErrorExit
End If
End Function
Private Function bCheckHwnds(xlApps() As Application, Hwnd As LongPtr) As Boolean
On Error Resume Next
Dim i As Integer
For i = LBound(xlApps) To UBound(xlApps)
If Not xlApps(i) Is Nothing Then
If xlApps(i).Hwnd = Hwnd Then
bCheckHwnds = False
Exit Function
End If
End If
Next i
bCheckHwnds = True
End Function
Public Function bWorkbooksInSameApp(wb1 As Workbook, wb2 As Workbook, bSameApp As Boolean) As Boolean
Dim bReturn As Boolean
Const sSOURCE As String = "bWorkbooksInSameApp()"
On Error GoTo ErrorHandler
bReturn = True
bSameApp = wb1.Application.Hwnd = wb2.Application.Hwnd
ErrorExit:
bWorkbooksInSameApp = bReturn
Exit Function
ErrorHandler:
bReturn = False
If bCentralErrorHandler(msMODULE, sSOURCE) Then
Stop
Resume
Else
Resume ErrorExit
End If
End Function
Private Function bGetExcelObjectFromHwnd(ByVal hWndMain As LongPtr, aAppResult As Application) As Boolean
Dim bReturn As Boolean
Const sSOURCE As String = "bGetExcelObjectFromHwnd()"
On Error GoTo ErrorHandler
bReturn = True
Dim hWndDesk As LongPtr
Dim Hwnd As LongPtr
Dim strText As String
Dim lngRet As Long
Dim iid As UUID
Dim obj As Object
hWndDesk = FindWindowEx(hWndMain, 0&, "XLDESK", vbNullString)
If hWndDesk <> 0 Then
Hwnd = FindWindowEx(hWndDesk, 0, vbNullString, vbNullString)
Do While Hwnd <> 0
strText = String$(100, Chr$(0))
lngRet = CLng(GetClassName(Hwnd, strText, 100))
If Left$(strText, lngRet) = "EXCEL7" Then
Call IIDFromString(StrPtr(IID_IDispatch), iid)
If AccessibleObjectFromWindow(Hwnd, OBJID_NATIVEOM, iid, obj) = 0 Then 'S_OK
Set aAppResult = obj.Application
GoTo ErrorExit
End If
End If
Hwnd = FindWindowEx(hWndDesk, Hwnd, vbNullString, vbNullString)
Loop
End If
ErrorExit:
bGetExcelObjectFromHwnd = bReturn
Exit Function
ErrorHandler:
MsgBox Err.Number
bReturn = False
If bCentralErrorHandler(msMODULE, sSOURCE) Then
Stop
Resume
Else
Resume ErrorExit
End If
End Function
I have a potential solution. However I want to leave the question open. This is a fairly complicated problem and I bet there are more elegant solutions than what I'm proposing.
So I updated the format of sExistingWorkbookList to [Application.hWnd]![Workbook.name]. I had tried this before but I think it's working this time.
Thoughts?
Updated Version of bWorkbookNamesAsArray
Added wb.Application.Hwnd & "!" & to ResultArray(Ndx) = wb.name
Public Function bWorkbookNamesAsArray(sResult() As String, Optional bAllInstances As Boolean = True) As Boolean
Dim bReturn As Boolean
Const sSOURCE As String = "bWorkbookNamesAsArray()"
On Error GoTo ErrorHandler
bReturn = True
Dim i As Long, wb As Workbook
Dim xlApps() As Application
Dim ResultArray() As String
Dim Ndx As Integer, wbCount As Integer
If bAllInstances Then
If Not bGetAllExcelInstances(xlApps) Then Err.Raise glHANDLED_ERROR
Else
ReDim xlApps(0)
Set xlApps(0) = Application
End If
For i = LBound(xlApps) To UBound(xlApps)
For Each wb In xlApps(i).Workbooks
wbCount = wbCount + 1
Next
Next
ReDim ResultArray(1 To wbCount)
For i = LBound(xlApps) To UBound(xlApps)
For Each wb In xlApps(i).Workbooks
Ndx = Ndx + 1
ResultArray(Ndx) = wb.Application.Hwnd & "!" & wb.Name
Next
Next
sResult = ResultArray()
ErrorExit:
bWorkbookNamesAsArray = bReturn
Exit Function
ErrorHandler:
bReturn = False
If bCentralErrorHandler(msMODULE, sSOURCE) Then
Stop
Resume
Else
Resume ErrorExit
End If
End Function
New Utility Function
Public Function bGetWorkbookFromHwndAndName(ByVal sWorkbookReference As String, ByRef wbResult As Workbook)
Dim bReturn As Boolean
Const sSOURCE As String = "bGetWorkbookFromHwndAndName()"
On Error GoTo ErrorHandler
bReturn = True
Dim xlApp As Application
If Not bGetExcelObjectFromHwnd(CLng(Split(sWorkbookReference, "!")(0)), xlApp) Then Err.Raise glHANDLED_ERROR
Set wbResult = xlApp.Workbooks(Split(sWorkbookReference, "!")(1))
ErrorExit:
bGetWorkbookFromHwndAndName = bReturn
Exit Function
ErrorHandler:
bReturn = False
If bCentralErrorHandler(msMODULE, sSOURCE) Then
Stop
Resume
Else
Resume ErrorExit
End If
End Function
Updated MCaptureExport.bCaptureCheck()
Private Function bCaptureCheck(sNameContains As String, wbResult As Workbook) As Boolean
Dim bReturn As Boolean
Const sSOURCE As String = "bCaptureCheck()"
On Error GoTo ErrorHandler
bReturn = True
Dim i As Long, wb As Workbook, sFullWorkbookReference As String
Dim xlApps() As Application
If Not bGetAllExcelInstances(xlApps) Then Err.Raise glHANDLED_ERROR
For i = LBound(xlApps) To UBound(xlApps)
For Each wb In xlApps(i).Workbooks
sFullWorkbookReference = wb.Application.Hwnd & "!" & wb.Name
If wb.Name Like "*" & sNameContains & "*" _
And Not bIsInArray(sFullWorkbookReference, sExistingWorkbookList) Then
If Not bGetWorkbookFromHwndAndName(sFullWorkbookReference, wbResult) Then Err.Raise glHANDLED_ERROR
GoTo ErrorExit
End If
Next
Next
ErrorExit:
bCaptureCheck = bReturn
Exit Function
ErrorHandler:
bReturn = False
If bCentralErrorHandler(msMODULE, sSOURCE) Then
Stop
Resume
Else
Resume ErrorExit
End If
End Function
I have it where it will open Internet Explorer give the user the save as box and then exit. However, I would prefer if instead of the user having to navigate to the correct folder, the directory comes from a cell in the worksheet and saves the webpage as a PDF. I have full Adobe installed. The code:
Sub WebSMacro()
Dim IE As Object
Dim Webloc As String
Dim FullWeb As String
Webloc = ActiveSheet.Range("B39").Value
FullWeb = "http://www.example.com=" & Webloc
Set IE = CreateObject("InternetExplorer.Application")
IE.Visible = True
IE.Navigate FullWeb
Do While IE.Busy
Application.Wait DateAdd("s", 1, Now)
Loop
IE.ExecWB OLECMDID_PRINT, OLECMDEXECOPT_DONTPROMPTUSER
Application.Wait DateAdd("s", 10, Now)
IE.Quit
Set IE = Nothing
End Sub
Today, you win the Internet!
Since I wanted to learn this more in depth for my own personal benefit, I used the code in the 2nd link I referenced in my comment to get the code to work as you have defined it.
The code will enter the FilePath and Name (gathered from a Cell) into the SaveAs Dialog Box and save it to the entered location.
Here is the main sub (with comments):
Sub WebSMacro()
'set default printer to AdobePDF
Dim WSHNetwork As Object
Set WSHNetwork = CreateObject("WScript.Network")
WSHNetwork.SetDefaultPrinter "Adobe PDF"
'get pdfSave as Path from cell range
Dim sFolder As String
sFolder = Sheets("Sheet1").Range("A1") 'assumes folder save as path is in cell A1 of mySheets
Dim IE As Object
Dim Webloc As String
Dim FullWeb As String
Webloc = ActiveSheet.Range("B39").Value
FullWeb = "http://www.example.com" & Webloc
Set IE = CreateObject("InternetExplorer.Application")
With IE
.Visible = True
.Navigate FullWeb
Do While .Busy
Application.Wait DateAdd("s", 1, Now)
Loop
.ExecWB 6, 2 'OLECMDID_PRINT, OLECMDEXECOPT_DONTPROMPTUSER
Application.Wait DateAdd("s", 3, Now)
Call PDFPrint(sFolder & Webloc & ".pdf")
.Quit
End With
Set IE = Nothing
End Sub
You will also need to place this two subs somewhere in your workbook (can be the same module as the main sub (or different one)):
Sub PDFPrint(strPDFPath As String)
'Prints a web page as PDF file using Adobe Professional.
'API functions are used to specify the necessary windows while
'a WMI function is used to check printer's status.
'By Christos Samaras
'http://www.myengineeringworld.net
Dim Ret As Long
Dim ChildRet As Long
Dim ChildRet2 As Long
Dim ChildRet3 As Long
Dim comboRet As Long
Dim editRet As Long
Dim ChildSaveButton As Long
Dim PDFRet As Long
Dim PDFName As String
Dim StartTime As Date
'Find the main print window.
StartTime = Now()
Do Until Now() > StartTime + TimeValue("00:00:05")
Ret = 0
DoEvents
Ret = FindWindow(vbNullString, "Save PDF File As")
If Ret <> 0 Then Exit Do
Loop
If Ret <> 0 Then
SetForegroundWindow (Ret)
'Find the first child window.
StartTime = Now()
Do Until Now() > StartTime + TimeValue("00:00:05")
ChildRet = 0
DoEvents
ChildRet = FindWindowEx(Ret, ByVal 0&, "DUIViewWndClassName", vbNullString)
If ChildRet <> 0 Then Exit Do
Loop
If ChildRet <> 0 Then
'Find the second child window.
StartTime = Now()
Do Until Now() > StartTime + TimeValue("00:00:05")
ChildRet2 = 0
DoEvents
ChildRet2 = FindWindowEx(ChildRet, ByVal 0&, "DirectUIHWND", vbNullString)
If ChildRet2 <> 0 Then Exit Do
Loop
If ChildRet2 <> 0 Then
'Find the third child window.
StartTime = Now()
Do Until Now() > StartTime + TimeValue("00:00:05")
ChildRet3 = 0
DoEvents
ChildRet3 = FindWindowEx(ChildRet2, ByVal 0&, "FloatNotifySink", vbNullString)
If ChildRet3 <> 0 Then Exit Do
Loop
If ChildRet3 <> 0 Then
'Find the combobox that will be edited.
StartTime = Now()
Do Until Now() > StartTime + TimeValue("00:00:05")
comboRet = 0
DoEvents
comboRet = FindWindowEx(ChildRet3, ByVal 0&, "ComboBox", vbNullString)
If comboRet <> 0 Then Exit Do
Loop
If comboRet <> 0 Then
'Finally, find the "edit property" of the combobox.
StartTime = Now()
Do Until Now() > StartTime + TimeValue("00:00:05")
editRet = 0
DoEvents
editRet = FindWindowEx(comboRet, ByVal 0&, "Edit", vbNullString)
If editRet <> 0 Then Exit Do
Loop
'Add the PDF path to the file name combobox of the print window.
If editRet <> 0 Then
SendMessage editRet, WM_SETTEXT, 0&, ByVal " " & strPDFPath
keybd_event VK_DELETE, 0, 0, 0 'press delete
keybd_event VK_DELETE, 0, KEYEVENTF_KEYUP, 0 ' release delete
'Get the PDF file name from the full path.
On Error Resume Next
PDFName = Mid(strPDFPath, WorksheetFunction.Find("*", WorksheetFunction.Substitute(strPDFPath, "\", "*", Len(strPDFPath) _
- Len(WorksheetFunction.Substitute(strPDFPath, "\", "")))) + 1, Len(strPDFPath))
On Error GoTo 0
'Save/print the web page by pressing the save button of the print window.
Sleep 1000
ChildSaveButton = FindWindowEx(Ret, ByVal 0&, "Button", "&Save")
SendMessage ChildSaveButton, BM_CLICK, 0, 0
'Sometimes the printing delays, especially in large colorful web pages.
'Here the code checks printer status and if is idle it means that the
'printing has finished.
Do Until CheckPrinterStatus("Adobe PDF") = "Idle"
DoEvents
If CheckPrinterStatus("Adobe PDF") = "Error" Then Exit Do
Loop
'Since the Adobe Professional opens after finishing the printing, find
'the open PDF document and close it (using a post message).
StartTime = Now()
Do Until StartTime > StartTime + TimeValue("00:00:05")
PDFRet = 0
DoEvents
PDFRet = FindWindow(vbNullString, PDFName & " - Adobe Acrobat")
If PDFRet <> 0 Then Exit Do
Loop
If PDFRet <> 0 Then
PostMessage PDFRet, WM_CLOSE, 0&, 0&
End If
End If
End If
End If
End If
End If
End If
End Sub
Function CheckPrinterStatus(strPrinterName As String) As String
'Provided the printer name the functions returns a string
'with the printer status.
'By Christos Samaras
'http://www.myengineeringworld.net
Dim strComputer As String
Dim objWMIService As Object
Dim colInstalledPrinters As Variant
Dim objPrinter As Object
'Set the WMI object and the check the install printers.
On Error Resume Next
strComputer = "."
Set objWMIService = GetObject("winmgmts:" & "{impersonationLevel=impersonate}!\\" & strComputer & "\root\cimv2")
Set colInstalledPrinters = objWMIService.ExecQuery("Select * from Win32_Printer")
'If an error occurs in the previous step, the function will return error.
If Err.Number <> 0 Then
CheckPrinterStatus = "Error"
End If
On Error GoTo 0
'The function loops through all installed printers and for the selected printer,
'checks it status.
For Each objPrinter In colInstalledPrinters
If objPrinter.Name = strPrinterName Then
Select Case objPrinter.PrinterStatus
Case 1: CheckPrinterStatus = "Other"
Case 2: CheckPrinterStatus = "Unknown"
Case 3: CheckPrinterStatus = "Idle"
Case 4: CheckPrinterStatus = "Printing"
Case 5: CheckPrinterStatus = "Warmup"
Case 6: CheckPrinterStatus = "Stopped printing"
Case 7: CheckPrinterStatus = "Offline"
Case Else: CheckPrinterStatus = "Error"
End Select
End If
Next objPrinter
'If there is a blank status the function returns error.
If CheckPrinterStatus = "" Then CheckPrinterStatus = "Error"
End Function
And finally Declare these constants and functions in a module as well (can be the same module as the main sub (or different one).
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 Declare Function PostMessage Lib "user32" Alias "PostMessageA" _
(ByVal hWnd As Long, ByVal wMsg As Long, ByVal wParam As Long, lParam As Any) As Long
Public Declare Sub keybd_event Lib "user32" _
(ByVal bVk As Byte, ByVal bScan As Byte, ByVal dwFlags As Long, ByVal dwExtraInfo As Long)
'Constants used in API functions.
Public Const SW_MAXIMIZE = 3
Public Const WM_SETTEXT = &HC
Public Const VK_DELETE = &H2E
Public Const KEYEVENTF_KEYUP = &H2
Public Const BM_CLICK = &HF5&
Public Const WM_CLOSE As Long = &H10
I am trying to unlock a password protected excel sheet using code found here
I am successfully able to unlock the excel file, but I do not want the user to see any windows. I tried setting this setting:
xlAp.Visible = False
But I still see the Project Properties window. How can you hide all the windows in this process?
Private Declare Function FindWindow Lib "user32" Alias "FindWindowA" _
(ByVal lpClassName As String, ByVal lpWindowName As String) As Long
Private 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
Private Declare Function GetWindowText Lib "user32" Alias "GetWindowTextA" _
(ByVal hwnd As Long, ByVal lpString As String, ByVal cch As Long) As Long
Private Declare Function GetWindowTextLength Lib "user32" Alias _
"GetWindowTextLengthA" (ByVal hwnd As Long) As Long
Private Declare Function SendMessage Lib "user32" Alias "SendMessageA" _
(ByVal hwnd As Long, ByVal wMsg As Long, ByVal wParam As Long, lParam As Any) As Long
Dim Ret As Long, ChildRet As Long, OpenRet As Long
Dim strBuff As String, ButCap As String
Dim MyPassword As String
Const WM_SETTEXT = &HC
Const BM_CLICK = &HF5
Sub UnlockVBA()
Dim xlAp As Object, oWb As Object
Set xlAp = CreateObject("Excel.Application")
xlAp.Visible = True
'~~> Open the workbook in a separate instance
Set oWb = xlAp.Workbooks.Open("C:\Sample.xlsm")
'~~> Launch the VBA Project Password window
'~~> I am assuming that it is protected. If not then
'~~> put a check here.
xlAp.VBE.CommandBars(1).FindControl(ID:=2578, recursive:=True).Execute
'~~> Your passwword to open then VBA Project
MyPassword = "Blah Blah"
'~~> Get the handle of the "VBAProject Password" Window
Ret = FindWindow(vbNullString, "VBAProject Password")
If Ret <> 0 Then
'MsgBox "VBAProject Password Window Found"
'~~> Get the handle of the TextBox Window where we need to type the password
ChildRet = FindWindowEx(Ret, ByVal 0&, "Edit", vbNullString)
If ChildRet <> 0 Then
'MsgBox "TextBox's Window Found"
'~~> This is where we send the password to the Text Window
SendMess MyPassword, ChildRet
DoEvents
'~~> Get the handle of the Button's "Window"
ChildRet = FindWindowEx(Ret, ByVal 0&, "Button", vbNullString)
'~~> Check if we found it or not
If ChildRet <> 0 Then
'MsgBox "Button's Window Found"
'~~> Get the caption of the child window
strBuff = String(GetWindowTextLength(ChildRet) + 1, Chr$(0))
GetWindowText ChildRet, strBuff, Len(strBuff)
ButCap = strBuff
'~~> Loop through all child windows
Do While ChildRet <> 0
'~~> Check if the caption has the word "OK"
If InStr(1, ButCap, "OK") Then
'~~> If this is the button we are looking for then exit
OpenRet = ChildRet
Exit Do
End If
'~~> Get the handle of the next child window
ChildRet = FindWindowEx(Ret, ChildRet, "Button", vbNullString)
'~~> Get the caption of the child window
strBuff = String(GetWindowTextLength(ChildRet) + 1, Chr$(0))
GetWindowText ChildRet, strBuff, Len(strBuff)
ButCap = strBuff
Loop
'~~> Check if we found it or not
If OpenRet <> 0 Then
'~~> Click the OK Button
SendMessage ChildRet, BM_CLICK, 0, vbNullString
Else
MsgBox "The Handle of OK Button was not found"
End If
Else
MsgBox "Button's Window Not Found"
End If
Else
MsgBox "The Edit Box was not found"
End If
Else
MsgBox "VBAProject Password Window was not Found"
End If
End Sub
Sub SendMess(Message As String, hwnd As Long)
Call SendMessage(hwnd, WM_SETTEXT, False, ByVal Message)
End Sub
#Amelie:
Ret1 = FindWindow(vbNullString, "VBAProject - Project Properties")
If Ret1 <> 0 Then
ChildRet1 = FindWindowEx(Ret1, ByVal 0&, "Button", vbNullString)
If ChildRet1 <> 0 Then
strBuff = String(GetWindowTextLength(ChildRet1) + 1, Chr$(0))
GetWindowText ChildRet1, strBuff, Len(strBuff)
ButCap = strBuff
Do While ChildRet1 <> 0
If InStr(1, ButCap, "OK") Then
OpenRet1 = ChildRet1
Exit Do
End If
ChildRet1 = FindWindowEx(Ret, ChildRet1, "Button", vbNullString)
strBuff = String(GetWindowTextLength(ChildRet1) + 1, Chr$(0))
GetWindowText ChildRet1, strBuff, Len(strBuff)
ButCap = strBuff
Loop
If OpenRet1 <> 0 Then SendMessageA OpenRet1, BM_CLICK, 0, vbNullString
End If
End If