Unlocking Password Protected VBA project - vba

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

Related

How to take screenshot of application and save it word using VBA

I have a VBA code to open the Attachmate Reflection(IBM Screen). I want to take complete screenshot of the window(like print screen) and paste the screenshot into word document.
However, I am not able to take print screen and paste it in word.
Getting "object property or method not supported" for objWord.Paste line
'Reflection screen part
Set view = frame.CreateView(terminal)
Set screen = terminal.screen
...
' word document
Private Declare PtrSafe Sub keybd_event Lib "user32" (ByVal bVk As Byte, ByVal bScan As Byte, ByVal dwFlags As Long, ByVal dwExtraInfo As Long)
Set objWord = CreateObject("Word.Application")
Set objDoc = objWord.Documents.Add
objWord.Visible = True
Set para = objDoc.Paragraphs.Add
para.Range.Text = Inp_Str & vbCrLf & vbCrLf & vbCrLf
para.Range.ParagraphFormat.SpaceAfter = 10
objDoc.Paragraphs.Add
objDoc.Paragraphs.Add.Range.Text = "Line 2 hello"
**Call keybd_event(VK_SNAPSHOT, 0, 0, 0)
'Paste into Word This paste is not working
objWord.Paste**
'quit the word application:
objWord.Quit
objWord.Paste should be changes to objWord.Selection.Paste. I also needed Sleep to give keybd_event time to copy the screenshot to the clipboard.
Test
Private Declare PtrSafe Sub keybd_event Lib "user32" (ByVal bVk As Byte, ByVal bScan As Byte, ByVal dwFlags As Long, ByVal dwExtraInfo As Long)
Private Const VK_SNAPSHOT = &H2C
Private Declare PtrSafe Function Sleep Lib "kernel32" (ByVal dwMilliseconds As Long) As Long
Sub Test()
Const Inp_Str As String = "Hello World"
Dim objWord As Object
Dim objDoc As Object
Dim para As Object
Set objWord = CreateObject("Word.Application")
Set objDoc = objWord.Documents.Add
objWord.Visible = True
Set para = objDoc.Paragraphs.Add
para.Range.Text = Inp_Str & vbCrLf & vbCrLf & vbCrLf
para.Range.ParagraphFormat.SpaceAfter = 10
objDoc.Paragraphs.Add
objDoc.Paragraphs.Add.Range.Text = "Line 2 hello"
keybd_event VK_SNAPSHOT, 0, 0, 0
Sleep 500
'Paste into Word This paste is not working
objWord.Selection.Paste
'quit the word application:
objWord.Quit
End Sub

Application send-keys highlighted in bold below does not work after shell screenshot code

Private Declare PtrSafe Sub ShowWindow Lib "user32" _
(ByVal hWnd As Long, ByVal nCmdShow As Long)
Public Declare PtrSafe Function SetForegroundWindow Lib "user32" (ByVal hWnd
As Long) As Long
Private Declare PtrSafe Sub keybd_event Lib "user32" (ByVal bVk As Byte,
ByVal _
bScan As Byte, ByVal dwFlags As Long, ByVal dwExtraInfo As Long)
Declare PtrSafe Function apiShowWindow Lib "user32" Alias "ShowWindow" _
(ByVal hWnd As Long, ByVal nCmdShow As Long) As Long
Global Const SW_MAXIMIZE = 3
Global Const SW_SHOWNORMAL = 1
Global Const SW_SHOWMINIMIZED = 2
'Declare Virtual Key Codes
Private Const VK_SNAPSHOT = &H2C
Private Const VK_KEYUP = &H2
Private Const VK_MENU = &H12
Public Const VK_TAB = &H9
Public Const VK_ENTER = &HD
Sub Automate_FAZAL_Enter_Data()
'Variables add/modify as required
Dim URL As String
Dim IE As Object
Dim HWNDSrc As Long
Dim LastRow, i, j As Integer
Dim P As Range
Dim S As Range
Dim T As String
Dim Default
Set sht = ThisWorkbook.Worksheets("Sheet3")
LastRow = sht.Cells(sht.Rows.Count, "B").End(xlUp).Row
Set sht_ELMTS = ThisWorkbook.Worksheets("Elements")
'Loop start
For j = 3 To LastRow
'Create InternetExplorer Object
Set IE = CreateObject("InternetExplorer.Application")
'
Set P = sht.Cells(j, 8)
Set N = sht.Cells(j, 9)
Set S = sht.Cells(j, 32)
MsgBox "Loop Start for " & N
'Set IE.Visible = True to make IE visible, or False for IE to run in the
background
IE.Visible = True
'Define URL
URL = "http://www.seleniumeasy.com/test/javascript-alert-box-demo.html"
apiShowWindow IE.hWnd, SW_MAXIMIZE
'Navigate to URL
IE.Navigate URL
' Statusbar tells website is loading
Application.StatusBar = URL & " is loading. Please wait..."
' Wait while IE loading...
Do While IE.ReadyState = 4: DoEvents: Loop
Do Until IE.ReadyState = 4: DoEvents: Loop
'Webpage Loaded
Application.StatusBar = URL & " Loaded"
HWNDSrc = IE.hWnd
SetForegroundWindow HWNDSrc
'some data will be entered
'=====================================================
'Section 1 second snapshot
Call keybd_event(VK_SNAPSHOT, 0, 0, 0)
Set WSH_OBJ = CreateObject("WScript.Shell")
WSH_OBJ.Run "mspaint"
Application.Wait (Now + TimeValue("00:00:03"))
WSH_OBJ.AppActivate "untitled - Paint"
Application.Wait (Now + TimeValue("00:00:03"))
Application.Wait (Now + TimeValue("00:00:03"))
'Application.SendKeys ("%{TAB}")
WSH_OBJ.SendKeys "^v"
Application.Wait (Now + TimeValue("00:00:03"))
Application.Wait (Now + TimeValue("00:00:04"))
WSH_OBJ.SendKeys "^s"
Application.Wait (Now + TimeValue("00:00:03"))
Application.Wait (Now + TimeValue("00:00:04"))
WSH_OBJ.SendKeys "C:\Sayantan\Enrollment-" & P & "-" & Replace(Replace(Replace(Now(), "/", "-"), " ", ""), ":", "") & "_" & N & "_Section1_BOTTOM_" & ".jpg"
Application.Wait (Now + TimeValue("00:00:03"))
WSH_OBJ.SendKeys "{ENTER}"
Application.Wait (Now + TimeValue("00:00:03"))
Application.Wait (Now + TimeValue("00:00:02"))
WSH_OBJ.SendKeys "%f"
Application.Wait (Now + TimeValue("00:00:03"))
Application.Wait (Now + TimeValue("00:00:02"))
WSH_OBJ.SendKeys "x"
Set WSH_OBJ = Nothing
Application.Wait (Now + TimeValue("00:00:03"))
Application.Wait (Now + TimeValue("00:00:02"))
'===============================================================
Application.Wait (Now + TimeValue("00:00:02"))
Dim e
Set e = IE.Document.GetElementsByClassName("btn btn-default btn-lg")(0)
***e.Click 'Confirmation box will appear*** THIS button activates
confimation box and user has to select ok or cancel
Application.Wait (Now + TimeValue("00:00:05"))
***Application.SendKeys "{ENTER}" 'i am trying to select ok via sendkeys
but this does not work***
IE.Quit
MsgBox "End"
Next j
'=================================================================
'Unload IE
Set IE = Nothing
End Sub
I am not sure how to click on ok without compromising existing code
this issue occurs only after the MS paint(Screenshot) code otherwise i am able to send keys to IE
Application send-keys highlighted in bold below does not work after shell screenshot code
Application send-keys highlighted in bold below does not work after shell screenshot code
If it is a normal IE popup and not a Java Web Applet or other Add-on popup you can use the following code:
These are API Calls to find a popup in IE, I have them on a separate Module.
Option Explicit
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 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 Const BM_CLICK = &HF5&
The following portion looks for a popup with the title "Message from webpage", you can change it if the popup has a different title. If it finds it, it will look for the OK Button, if it finds that, it will send the Click to it. (You can replace "OK" for "Cancel" to find and press Cancel instead).
You will replace the SendKeys ENTER with the code below.
hWND = FindWindow(vbNullString, "Message from webpage")
If hWND <> 0 Then childHWND = FindWindowEx(hWND, ByVal 0&, "Button", "OK")
If childHWND <> 0 Then SendMessage childHWND, BM_CLICK, 0, 0

UIAutomationClient elementFromPoint With VBA error "User-Defined type may not be passed ByVal"

Is there a way to use ElementfromPoint from UIAutomationClient with VBA (EXCEL)
I have always an compilation error :
"User-Defined type may not be passed ByVal"
Sub Test_ElementFromPoint()
Dim uiAuto As New UIAutomationClient.CUIAutomation8
Dim elmRibbon As UIAutomationClient.IUIAutomationElement
Dim pt As tagPOINT
pt.x = 541
pt.y = 99
Set elmRibbon = uiAuto.ElementFromPoint(pt)
MsgBox elmRibbon.CurrentName
End Sub
Well if i can't use elementfromPoint from vba i can use AccessibleObjectFromPoint from Iaccessible to start my query but with it i don't get all the information (.currentHelpText) from ElementFromIAccessible
Code 1
Public Sub Sample()
MsgBox "button", vbSystemModal
TrouveButton "Paste"
End Sub
Public Sub TrouveButton(ByVal TabName As String)
Dim uiAuto As UIAutomationClient.CUIAutomation
Dim elmRibbon As UIAutomationClient.IUIAutomationElement
Dim elmRibbonTab As UIAutomationClient.IUIAutomationElement
Dim cndProperty As UIAutomationClient.IUIAutomationCondition
Dim aryRibbonTab As UIAutomationClient.IUIAutomationElementArray
Dim ptnAcc As UIAutomationClient.IUIAutomationLegacyIAccessiblePattern
Dim accRibbon As Office.IAccessible
Dim i As Long
Set elmRibbonTab = Nothing '???
Set uiAuto = New UIAutomationClient.CUIAutomation
Set accRibbon = Application.CommandBars("Ribbon")
Set elmRibbon = uiAuto.ElementFromIAccessible(accRibbon, 0)
Set cndProperty = uiAuto.CreatePropertyCondition(UIA_ClassNamePropertyId, "NetUIRibbonButton")
Set aryRibbonTab = elmRibbon.FindAll(TreeScope_Subtree, cndProperty)
For i = 0 To aryRibbonTab.Length - 1
Debug.Print aryRibbonTab.GetElement(i).CurrentName
If aryRibbonTab.GetElement(i).CurrentName = TabName Then
Set elmRibbonTab = aryRibbonTab.GetElement(i)
Exit For
End If
Next
If elmRibbonTab Is Nothing Then Exit Sub
With elmRibbonTab
MsgBox "Name: " & .CurrentName _
& vbCr & "------------------------------------" _
& vbCr & "CurrentHelpText: " & CStr(.CurrentHelpText) , , "ui automation"
End With
End Sub
code 2
Option Explicit
Private Type POINTAPI
x As Long
Y As Long
End Type
#If VBA7 Then
Private Declare PtrSafe Function GetCursorPos Lib "user32.dll" (lpPoint As POINTAPI) As Long
Private Declare PtrSafe Function GetAsyncKeyState Lib "user32" (ByVal vKey As Long) As Integer
#If Win64 Then
Private Declare PtrSafe Function AccessibleObjectFromPoint Lib "Oleacc" (ByVal arg1 As LongPtr, ppacc As IAccessible, pvarChild As Variant) As Long
Private Declare PtrSafe Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (Destination As Any, Source As Any, ByVal Length As LongPtr)
#Else
Private Declare PtrSafe Function AccessibleObjectFromPoint Lib "Oleacc" (ByVal lX As Long, ByVal lY As Long, ppacc As IAccessible, pvarChild As Variant) As Long
#End If
#Else
Private Declare Function GetCursorPos Lib "user32" (lpPoint As POINTAPI) As Long
Private Declare Function AccessibleObjectFromPoint Lib "Oleacc" (ByVal lX As Long, ByVal lY As Long, ppacc As IAccessible, pvarChild As Variant) As Long
Private Declare Function GetAsyncKeyState Lib "user32" (ByVal vKey As Long) As Integer
#End If
Private Const CHILDID_SELF = &H0&
Private Const S_OK As Long = &H0
Sub Sample2()
'move the mouse on PASTE BUTTON
Beep
Application.OnTime DateAdd("s", 3, Now), "get_element_under_mouse"
End Sub
Private Sub get_element_under_mouse()
Dim oIA As IAccessible
Dim oCmbar As CommandBar
Dim lResult As Long
Dim tPt As POINTAPI
Dim oButton As IAccessible
GetCursorPos tPt
#If Win64 Then
Dim lngPtr As LongPtr
CopyMemory lngPtr, tPt, LenB(tPt)
lResult = AccessibleObjectFromPoint(lngPtr, oIA, 0)
#Else
lResult = AccessibleObjectFromPoint(tPt.x, tPt.Y, oIA, 0)
#End If
If lResult = S_OK Then
' On Error Resume Next
End If
Dim uiAuto As UIAutomationClient.CUIAutomation
Dim elmRibbon As UIAutomationClient.IUIAutomationElement
Dim uielmt As UIAutomationClient.IUIAutomationElement
Dim cndProperty As UIAutomationClient.IUIAutomationCondition
Dim i As Long
On Error Resume Next
Set uiAuto = New UIAutomationClient.CUIAutomation
' uiAuto.p
Set elmRibbon = uiAuto.ElementFromIAccessible(oIA, 0)
If Not elmRibbon Is Nothing Then
MsgBox "Name: " & elmRibbon.CurrentName _
& vbCr & "------------------------------------" _
& vbCr & "CurrentHelpText: " & CStr(elmRibbon.CurrentHelpText) , , "ui automation"
End If
End Sub

Saving webpage as PDF to certain directory

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

Left and right functions not working in my VBA code, expecting array?

When I run this code through Excel, it says the Left(,) function is expecting an array. I'm passing it a String, the function requires a String, the variable is declared as a String. I put the $ operator on there and it still gives me crap. Any idea what might be going on?
FWIW this executes just fine when I run it through SolidWorks.
Also, it's being called from a userform that passes it a String.
#If VBA7 Then
Declare PtrSafe Function SHGetPathFromIDList Lib "shell32.dll" _
Alias "SHGetPathFromIDListA" (ByVal pidl As Long, ByVal _
pszPath As String) As Long
Declare PtrSafe Function SHBrowseForFolder Lib "shell32.dll" _
Alias "SHBrowseForFolderA" (lpBrowseInfo As BROWSEINFO) _
As Long
#Else
Declare Function SHGetPathFromIDList Lib "shell32.dll" _
Alias "SHGetPathFromIDListA" (ByVal pidl As Long, ByVal _
pszPath As String) As Long
Declare Function SHBrowseForFolder Lib "shell32.dll" _
Alias "SHBrowseForFolderA" (lpBrowseInfo As BROWSEINFO) _
As Long
#End If
Public Type BROWSEINFO
#If VBA7 Then
hOwner As LongPtr
pidlRoot As LongPtr
pszDisplayName As String
lpszTitle As String
ulFlags As Long
lpfn As LongPtr
lParam As LongPtr
iImage As Long
#Else
hOwner As Long
pidlRoot As Long
pszDisplayName As String
lpszTitle As String
ulFlags As Long
lpfn As Long
lParam As Long
iImage As Long
#End If
End Type
Private bInfo As BROWSEINFO
Function GetDirectory(Optional Msg As String = "Select a folder.") As String
Dim path As String
Dim x As Long, pos As Integer
'dim
bInfo.pidlRoot = 0& ' Root folder = Desktop
bInfo.lpszTitle = Msg ' Dialog title
bInfo.ulFlags = &H1 ' Type of directory to return
x = SHBrowseForFolder(bInfo)
path = Space$(512)
If SHGetPathFromIDList(ByVal x, ByVal path) Then
pos = InStr(path, Chr$(0))
GetDirectory = Left(path, (pos - 1))
End If
End Function
pls try the below code , it works
Option Explicit
'32-bit API declarations
Declare Function SHGetPathFromIDList Lib "shell32.dll" _
Alias "SHGetPathFromIDListA" (ByVal pidl As Long, ByVal _
pszpath As String) As Long
Declare Function SHBrowseForFolder Lib "shell32.dll" _
Alias "SHBrowseForFolderA" (lpBrowseInfo As BrowseInfo) _
As Long
Public Type BrowseInfo
hOwner As Long
pIDLRoot As Long
pszDisplayName As String
lpszTitle As String
ulFlags As Long
lpfn As Long
lParam As Long
iImage As Long
End Type
Function GetDirectory(Optional msg) As String
On Error Resume Next
Dim bInfo As BrowseInfo
Dim path As String
Dim r As Long, x As Long, pos As Integer
'Root folder = Desktop
bInfo.pIDLRoot = 0&
'Title in the dialog
If IsMissing(msg) Then
bInfo.lpszTitle = "Please select the folder of the excel files to copy."
Else
bInfo.lpszTitle = msg
End If
'Type of directory to return
bInfo.ulFlags = &H1
'Display the dialog
x = SHBrowseForFolder(bInfo)
'Parse the result
path = Space$(512)
r = SHGetPathFromIDList(ByVal x, ByVal path)
If r Then
pos = InStr(path, Chr$(0))
GetDirectory = Left(path, pos - 1)
Else
GetDirectory = ""
End If
End Function
Sub CombineFiles()
Dim path As String
Dim FileName As String
Dim LastCell As Range
Dim Wkb As Workbook
Dim WS As Worksheet
Dim ThisWB As String
ThisWB = ThisWorkbook.Name
Application.EnableEvents = False
Application.ScreenUpdating = False
path = GetDirectory
FileName = Dir(path & "\*.xls", vbNormal)
Do Until FileName = ""
If FileName <> ThisWB Then
Set Wkb = Workbooks.Open(FileName:=path & "\" & FileName)
For Each WS In Wkb.Worksheets
Set LastCell = WS.Cells.SpecialCells(xlCellTypeLastCell)
If LastCell.Value = "" And LastCell.Address = Range("$A$1").Address Then
Else
WS.Copy After:=ThisWorkbook.Sheets(ThisWorkbook.Sheets.Count)
End If
Next WS
Wkb.Close False
End If
FileName = Dir()
Loop
Application.EnableEvents = True
Application.ScreenUpdating = True
Set Wkb = Nothing
Set LastCell = Nothing
End Sub