Protect VBAProject using VBA - excel

I have a main workbook with a lot of VBA, that collects data from other workbooks, manipulates these data, and finally writes data output to a new workbook that itself holds some VBA. This output workbook is sent to many people that should NOT be able to change nor see the VBA.
Therefore I have to lock the VBAProject from viewing. Since the users of my main workbook have no VBA skills at all, I would not have them locking the VBAProject (in the VBA editor: Menu Tools / VBAProject Properties... / Protection / Lock project for viewing / etc.). I would rather lock the VBAProject using VBA.
I have seen this done by several SendKeys. However, I do not like using SendKeys. Instead I do prefer 'real' VBA - but how to do it? Perhaps by using some Windows API functions? - which I am not at all familiar with, but can use if I just have to copy/paste some code. ;-)

Finally, I made the solution shown below. It will run on Excel 64 bit, but probably it can easily be changed to 32 bit (see suggestions in the code). I have tested it on Excel 2016.
' Helge V. Larsen (MSc, PhD)
' Helge#Engfred.dk
' HELA Consulting
' January 2022.
' Regarding Windows API: Very much inspired by the late Howard Kaikow:
' http://www.standards.com/Office/SetVBAProjectPassword.html
'
' Author: Howard Kaikow
' URL : http://www.standards.com/
' Email : kaikow#standards.com
' Date : April 2005
' This will run in Excel 64 bit.
' It will probably run in Excel 32 bit
' if you remove all "PtrSafe" and change all "LongPtr" to "Long".
' (I cannot test it since I do not have access to Exccel 32 bit.)
'
' Alternatively, you could use compiler directives
' #If VBA7 Then
' #Else
' #End If
' to make it run in Excel 32 and 64 bit .
Option Explicit
' API constants
Private Const BM_CLICK As Long = &HF5&
Private Const BM_SETCHECK As Long = &HF1&
Private Const BST_CHECKED As Long = &H1&
Private Const EM_REPLACESEL As Long = &HC2&
Private Const HWND_TOPMOST As Long = -1
Private Const SWP_NOACTIVATE As Long = &H10&
Private Const SWP_NOMOVE As Long = &H2&
Private Const SWP_NOSIZE As Long = &H1&
Private Const SWP_SHOWWINDOW As Long = &H40&
Private Const TCM_SETCURFOCUS As Long = &H1330&
' API functions and subs
Private Declare PtrSafe Function EnumChildWindows Lib "user32" _
(ByVal hWndParent As LongPtr, ByVal lpEnumFunc As LongPtr, ByVal lParam As Long) As Long
Private Declare PtrSafe Function FindWindow Lib "user32" Alias "FindWindowA" _
(ByVal lpClassName As String, ByVal lpWindowName As String) As Long
Private Declare PtrSafe Function GetDlgItem Lib "user32.dll" _
(ByVal hDlg As LongPtr, ByVal nIDDlgItem As Long) As Long
Private Declare PtrSafe Function SendMessage Lib "user32" Alias "SendMessageA" _
(ByVal hWnd As Long, ByVal wMsg As Long, ByVal wParam As Long, lParam As Any) As Long
Private Declare PtrSafe Function SetFocusAPI Lib "user32" Alias "SetFocus" _
(ByVal hWnd As Long) As Long
Private Declare PtrSafe Sub SetWindowPos Lib "user32" (ByVal hWnd As Long, ByVal hWndInsertAfter As Long, _
ByVal X As Long, ByVal Y As Long, ByVal cx As Long, ByVal cy As Long, ByVal wFlags As Long)
Private hWndProjectProperties As LongPtr
Sub HVL_Lock_VBProject()
' Protect VBProject in workbook.
' The workbook is opened in another instance of Excel.
Dim appExcel As Excel.Application
Dim wbkExcel As Excel.Workbook
Dim aFile As String
Dim Pass As String
aFile = HVL_GetFile_Dialog("Browse for Excel workbook", ThisWorkbook.Path, "Excel files, *.xl*,")
If aFile = vbNullString Then Exit Sub
Set appExcel = New Excel.Application
appExcel.Visible = False
Set wbkExcel = appExcel.Workbooks.Open(aFile)
If wbkExcel.VBProject.Protection = vbext_pp_none Then
Pass = HVL_Get_PassWord
If Pass = vbNullString Then GoTo Exit_Sub
SetPassword wbkExcel.VBProject, Pass
Else ' vbext_pp_locked
MsgBox "The VBproject in" & vbCr & _
aFile & vbCr & _
"is protected." & vbCr & vbCr & _
"Cannot change Project Password.", _
vbInformation, _
"Information"
GoTo Exit_Sub
End If
wbkExcel.Save
wbkExcel.Close False
MsgBox "The VBproject in" & vbCr & _
aFile & vbCr & _
"has been locked.", _
vbInformation, _
"Information"
Exit_Sub:
appExcel.Quit
Set appExcel = Nothing
Set wbkExcel = Nothing
End Sub
Sub SetPassword(ByRef aVBProject As VBProject, ByVal strPassword As String)
' Author: Howard Kaikow
' URL : http://www.standards.com/
' Email : kaikow#standards.com
' Date : April 2005
' spy++ was used to find the Control IDs in Project Properties dialog
' Changed by Helge V. Larsen.
Const ControlIDConfirmPassword As Long = &H1556&
Const ControlIDLockProject As Long = &H1557&
Const ControlIDOK As Long = &H1&
Const ControlIDPassword As Long = &H1555&
Const ControlIDSysTabControl32 As Long = &H3020&
Dim Ctrl As Office.CommandBarControl
Dim hWnd As Long
Dim hWndLockProject As Long
Dim hWndPassword As Long
Dim hWndConfirmPassword As Long
Dim hWndOK As Long
Dim hWndSysTabControl32 As Long
Dim strCaption As String
With aVBProject
strCaption = .Name & " - Project Properties"
With .VBE
' Find Project Properties dialog
Set Ctrl = .CommandBars.FindControl(ID:=2578)
' Display Project Properties dialog
Ctrl.Execute
Set Ctrl = Nothing
End With
End With
' Get hWnd for Project Properties dialog
hWndProjectProperties = FindWindow(vbNullString, strCaption)
If hWndProjectProperties = 0 Then
Exit Sub
End If
' Get hWnd for OK button in Project Properties dialog
hWndOK = GetDlgItem(hWndProjectProperties, ControlIDOK)
' Get hWnd for Tab Control in Project Properties dialog
hWndSysTabControl32 = GetDlgItem(hWndProjectProperties, ControlIDSysTabControl32)
'Move to Protection tab
SendMessage hWndSysTabControl32, TCM_SETCURFOCUS, 1, ByVal 0&
' Must reset hWndProjectProperties probably because tab changed.
EnumChildWindows ByVal hWndProjectProperties, AddressOf EnumChildProc, ByVal 0
' Get hWnd for Password Edit control in Project Properties dialog
hWndPassword = GetDlgItem(hWndProjectProperties, ControlIDPassword)
' Get hWnd for Confirm Password Edit control in Project Properties dialog
hWndConfirmPassword = GetDlgItem(hWndProjectProperties, ControlIDConfirmPassword)
' Get hWnd for Lock Project checkbox control in Project Properties dialog
hWndLockProject = GetDlgItem(hWndProjectProperties, ControlIDLockProject)
' Lock project for &viewing
SendMessage hWndLockProject, BM_SETCHECK, BST_CHECKED, 0
' &Password
SendMessage hWndPassword, EM_REPLACESEL, vbTrue, ByVal strPassword
' &Confirm password
SendMessage hWndConfirmPassword, EM_REPLACESEL, vbTrue, ByVal strPassword
'OK button
SetFocusAPI hWndOK
SendMessage hWndOK, BM_CLICK, 0&, 0&
End Sub
Function EnumChildProc(ByVal hWnd As LongPtr, ByVal lParam As Long) As Long
hWndProjectProperties = hWnd
' Do not recurse
EnumChildProc = 0
End Function
Function HVL_GetFile_Dialog(Optional DialogTitle As String, _
Optional InitDirectory As String, _
Optional Filter As String, _
Optional InitView As Office.MsoFileDialogView = msoFileDialogViewDetails) As String
' Filter: e.g. "Data bases, *.mdb; *.accdb"
Dim Filter_Arr As Variant
Dim ViewType As Office.MsoFileDialogView
With Application.FileDialog(msoFileDialogFilePicker)
.InitialView = InitView
.AllowMultiSelect = False
If DialogTitle <> vbNullString Then .Title = DialogTitle
If Dir(InitDirectory, vbDirectory) <> vbNullString Then
.InitialFileName = InitDirectory
Else
.InitialFileName = CurDir
End If
If Filter <> vbNullString Then
Filter_Arr = Split(Filter, ",")
.Filters.Add Trim(Filter_Arr(0)), Trim(Filter_Arr(1)), 1
End If
If .Show = True Then
HVL_GetFile_Dialog = .SelectedItems(1)
Else
HVL_GetFile_Dialog = vbNullString
End If
End With
End Function
Function HVL_Get_PassWord()
Dim Pass1 As String
Dim Pass2 As String
Pass1 = InputBox("Enter VBproject password:", "Lock VBroject")
If Pass1 = vbNullString Then GoTo No_Password
Pass2 = InputBox("Caution: If you loose or forget the password," & vbCr & _
"it cannot be recovered. It is advisable to keep" & vbCr & _
"a list of passwords and their corresponding" & vbCr & _
"workbook names in a safe place." & vbCr & _
"(Remember that passwords are case-sensitive.)" & vbCr & vbCr & _
"Confirm VBproject password:", _
"Lock VBproject")
If Pass2 = vbNullString Then GoTo No_Password
If Pass1 <> Pass2 Then
MsgBox "Confirmation password is not identical!", vbCritical, "Error"
GoTo No_Password
End If
HVL_Get_PassWord = Pass1
Exit Function
No_Password:
HVL_Get_PassWord = vbNullString
End Function

Related

Automatically Download PDF Links to Desktop Folder

I have code that loops through a list of hyperlinks in Excel and batch downloads these links as PDFs.
Sometimes they save to my desktop, documents, or another file path.
I would like them saved to a designated folder on my desktop named "PDFs."
Declare PtrSafe Function URLDownloadToFile _
Lib "urlmon" Alias "URLDownloadToFileA" _
(ByVal pCaller As Long, ByVal szURL As String, _
ByVal szFileName As String, ByVal dwReserved As Long, ByVal lpfnCB As Long) As Long
Function DownloadFile(URL As String, LocalFilename As String) As Boolean
Dim lngRetVal As Long
lngRetVal = URLDownloadToFile(0, URL, LocalFilename, 0, 0)
If lngRetVal = 0 Then DownloadFile = True
End Function
Sub DownloadPDFs()
Dim StartRowNum As Long
Dim EndRowNum As Long
Dim pdfname As String
Dim RecordNum As String
Dim URLprefix As String
LastRowPDF = Sheet1.Cells(Rows.Count, "B").End(xlUp).Row
For i = 2 To LastRowPDF
Application.ScreenUpdating = False
URLprefix = Sheet1.Cells(i, 2)
RecordNum = Sheet1.Cells(i, 3)
pdfname = RecordNum & ".pdf"
URL = URLprefix
DownloadFile URLprefix, pdfname
Application.ScreenUpdating = True
Next i
End Sub
How do I save to a specific folder path?
This is the method I use and it works well, especially if you may need to use the file on multiple computers where the user profile may change, for example sending to others to execute the print operation or printing from another desktop. This method does not set a static path specific to your PC, but rather a path according to the PC it is being run on. A more flexible solution.
'Set Filename
pdfname = Environ("UserProfile") & "\Desktop\PDFs\" & RecordNum & ".pdf"

How can I print list pdf file with name them in column excel?

I want to print the list pdf file which it have name in 1 column of excel .
I don't want to hold the button Ctrl and find name of it one by one in column of excel and choose those file . Because may be have a lot of file . Find one by one take a lot of time.
For example with the image above.
What software can support for me do this ? Or have to I do any thing to done this problem ???.
Thank you for read my post !!!
This should work:
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 Function PrintPDF(xlHwnd As Long, FileName As String) As Boolean
Dim X As Long
On Error Resume Next
X = ShellExecute(xlHwnd, "Print", FileName, 0&, 0&, 3)
If Err.Number > 0 Then
MsgBox Err.Number & ": " & Err.Description
PrintPDF = False
Else
PrintPDF = True
End If
On Error GoTo 0
End Function
Sub PrintSpecificPDF()
'opens the specified pdf and prints it using the default printer
'note that it uses the default PDF program and leaves it open
Dim strPth As String, strFile As String
Dim rngList As Range, rngTarget As Range
Set rngList = Range(Range("B2"), Range("B1").End(xlDown))
strPth = "D:\PDF\"
For Each rngTarget In rngList
strFile = rngTarget.Value & ".pdf"
If Not PrintPDF(0, strPth & strFile) Then
MsgBox "Printing failed"
End If
Next
End Sub
I've taken this code and slightly modified it according to your case.

Open PDF file and copy filepath and print pages VBA

I currently have a macro that loops through a list and finds PDF files based on keywords. The macro works as it should, but I would like to take it a bit further. The macro searches for the correct PDF based on the report number per item.
I would like to loop and:
Hyperlink the file in the column "M".
Check if the file was opened correctly and place the status in column "K"
Minimize all open PDF windows.
If possible, find the Item number within the PDF and it's corresponding page. Each page is also bookmarked with the item number so it could be searched that way as well. I would like to somehow print the correct pages.
There are hundreds of reports and it is a very tedious process. I also have Adobe Pro. I am open to all suggestions.
Current working code to find PDF based on wildcard:
`Sub Open_PDF()
Dim filePath As String, fileName As String, iName As String
Dim lrow As Long
Dim i As Long
lrow = Cells(Rows.Count, 10).End(xlUp).Row
For i = 5 To lrow
iName = Cells(i, 10)
FileType = Range("FileType")
filePath = Range("B6")
fileName = Dir(filePath & iName & "*" & "." & FileType)
If fileName <> "" Then
openAnyFile filePath & fileName
End If
Next i
End Sub
Function openAnyFile(strPath As String)
Dim objShell As Object
Set objShell = CreateObject("Shell.Application")
objShell.Open (strPath)
End Function
`
I found the following codes, but could not understand how to get it to work.
Option Explicit
'Retrieves a handle to the top-level window whose class name and window name match the
specified strings.
'This function does not search child windows. This function does not perform a case-
sensitive search.
Public Declare Function FindWindow Lib "user32" Alias "FindWindowA" _
(ByVal lpClassName As String, ByVal lpWindowName As String) As Long
`'Retrieves a handle to a window whose class name and window name match the specified
strings.
'The function searches child windows, beginning with the one following the specified
child window.
'This function does not perform a case-sensitive search.
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
'Brings the thread that created the specified window into the foreground and activates
the window.
'Keyboard input is directed to the window, and various visual cues are changed for the
user.
'The system assigns a slightly higher priority to the thread that created the
foreground
'window than it does to other threads.
Public Declare Function SetForegroundWindow Lib "user32" (ByVal hwnd As Long) As Long
'Sends the specified message to a window or windows. The SendMessage function calls
the window procedure
'for the specified window and does not lParenturn until the window procedure has
processed the message.
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
'Places (posts) a message in the message queue associated with the thread that created
the specified
'window and lParenturns without waiting for the thread to process the message.
Public Declare Function PostMessage Lib "user32.dll" Alias "PostMessageA" _
(ByVal hwnd As Long, ByVal wMsg As Long, ByVal wParam As Long, ByVal lParam As Long)
As Long
'Constants used in API functions.
Public Const WM_SETTEXT = &HC
Public Const VK_RETURN = &HD
Public Const WM_KEYDOWN = &H100
Private Sub OpenPDF(strPDFPath As String, strPageNumber As String, strZoomValue As String)
'Opens a PDF file to a specific page and with a specific zoom
'using Adobe Reader Or Adobe Professional.
'API functions are used to specify the necessary windows
'and send the page and zoom info to the Adobe window.
'By Christos Samaras
'https://myengineeringworld.net/////
Dim strPDFName As String
Dim lParent As Long
Dim lFirstChildWindow As Long
Dim lSecondChildFirstWindow As Long
Dim lSecondChildSecondWindow As Long
Dim dtStartTime As Date
'Check if the PDF path is correct.
If FileExists(strPDFPath) = False Then
MsgBox "The PDF path is incorect!", vbCritical, "Wrong path"
Exit Sub
End If
'Get the PDF file name from the full path.
On Error Resume Next
strPDFName = Mid(strPDFPath, InStrRev(strPDFPath, "") + 1, Len(strPDFPath))
On Error GoTo 0
'The following line depends on the apllication you are using.
'For Word:
'ThisDocument.FollowHyperlink strPDFPath, NewWindow:=True
'For Power Point:
'ActivePresentation.FollowHyperlink strPDFPath, NewWindow:=True
'Note that both Word & Power Point pop up a security window asking
'for access to the specified PDf file.
'For Access:
'Application.FollowHyperlink strPDFPath, NewWindow:=True
'For Excel:
ThisWorkbook.FollowHyperlink strPDFPath, NewWindow:=True
'Find the handle of the main/parent window.
dtStartTime = Now()
Do Until Now() > dtStartTime + TimeValue("00:00:05")
lParent = 0
DoEvents
'For Adobe Reader.
'lParent = FindWindow("AcrobatSDIWindow", strPDFName & " - Adobe Reader")
'For Adobe Professional.
lParent = FindWindow("AcrobatSDIWindow", strPDFName & " - Adobe Acrobat Pro")
If lParent <> 0 Then Exit Do
Loop
If lParent <> 0 Then
'Bring parent window to the foreground (above other windows).
SetForegroundWindow (lParent)
'Find the handle of the first child window.
dtStartTime = Now()
Do Until Now() > dtStartTime + TimeValue("00:00:05")
lFirstChildWindow = 0
DoEvents
lFirstChildWindow = FindWindowEx(lParent, ByVal 0&, vbNullString, "AVUICommandWidget")
If lFirstChildWindow <> 0 Then Exit Do
Loop
'Find the handles of the two subsequent windows.
If lFirstChildWindow <> 0 Then
dtStartTime = Now()
Do Until Now() > dtStartTime + TimeValue("00:00:05")
lSecondChildFirstWindow = 0
DoEvents
lSecondChildFirstWindow = FindWindowEx(lFirstChildWindow, ByVal 0&, "Edit", vbNullString)
If lSecondChildFirstWindow <> 0 Then Exit Do
Loop
If lSecondChildFirstWindow <> 0 Then
'Send the zoom value to the corresponding window.
SendMessage lSecondChildFirstWindow, WM_SETTEXT, 0&, ByVal strZoomValue
PostMessage lSecondChildFirstWindow, WM_KEYDOWN, VK_RETURN, 0
dtStartTime = Now()
Do Until Now() > dtStartTime + TimeValue("00:00:05")
lSecondChildSecondWindow = 0
DoEvents
'Notice the difference in syntax between lSecondChildSecondWindow and lSecondChildFirstWindow.
'lSecondChildSecondWindow is the handle of the next child window after lSecondChildFirstWindow,
'while both windows have as parent window the lFirstChildWindow.
lSecondChildSecondWindow = FindWindowEx(lFirstChildWindow, lSecondChildFirstWindow, "Edit", vbNullString)
If lSecondChildSecondWindow <> 0 Then Exit Do
Loop
If lSecondChildSecondWindow <> 0 Then
'Send the page number to the corresponding window.
SendMessage lSecondChildSecondWindow, WM_SETTEXT, 0&, ByVal strPageNumber
PostMessage lSecondChildSecondWindow, WM_KEYDOWN, VK_RETURN, 0
End If
End If
End If
End If
End Sub
Function FileExists(strFilePath As String) As Boolean
'Checks if a file exists.
'By Christos Samaras
'https://myengineeringworld.net/////
On Error Resume Next
If Not Dir(strFilePath, vbDirectory) = vbNullString Then FileExists = True
On Error GoTo 0
End Function
Sub TestPDF()
OpenPDF ThisWorkbook.Path & "" & "Sample File.pdf", 6, 143
End Sub
I can partially help you:
Sub Open_PDF()
Dim filePath As String, fileName As String, iName, disptxt As String
Dim lrow As Long
Dim i As Long
Dim wb As Workbook: Set wb = ThisWorkbook
Dim ws As Worksheet: Set ws = wb.Worksheets("Sheet1")
lrow = Cells(Rows.Count, 10).End(xlUp).Row
For i = 5 To lrow
iName = Cells(i, 10)
FileType = Range("FileType")
filePath = Range("B6")
fileName = Dir(filePath & iName & "*" & "." & FileType)
If fileName <> "" Then
disptxt = filePath & iName ' whatever you want the hyperlink to show
ws.Hyperlinks.Add Anchor:=ws.Range("M" & i), Address:=filePath & fileName, ScreenTip:="hover message", TextToDisplay:=disptxt
Range("K" & i) = "Success"
openAnyFile filePath & fileName
Else
Range("K" & i) = "Failed"
End If
Next i
End Sub

VBA - choose save as from the frame notification bar of internet explorer

I am trying to download a file with save as through the frame notification bar of internet explorer.
However after doing a lot of searches, I have only found solutions to click save on the frame notification bar.
So far I have been trying to save as the file on the sample site:
http://www.tvsubtitles.net/subtitle-114117.html
with the following code:
' Add referenses
' Microsoft Internet Controls
' Microsoft HTML Object Library
' UIAutomationClient (copy file from C:\Windows\System32\UIAutomationCore.dll to Documents Folder)
#If VBA7 Then
Private Declare PtrSafe Function FindWindowEx _
Lib "user32" _
Alias "FindWindowExA" ( _
ByVal hWnd1 As LongPtr, _
ByVal hWnd2 As LongPtr, _
ByVal lpsz1 As String, _
ByVal lpsz2 As String) _
As LongPtr
#Else
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
#End If
Sub downloadfilefromeie()
Dim subpage As InternetExplorer
Dim objpage As HTMLDocument
Dim o As CUIAutomation
Dim h As LongPtr
Dim fnb As LongPtr
Dim e As IUIAutomationElement
Dim iCnd As IUIAutomationCondition
Dim Button As IUIAutomationElement
Dim InvokePattern As IUIAutomationInvokePattern
Dim strBuff As String
Dim ButCap As String
Set objshell = CreateObject("Shell.Application")
Set objallwindows = objshell.Windows
Set subpage = New InternetExplorer
For Each ow In objallwindows
'MsgBox ow
If (InStr(1, ow, "Internet Explorer", vbTextCompare)) Then
'MsgBox ow.Hwnd & " " & ow & " " & ow.locationURL
If (InStr(1, ow.locationURL, "tvsub", vbTextCompare)) Then
Set subpage = ow
End If
End If
Next
Set objpage = New HTMLDocument
If subpage Is Nothing Then
Else
Set objpage = subpage.Document
'Debug.Print objpage
'objpage.getElementById("content").Click
Set dl = objpage.getElementsbyclassname("subtable")
Set dltable = dl(0).FirstChild.ChildNodes
Set dlrow = dltable(10).getElementsByTagName("a")(2)
dlrow.Click
While objpage.ReadyState <> "complete"
DoEvents
Wend
End If
Application.Wait (Now() + TimeValue("0:00:05"))
Set o = New CUIAutomation
h = subpage.Hwnd
fnb = FindWindowEx(h, 0, "Frame Notification Bar", vbNullString)
If fnb = 0 Then Exit Sub
'Debug.Print "type of fnb is " & TypeName(fnb)
Set e = o.ElementFromHandle(ByVal fnb)
'Debug.Print "type of e is " & TypeName(e)
Set iCnd = o.CreatePropertyCondition(UIA_NamePropertyId, "Save")
Set Button = e.FindFirst(TreeScope_Subtree, iCnd)
'Debug.Print "type of Button is " & TypeName(Button)
Set InvokePattern = Button.GetCurrentPattern(UIA_InvokePatternId)
'Debug.Print "type of InvokePattern is " & TypeName(InvokePattern)
InvokePattern.Invoke
End Sub
I have tried changing "Save" to "Save as" but it doesn't work. My guess is that I need to somehow be able to click on the arrow on the split button first before accessing to the save as button but I have had no success in doing it.
Gladly appreciate it if someone can offer a solution.
I tried simply to download a file by the link http://www.tvsubtitles.net/download-114117.html, which can be found on the webpage http://www.tvsubtitles.net/subtitle-114117.html, and it worked for me, here is the code:
Sub Test_download_tvsubtitles_net()
DownloadFile "http://www.tvsubtitles.net/download-114117.html", ThisWorkbook.Path & "\download-114117.zip"
End Sub
Sub DownloadFile(sUrl, sPath)
Dim aBody
With CreateObject("MSXML2.XMLHTTP")
.Open "GET", sUrl, False
.Send
aBody = .responseBody
End With
With CreateObject("ADODB.Stream")
.Type = 1 ' adTypeBinary
.Open
.Write aBody
.SaveToFile sPath, 2 ' adSaveCreateOverWrite
.Close
End With
End Sub

Excel VBA - Change cell value in another excel window [duplicate]

Can an Excel VBA macro, running in one instance of Excel, access the workbooks of another running instance of Excel? For example, I would like to create a list of all workbooks that are open in any running instance of Excel.
Cornelius' answer is partially correct. His code gets the current instance and then makes a new instance. GetObject only ever gets the first instance, no matter how many instances are available. The question I believe is how can you get a specific instance from among many instances.
For a VBA project, make two modules, one code module, and the other as a form with one command button named Command1. You might need to add a reference to Microsoft.Excel.
This code displays all the name of each workbook for each running instance of Excel in the Immediate window.
'------------- Code Module --------------
Option Explicit
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
Declare Function GetClassName Lib "User32" Alias "GetClassNameA" (ByVal hWnd As Long, ByVal lpClassName As String, ByVal nMaxCount As Long) As Long
Declare Function IIDFromString Lib "ole32" (ByVal lpsz As Long, ByRef lpiid As UUID) As Long
Declare Function AccessibleObjectFromWindow Lib "oleacc" (ByVal hWnd As Long, ByVal dwId As Long, ByRef riid As UUID, ByRef ppvObject As Object) As Long
Type UUID 'GUID
Data1 As Long
Data2 As Integer
Data3 As Integer
Data4(7) As Byte
End Type
'------------- Form Module --------------
Option Explicit
Const IID_IDispatch As String = "{00020400-0000-0000-C000-000000000046}"
Const OBJID_NATIVEOM As Long = &HFFFFFFF0
'Sub GetAllWorkbookWindowNames()
Sub Command1_Click()
On Error GoTo MyErrorHandler
Dim hWndMain As Long
hWndMain = FindWindowEx(0&, 0&, "XLMAIN", vbNullString)
Do While hWndMain <> 0
GetWbkWindows hWndMain
hWndMain = FindWindowEx(0&, hWndMain, "XLMAIN", vbNullString)
Loop
Exit Sub
MyErrorHandler:
MsgBox "GetAllWorkbookWindowNames" & vbCrLf & vbCrLf & "Err = " & Err.Number & vbCrLf & "Description: " & Err.Description
End Sub
Private Sub GetWbkWindows(ByVal hWndMain As Long)
On Error GoTo MyErrorHandler
Dim hWndDesk As Long
hWndDesk = FindWindowEx(hWndMain, 0&, "XLDESK", vbNullString)
If hWndDesk <> 0 Then
Dim hWnd As Long
hWnd = FindWindowEx(hWndDesk, 0, vbNullString, vbNullString)
Dim strText As String
Dim lngRet As Long
Do While hWnd <> 0
strText = String$(100, Chr$(0))
lngRet = GetClassName(hWnd, strText, 100)
If Left$(strText, lngRet) = "EXCEL7" Then
GetExcelObjectFromHwnd hWnd
Exit Sub
End If
hWnd = FindWindowEx(hWndDesk, hWnd, vbNullString, vbNullString)
Loop
On Error Resume Next
End If
Exit Sub
MyErrorHandler:
MsgBox "GetWbkWindows" & vbCrLf & vbCrLf & "Err = " & Err.Number & vbCrLf & "Description: " & Err.Description
End Sub
Public Function GetExcelObjectFromHwnd(ByVal hWnd As Long) As Boolean
On Error GoTo MyErrorHandler
Dim fOk As Boolean
fOk = False
Dim iid As UUID
Call IIDFromString(StrPtr(IID_IDispatch), iid)
Dim obj As Object
If AccessibleObjectFromWindow(hWnd, OBJID_NATIVEOM, iid, obj) = 0 Then 'S_OK
Dim objApp As Excel.Application
Set objApp = obj.Application
Debug.Print objApp.Workbooks(1).Name
Dim myWorksheet As Worksheet
For Each myWorksheet In objApp.Workbooks(1).Worksheets
Debug.Print " " & myWorksheet.Name
DoEvents
Next
fOk = True
End If
GetExcelObjectFromHwnd = fOk
Exit Function
MyErrorHandler:
MsgBox "GetExcelObjectFromHwnd" & vbCrLf & vbCrLf & "Err = " & Err.Number & vbCrLf & "Description: " & Err.Description
End Function
I believe that VBA is more powerful than Charles thinks ;)
If there is only some tricky way to point to the specific instance from GetObject and CreateObject we'll have your problem solved!
EDIT:
If you're the creator of all the instances there should be no problems with things like listing workbooks. Take a look on this code:
Sub Excels()
Dim currentExcel As Excel.Application
Dim newExcel As Excel.Application
Set currentExcel = GetObject(, "excel.application")
Set newExcel = CreateObject("excel.application")
newExcel.Visible = True
newExcel.Workbooks.Add
'and so on...
End Sub
I think that within VBA you can get access to the application object in another running instance. If you know the name of a workbook open within the other instance, then you can get a reference to the application object. See Allen Waytt's page
The last part,
Dim xlApp As Excel.Application
Set xlApp = GetObject("c:\mypath\ExampleBook.xlsx").Application
Allowed me to get a pointer to the application object of the instance that had ExampleBook.xlsx open.
I believe "ExampleBook" needs to be the full path, at least in Excel 2010. I'm currently experimenting with this myself, so I will try and update as I get more details.
Presumably there may be complications if separate instances have the same workbook open, but only one may have write access.
Thanks to this great post I had a routine to find return an array of all Excel applications currently running on the machine. Trouble is that I've just upgraded to Office 2013 64 bit and it all went wrong.
There is the usual faff of converting ... Declare Function ... into ... Declare PtrSafe Function ..., which is well documented elsewhere. However, what I couldn't find any documentation on is that fact that the window hierarchy ('XLMAIN' -> 'XLDESK' -> 'EXCEL7') that the original code expects has changed following this upgrade. For anyone following in my footsteps, to save you an afternoon of digging around, I thought I'd post my updated script. It's hard to test, but I think it should be backwards compatible too for good measure.
Option Explicit
#If Win64 Then
Private Declare PtrSafe Function FindWindowEx Lib "user32" Alias "FindWindowExA" (ByVal hWnd1 As LongPtr, ByVal hWnd2 As LongPtr, ByVal lpsz1 As String, ByVal lpsz2 As String) As LongPtr
Private Declare PtrSafe Function GetClassName Lib "user32" Alias "GetClassNameA" (ByVal Hwnd As LongPtr, ByVal lpClassName As String, ByVal nMaxCount As LongPtr) As LongPtr
Private Declare PtrSafe Function IIDFromString Lib "ole32" (ByVal lpsz As LongPtr, ByRef lpiid As UUID) As LongPtr
Private Declare PtrSafe Function AccessibleObjectFromWindow Lib "oleacc" (ByVal Hwnd As LongPtr, ByVal dwId As LongPtr, ByRef riid As UUID, ByRef ppvObject As Object) As LongPtr
#Else
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 GetClassName Lib "user32" Alias "GetClassNameA" (ByVal hwnd As Long, ByVal lpClassName As String, ByVal nMaxCount As Long) As Long
Private Declare Function IIDFromString Lib "ole32" (ByVal lpsz As Long, ByRef lpiid As UUID) As Long
Private Declare Function AccessibleObjectFromWindow Lib "oleacc" (ByVal hwnd As Long, ByVal dwId As Long, ByRef riid As UUID, ByRef ppvObject As Object) As Long
#End If
Type UUID 'GUID
Data1 As Long
Data2 As Integer
Data3 As Integer
Data4(7) As Byte
End Type
Const IID_IDispatch As String = "{00020400-0000-0000-C000-000000000046}"
Const OBJID_NATIVEOM As LongPtr = &HFFFFFFF0
' Run as entry point of example
Public Sub Test()
Dim i As Long
Dim xlApps() As Application
If GetAllExcelInstances(xlApps) Then
For i = LBound(xlApps) To UBound(xlApps)
If xlApps(i).Workbooks(1).Name <> ThisWorkbook.Name Then
MsgBox (xlApps(i).Workbooks(1).Name)
End If
Next
End If
End Sub
' Actual public facing function to be called in other code
Public Function GetAllExcelInstances(xlApps() As Application) As Long
On Error GoTo MyErrorHandler
Dim n As Long
#If Win64 Then
Dim hWndMain As LongPtr
#Else
Dim hWndMain As Long
#End If
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
Set app = GetExcelObjectFromHwnd(hWndMain)
If Not (app Is Nothing) Then
If n = 0 Then
n = n + 1
Set xlApps(n) = app
ElseIf checkHwnds(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
Exit Function
MyErrorHandler:
MsgBox "GetAllExcelInstances" & vbCrLf & vbCrLf & "Err = " & Err.Number & vbCrLf & "Description: " & Err.Description
End Function
#If Win64 Then
Private Function checkHwnds(xlApps() As Application, Hwnd As LongPtr) As Boolean
#Else
Private Function checkHwnds(xlApps() As Application, Hwnd As Long) As Boolean
#End If
Dim i As Integer
For i = LBound(xlApps) To UBound(xlApps)
If xlApps(i).Hwnd = Hwnd Then
checkHwnds = False
Exit Function
End If
Next i
checkHwnds = True
End Function
#If Win64 Then
Private Function GetExcelObjectFromHwnd(ByVal hWndMain As LongPtr) As Application
#Else
Private Function GetExcelObjectFromHwnd(ByVal hWndMain As Long) As Application
#End If
On Error GoTo MyErrorHandler
#If Win64 Then
Dim hWndDesk As LongPtr
Dim Hwnd As LongPtr
#Else
Dim hWndDesk As Long
Dim Hwnd As Long
#End If
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 GetExcelObjectFromHwnd = obj.Application
Exit Function
End If
End If
Hwnd = FindWindowEx(hWndDesk, Hwnd, vbNullString, vbNullString)
Loop
On Error Resume Next
End If
Exit Function
MyErrorHandler:
MsgBox "GetExcelObjectFromHwnd" & vbCrLf & vbCrLf & "Err = " & Err.Number & vbCrLf & "Description: " & Err.Description
End Function
I had a similar problem/goal.
And I got ForEachLoops answer working, but there is a change that needs made.
In the bottom function (GetExcelObjectFromHwnd), he used the workbook index of 1 in both debug.print commands. The result is you only see the first WB.
So I took his code, and put a for loop inside GetExcelObjectFromHwnd, and changed the 1 to a counter. the result is I can get ALL active excel workbooks and return the information I need to reach across instances of Excel and access other WB's.
And I created a Type to simplify retrieving of the info and pass it back to the calling subroutine:
Type TargetWBType
name As String
returnObj As Object
returnApp As Excel.Application
returnWBIndex As Integer
End Type
For name I simply used the base filename, e.g. "example.xls". This snippet proves the functionality by spitting out the value of A6 on every WS of the target WB. Like so:
Dim targetWB As TargetWBType
targetWB.name = "example.xls"
Call GetAllWorkbookWindowNames(targetWB)
If Not targetWB.returnObj Is Nothing Then
Set targetWB.returnApp = targetWB.returnObj.Application
Dim ws As Worksheet
For Each ws In targetWB.returnApp.Workbooks(targetWB.returnWBIndex).Worksheets
MsgBox ws.Range("A6").Value
Next
Else
MsgBox "Target WB Not found"
End If
So now the ENTIRE module that ForEachLoop originally made looks like this, and I've indicated the changes I made. It does have a msgbox popup, whcih I left in the snippet for debugging purposes. Strip that out once it's finding your target. The code:
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
Declare Function GetClassName Lib "User32" Alias "GetClassNameA" (ByVal hWnd As Long, ByVal lpClassName As String, ByVal nMaxCount As Long) As Long
Declare Function IIDFromString Lib "ole32" (ByVal lpsz As Long, ByRef lpiid As UUID) As Long
Declare Function AccessibleObjectFromWindow Lib "oleacc" (ByVal hWnd As Long, ByVal dwId As Long, ByRef riid As UUID, ByRef ppvObject As Object) As Long
Type UUID 'GUID
Data1 As Long
Data2 As Integer
Data3 As Integer
Data4(7) As Byte
End Type
'------------- Form Module --------------
Option Explicit
Const IID_IDispatch As String = "{00020400-0000-0000-C000-000000000046}"
Const OBJID_NATIVEOM As Long = &HFFFFFFF0
'My code: added targetWB
Sub GetAllWorkbookWindowNames(targetWB As TargetWBType)
On Error GoTo MyErrorHandler
Dim hWndMain As Long
hWndMain = FindWindowEx(0&, 0&, "XLMAIN", vbNullString)
Do While hWndMain <> 0
GetWbkWindows hWndMain, targetWB 'My code: added targetWB
hWndMain = FindWindowEx(0&, hWndMain, "XLMAIN", vbNullString)
Loop
Exit Sub
MyErrorHandler:
MsgBox "GetAllWorkbookWindowNames" & vbCrLf & vbCrLf & "Err = " & Err.Number & vbCrLf & "Description: " & Err.Description
End Sub
'My code: added targetWB
Private Sub GetWbkWindows(ByVal hWndMain As Long, targetWB As TargetWBType)
On Error GoTo MyErrorHandler
Dim hWndDesk As Long
hWndDesk = FindWindowEx(hWndMain, 0&, "XLDESK", vbNullString)
If hWndDesk <> 0 Then
Dim hWnd As Long
hWnd = FindWindowEx(hWndDesk, 0, vbNullString, vbNullString)
Dim strText As String
Dim lngRet As Long
Do While hWnd <> 0
strText = String$(100, Chr$(0))
lngRet = GetClassName(hWnd, strText, 100)
If Left$(strText, lngRet) = "EXCEL7" Then
GetExcelObjectFromHwnd hWnd, targetWB 'My code: added targetWB
Exit Sub
End If
hWnd = FindWindowEx(hWndDesk, hWnd, vbNullString, vbNullString)
Loop
On Error Resume Next
End If
Exit Sub
MyErrorHandler:
MsgBox "GetWbkWindows" & vbCrLf & vbCrLf & "Err = " & Err.Number & vbCrLf & "Description: " & Err.Description
End Sub
'My code: added targetWB
Public Function GetExcelObjectFromHwnd(ByVal hWnd As Long, targetWB As TargetWBType) As Boolean
On Error GoTo MyErrorHandler
Dim fOk As Boolean
fOk = False
Dim iid As UUID
Call IIDFromString(StrPtr(IID_IDispatch), iid)
Dim obj As Object
If AccessibleObjectFromWindow(hWnd, OBJID_NATIVEOM, iid, obj) = 0 Then 'S_OK
Dim objApp As Excel.Application
Set objApp = obj.Application
'My code
Dim wbCount As Integer
For wbCount = 1 To objApp.Workbooks.Count
'End my code
'Not my code
Debug.Print objApp.Workbooks(wbCount).name
'My code
If LCase(objApp.Workbooks(wbCount).name) = LCase(targetWB.name) Then
MsgBox ("Found target: " & targetWB.name)
Set targetWB.returnObj = obj
targetWB.returnWBIndex = wbCount
End If
'End My code
'Not my code
Dim myWorksheet As Worksheet
For Each myWorksheet In objApp.Workbooks(wbCount).Worksheets
Debug.Print " " & myWorksheet.name
DoEvents
Next
'My code
Next
'Not my code
fOk = True
End If
GetExcelObjectFromHwnd = fOk
Exit Function
MyErrorHandler:
MsgBox "GetExcelObjectFromHwnd" & vbCrLf & vbCrLf & "Err = " & Err.Number & vbCrLf & "Description: " & Err.Description
End Function
I repeat, this works, and using the variables within the TargetWB type I am reliably accessing workbooks and worksheets across instances of Excel.
The only potential problem I see with my solution, is if you have multiple WB's with the same name. Right now, I believe it would return the last instance of that name. If we add an Exit For into the If Then I believe it will instead return the first instance of it. I didn't test this part thouroughly as in my application there is only ever one instance of the file open.
Just to add to James MacAdie's answer, I think you do the redim too late because in the checkHwnds function you end up with an out of range error as you're trying to check values up to 100 even though you haven't yet populated the array fully? I modified the code to the below and it's now working for me.
' Actual public facing function to be called in other code
Public Function GetAllExcelInstances(xlApps() As Application) As Long
On Error GoTo MyErrorHandler
Dim n As Long
#If Win64 Then
Dim hWndMain As LongPtr
#Else
Dim hWndMain As Long
#End If
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
Set app = GetExcelObjectFromHwnd(hWndMain)
If Not (app Is Nothing) Then
If n = 0 Then
n = n + 1
ReDim Preserve xlApps(1 To n)
Set xlApps(n) = app
ElseIf checkHwnds(xlApps, app.Hwnd) Then
n = n + 1
ReDim Preserve xlApps(1 To n)
Set xlApps(n) = app
End If
End If
hWndMain = FindWindowEx(0&, hWndMain, "XLMAIN", vbNullString)
Loop
If n Then
GetAllExcelInstances = n
Else
Erase xlApps
End If
Exit Function
MyErrorHandler:
MsgBox "GetAllExcelInstances" & vbCrLf & vbCrLf & "Err = " & Err.Number & vbCrLf & "Description: " & Err.Description
End Function
I don't believe this is possible using only VBA because the highest level object you can get to is the Application object which is the current instance of Excel.

Resources