Related
I am trying to download files located on a network via an ftp connection from a VBA macro. my concern is that the file changes according to the need. so I have to use a regular expression to find the file to download. i define a function ftpDownload like this:
Function FtpDownload(ByVal strRemoteFile As String, ByVal strLocalFile As String, ByVal strHost As String, ByVal lngPort As Long, ByVal strUser As String, ByVal strPass As String)
'usage
'FtpDownload "/TEST/test.html", "c:\test.html", "ftp.server.com", 21, "user", "password"
Dim hOpen As Long
Dim hConn As Long
hOpen = InternetOpenA("FTPGET", 1, vbNullString, vbNullString, 1)
hConn = InternetConnectA(hOpen, strHost, lngPort, strUser, strPass, 1, 0, 2)
If FtpGetFileA(hConn, strRemoteFile, strLocalFile, 1, 0, FTP_TRANSFER_TYPE_UNKNOWN Or INTERNET_FLAG_RELOAD, 0) Then
Debug.Print "done"
NA = MsgBox("Done", vbOKOnly + vbInformation, "FTP transfert")
Else
Debug.Print "fail"
NA = MsgBox("Fail", vbOKOnly + vbCritical, "FTP transfert")
End If
InternetCloseHandle hConn
InternetCloseHandle hOpen
End Function
the remote files I would like to download are in the path :
/tmp/SLX2088-101005_25-Mar-2017_13_24_25.txt
i would like to use an expression to find and download the file.
SLX2088- is invariable
101005 is unique id that i will use in variable to find the file.
so my expression will be RemoteFileName:="SLX2088-" & id & "*.txt". this expression works locally but not on ftp.
I would therefore like to first write an expression that allows me to find the file with the identifier inserted in a num_id variable and then be able to use this expression in my FtpDownload function to download the file.
can someone help me build the expression and tell me how to use it in the function?
HostName = "**.**.***.**"
UserName = "****"
Password = "****"
RemoteFileName = "/../../../tmp/SLX2088-101005_25-Mar-2017_13_24_25.txt"
LocalFileName = "C:\temp\SLX2088-101005_25-Mar-2017_13_24_25.txt"
NA = FtpDownload(RemoteFileName, LocalFileName, HostName, 21, UserName, Password)
I found the solution thank you for your help. here is the code:
Global num_inspection
Global ligne_inspection
Global actual_wkb
Const MAX_PATH = 260
Dim fichier_actu As String
Dim set_mask As String
Dim level As String
Dim entity As String
Dim hFind As Long, lRet As Long
Private Const FTP_TRANSFER_TYPE_UNKNOWN As Long = 0
Private Const INTERNET_FLAG_RELOAD As Long = &H80000000
Public Type FILETIME
dwLowDateTime As Long
dwHighDateTime As Long
End Type
Public Type WIN32_FIND_DATA
dwFileAttributes As Long
ftCreationTime As FILETIME
ftLastAccessTime As FILETIME
ftLastWriteTime As FILETIME
nFileSizeHigh As Long
nFileSizeLow As Long
dwReserved0 As Long
dwReserved1 As Long
cFileName As String * MAX_PATH
cAlternate As String * 14
End Type
Public Declare PtrSafe Function FtpSetCurrentDirectory Lib "wininet.dll" Alias "FtpSetCurrentDirectoryA" _
(ByVal hFtpSession As Long, ByVal lpszDirectory As String) As Boolean
Private Declare PtrSafe Function FtpFindFirstFile Lib "wininet.dll" Alias "FtpFindFirstFileA" _
(ByVal hFtpSession As Long, ByVal lpszSearchFile As String, lpFindFileData As WIN32_FIND_DATA, ByVal dwFlags As Long, ByVal dwContent As Long) As Long
Private Declare PtrSafe Function InternetFindNextFile Lib "wininet.dll" Alias "InternetFindNextFileA" (ByVal hFind As Long, lpvFindData As WIN32_FIND_DATA) As Long
Private Declare PtrSafe Function InternetOpenA Lib "wininet.dll" ( _
ByVal sAgent As String, _
ByVal lAccessType As Long, _
ByVal sProxyName As String, _
ByVal sProxyBypass As String, _
ByVal lFlags As Long) As Long
Private Declare PtrSafe Function InternetConnectA Lib "wininet.dll" ( _
ByVal hInternetSession As Long, _
ByVal sServerName As String, _
ByVal nServerPort As Long, _
ByVal sUsername As String, _
ByVal sPassword As String, _
ByVal lService As Long, _
ByVal lFlags As Long, _
ByVal lcontext As Long) As Long
Private Declare PtrSafe Function FtpGetFileA Lib "wininet.dll" ( _
ByVal hConnect As Long, _
ByVal lpszRemoteFile As String, _
ByVal lpszNewFile As String, _
ByVal fFailIfExists As Long, _
ByVal dwFlagsAndAttributes As Long, _
ByVal dwFlags As Long, _
ByVal dwContext As Long) As Long
Private Declare PtrSafe Function InternetCloseHandle Lib "wininet" ( _
ByVal hInet As Long) As Long
Dim pData As WIN32_FIND_DATA
Sub testFTP()
HostName = "********"
UserName = "****"
Password = "****"
RemoteFileName = "file expression like *.*"
LocalFileName = "yourLocalFileName"
NA = FtpDownload(RemoteFileName, LocalFileName, HostName, 21, UserName, Password)
'Workbooks.OpenText Filename:="yourLocalFileName", _
Origin:=xlMSDOS, StartRow:=1, DataType:=xlDelimited, TextQualifier:= _
xlDoubleQuote, ConsecutiveDelimiter:=True, Tab:=True, Semicolon:=False, _
Comma:=False, Space:=True, Other:=True, OtherChar:=";", FieldInfo:= _
Array(Array(1, 1), Array(2, 1), Array(3, 1), Array(4, 1), Array(5, 1))
End Sub
Function FtpDownload(ByVal strRemoteFile As String, ByVal strLocalFile As String, ByVal strHost As String, ByVal lngPort As Long, ByVal strUser As String, ByVal strPass As String)
Dim hOpen As Long
Dim hConn As Long
hOpen = InternetOpenA("FTPGET", 1, vbNullString, vbNullString, 1)
hConn = InternetConnectA(hOpen, strHost, lngPort, strUser, strPass, 1, 0, 2)
Call FtpSetCurrentDirectory(hConn, "here your remote directory")
pData.cFileName = String(MAX_PATH, 0)
hFind = FtpFindFirstFile(hConn, strRemoteFile, pData, 0, 0)
If FtpGetFileA(hConn, pData.cFileName, strLocalFile, 1, 0, FTP_TRANSFER_TYPE_UNKNOWN Or INTERNET_FLAG_RELOAD, 0) Then
Debug.Print "done"
NA = MsgBox("Done", vbOKOnly + vbInformation, "FTP transfert")
Else
Debug.Print "fail"
NA = MsgBox("Fail", vbOKOnly + vbCritical, "FTP transfert")
End If
InternetCloseHandle hConn
InternetCloseHandle hOpen
End Function
I'm currently creating a program that downloads URL links as PDF and stores it into my local storage. The problem is that, when it encounters a duplicate name then it overwrites. Any thoughts on instead of overwriting the existing file, It should just add (2) on the end.
My code here is
Private Declare PtrSafe Function URLDownloadToFile Lib "urlmon" _
Alias "URLDownloadToFileA" (ByVal pCaller As LongPtr, _
ByVal szURL As String, ByVal szFileName As String, _
ByVal dwReserved As Long, ByVal lpfnCB As LongPtr) As Long
Sub DownloadFile()
Dim downloadStatus As Variant
Dim Url As String
Dim destinatioFile_Local As String
Dim i As Integer
i = 1
Do Until IsEmpty(Cells(i, 1)) = True
Url = (Cells(i, 1))
destinationFile_local = "C:\Users\name\Desktop\test" & filename(Cells(i, 1))
downloadStatus = URLDownloadToFile(0, Url, destinationFile_local, 0, 0)
If downloadStatus = 0 Then
MsgBox "Downloaded"
Else
MsgBox "Download fail"
End If
i = i + 1
Loop
End Sub
Function filename(file_fullname) As String
filename = Mid(file_fullname, InStrRev(file_fullname, "/") + 1)
End Function
I have an excel workbook and want to copy another excel file from the local memory and save it to ftp server folder.
I found example code here here
The file which I want to transfer is following:
C:\Users\User1\test.xlsx
The folder to which I want to transfer is accessible via:
ftp://user:password#www.name/destination/
ftp = "85.253.158.128" I retrieved from https://www.myip.com/ (I tried both my IP and HOST)
My code is following:
Declare PtrSafe Function InternetConnect Lib "wininet.dll" Alias "InternetConnectA" ( _
ByVal hInternetSession As Long, ByVal sServerName As String, _
ByVal nServerPort As Integer, ByVal sUserName As String, _
ByVal sPassword As String, ByVal lService As Long, _
ByVal lFlags As Long, ByVal lContext As Long) As Long
Declare PtrSafe Function InternetOpen Lib "wininet.dll" Alias "InternetOpenA" ( _
ByVal sAgent As String, ByVal lAccessType As Long, _
ByVal sProxyName As String, _
ByVal sProxyBypass As String, ByVal lFlags As Long) As Long
Declare PtrSafe Function FtpSetCurrentDirectory Lib "wininet.dll" Alias _
"FtpSetCurrentDirectoryA" (ByVal hFtpSession As Long, _
ByVal lpszDirectory As String) As Boolean
Declare PtrSafe Function FtpPutFile Lib "wininet.dll" Alias "FtpPutFileA" ( _
ByVal hConnect As Long, _
ByVal lpszLocalFile As String, _
ByVal lpszNewRemoteFile As String, _
ByVal dwFlags As Long, _
ByRef dwContext As Long) As Boolean
Sub simpleFtpFileUpload()
Dim ftp, FTP_PORT, user, password, loc_file, remote_file, ftp_folder As Variant
ftp_folder = "ftp://user#www.name/destination"
loc_file = "C:\Users\User1\test.xlsx"
remote_file = ftp_folder & "/test.xlsx"
FTP_PORT = 21
user = "usr"
password = "pwd"
ftp = "85.253.158.128" '"192.168.1.110"
Internet_OK = InternetOpen("", 1, "", "", 0)
If Internet_OK Then
FTP_OK = InternetConnect(Internet_OK, ftp, FTP_PORT, user, password, 1, 0, 0) ' INTERNET_DEFAULT_FTP_PORT or port no
If FtpSetCurrentDirectory(FTP_OK, "/") Then
Success = FtpPutFile(FTP_OK, loc_file, remote_file, FTP_TRANSFER_TYPE_BINARY, 0)
End If
End If
If Success Then
Debug.Print "ftp success ;)"
MsgBox "ftp success ;)"
Else
Debug.Print "ftp failure :("
MsgBox "ftp failure :("
End If
End Sub
I always got an error "ftp failure :(". Could you help to solve this problem? I am also using VPN, may it trigger the problem?
UPDATE:
Is it also possible to do something like below, because DestFile shows the path on the disc :
Sub simpleFtpFileUpload()
Dim SoureFile As String
Dim DestFile As String
SourceFile = "C:\Users\User1\test.xlsx"
DestFile = "ftp://user:password#www.name/destination/test.xlsx"
FileCopy SourceFile, DestFile
End Sub
With this approach I got an error
and FileCopy SourceFile, DestFile row is highlighted when I press Debug button.
I have found the code below to start me off with developing a automated way to download files from an ftp site. however it fails every time without any error that i can troubleshoot.
I have a newbie in excel vba so some help would be appreciated.
I have tried searching online and here at stack overflow but I could'nt figure this out on my own
Private Const FTP_TRANSFER_TYPE_UNKNOWN As Long = 0
Private Const INTERNET_FLAG_RELOAD As Long = &H80000000
Private Declare Function InternetOpenA Lib "wininet.dll" ( _
ByVal sAgent As String, _
ByVal lAccessType As Long, _
ByVal sProxyName As String, _
ByVal sProxyBypass As String, _
ByVal lFlags As Long) As Long
Private Declare Function InternetConnectA Lib "wininet.dll" ( _
ByVal hInternetSession As Long, _
ByVal sServerName As String, _
ByVal nServerPort As Long, _
ByVal sUsername As String, _
ByVal sPassword As String, _
ByVal lService As Long, _
ByVal lFlags As Long, _
ByVal lcontext As Long) As Long
Private Declare Function FtpGetFileA Lib "wininet.dll" ( _
ByVal hConnect As Long, _
ByVal lpszRemoteFile As String, _
ByVal lpszNewFile As String, _
ByVal fFailIfExists As Long, _
ByVal dwFlagsAndAttributes As Long, _
ByVal dwFlags As Long, _
ByVal dwContext As Long) As Long
Private Declare Function InternetCloseHandle Lib "wininet" ( _
ByVal hInet As Long) As Long
Sub FtpDownload(ByVal strRemoteFile As String, ByVal strLocalFile As String, ByVal strHost As String, ByVal lngPort As Long, Optional ByVal strUser As String, Optional ByVal strPass As String)
Dim hOpen As Long
Dim hConn As Long
hOpen = InternetOpenA("FTPGET", 1, vbNullString, vbNullString, 1)
hConn = InternetConnectA(hOpen, strHost, lngPort, strUser, strPass, 1, 0, 2)
If FtpGetFileA(hConn, strRemoteFile, strLocalFile, 1, 0, FTP_TRANSFER_TYPE_UNKNOWN Or INTERNET_FLAG_RELOAD, 0) Then
Debug.Print "Success"
Else
Debug.Print "Fail"
End If
'Close connections
InternetCloseHandle hConn
InternetCloseHandle hOpen
End Sub
Sub Get_File_From_FTP()
'Assign Host URL, Source and Destination File path
Dim HostURL, fileSource, FileDestination As String
HostURL = ThisWorkbook.Sheets(1).Cells(1, 1)
fileSource = ThisWorkbook.Sheets(1).Cells(1, 2)
FileDestination = ThisWorkbook.Sheets(1).Cells(2, 2)
FtpDownload fileSource, FileDestination, HostURL, 21, "Username", "Password"
End Sub
Okay, the above code works without any problems. I believe the problem might be within your reference cells...
HostURL = ThisWorkbook.Sheets(1).Cells(1, 1)
fileSource = ThisWorkbook.Sheets(1).Cells(1, 2)
FileDestination = ThisWorkbook.Sheets(1).Cells(2, 2)
When i messed around with this, i found that I had to have this format...
HostURL = "192.168.168.2" 'Or your FQDN
fileSource = "/This/Is/The/Path/To/Your/File.file" ' Make sure that this matches your file path
FileDestination = "C:\This\Is\The\Complete\Path\On\Your\Machine.File"
Of course, make sure that you populate the username and password section of the macro...
FtpDownload fileSource, FileDestination, HostURL, 21, "YOUR_USERNAME_HERE", "YOUR_PASSWORD_HERE"
Dim HostURL, fileSource, FileDestination As String
HostURL = "ftp.datacentre.com"
fileSource = "/country_forecast/CWG_ecop_19021012_United-Kingdom.csv"
FileDestination = "C:\Development\Test1\newFile.txt"
FtpDownload fileSource, FileDestination, HostURL, 21, "username", "password"
I have tried everything now. so I'm using the above paths.
This url works though I i download the file manually. [ftp://username:password#ftp.datacentre.com/country_forecast/CWG_ecop_19021012_United-Kingdom.csv]
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.