Jaafar Tribak
Well-known Member
- Joined
- Dec 5, 2002
- Messages
- 9,596
- Office Version
- 2016
- Platform
- Windows
Ok, I admit it, designing a Collection of all the XL applications currently running in one's machine and use it nearly in the same way as other native collections in the XL object model is no doubt of little practical use for most XL users but I 've long wanted to do this if only for the challenge of it as well as for the sake of learning.
This subject was discussed here http://www.mrexcel.com/board2/viewtopic.php?t=185175&highlight=communicating but was abandoned.
Also, let me just say that the method I've attempted here to do this is by no means an elegant robust solution.It's actually just a hack\workaround which also requires quite a bit of setting up and can also be prone to errors if not handled carefully.
For a robust solution, the only way I know of is by registering and using a third party type lib : OLELIB.TLB written in C with which one can get a pointer to every object in the ROT but then again, what we want here is a VBA-Only solution !!
Set Up required - Follow these 2 STEPS :
STEP1- Create a workbook , place the following code in the 'ThisWorkBook' Module , save it as an AddIn and name it : AppsCollection.xla
AddIn Code
Now, install this addin before you can use the Class shown in the next step.
STEP2- Create a workbook , add a Class Module to it's VBProject and name the Class : clsAppsCollection.
Place the following code in this Class Module :
That's it.
Here are two examples you can try once the AddIn has been insatlled & loaded and the Class has been added to your project.
Start a few instances of Excel and run the test routine below :
Example 1
Example 2:
A word of caution for anyone trying this code! The code in this project makes use of the Registry to store temporary entries inside the 'VB and VBA program Settings' Key during the AddIn autpen event. I believe this is safe but if you happen to edit the code, subtle errors can arise and can be tricky to locate. You may have to manually delete the above temp reg entries by running the RegEdit.exe Applet.
The MaximumInstancesAllowed Property can be particularly troublesome if edited !
Tested in XL 2002 Office XP.
Any feedback would be much appreciated.
Regards.
This subject was discussed here http://www.mrexcel.com/board2/viewtopic.php?t=185175&highlight=communicating but was abandoned.
Also, let me just say that the method I've attempted here to do this is by no means an elegant robust solution.It's actually just a hack\workaround which also requires quite a bit of setting up and can also be prone to errors if not handled carefully.
For a robust solution, the only way I know of is by registering and using a third party type lib : OLELIB.TLB written in C with which one can get a pointer to every object in the ROT but then again, what we want here is a VBA-Only solution !!
Set Up required - Follow these 2 STEPS :
STEP1- Create a workbook , place the following code in the 'ThisWorkBook' Module , save it as an AddIn and name it : AppsCollection.xla
AddIn Code
Code:
Option Explicit
Private Declare Function FindWindow Lib "user32" Alias "FindWindowA" _
(ByVal lpClassName As String, ByVal lpWindowName As String) As Long
Private bSkipCloseEvent As Boolean
Private Sub Workbook_Open()
Dim oWB As Workbook
Dim lHwnd As Long
Dim vAddInLocations As Variant
Dim sMaxInstances As String
'\\check if there is a max allowed # of xl instances
'\\in the registry
sMaxInstances = GetSetting("XLInstances", "MaxAllowed", "Max=")
'\\if there is,check how many xl instances are already open
If Val(sMaxInstances) <> 0 Then
vAddInLocations = GetAllSettings("MyRunningApps", "AddInLocations")
'\\if this xl instance is going to exceed the allowed #
'\\then set a flag,inform the user and close it
If UBound(vAddInLocations, 1) >= Val(sMaxInstances) - 1 Then
GoTo exitHere
End If
End If
'\\however,if it's ok to open this instance then see if it is the first one.
'\\if it is not,save this addin temporarly under a unique name
'\this will permit to retrieve a pointer to the parent application !
lHwnd = FindWindow("XLMAIN", Application.Caption)
If Me.ReadOnly Then
Me.SaveAs Environ("temp") & Application.PathSeparator & _
CStr(lHwnd) & "_" & Me.Name
End If
'\always make an entry in the registry so the addin path
'\\can be later retrieved by the 'Applications' class
SaveSetting "MyRunningApps", "AddInLocations", CStr(Me.Name), CStr(Me.FullName)
Exit Sub
'\\we got here means there are more than the allowed # of instances
'\\quit and get out now skipping the Before_Close event handler
exitHere:
bSkipCloseEvent = True
MsgBox "You have exceed the maximum number of allowed instances", vbExclamation
Application.Quit
End Sub
Private Sub Workbook_BeforeClose(Cancel As Boolean)
'\\if user is closing this xl instance delete its corresponding
'\\registry entry to indicate it's no longer running
If bSkipCloseEvent Then Exit Sub
DeleteSetting "MyRunningApps", "AddInLocations", CStr(Me.Name)
'\\if it's not the first instance delete the associated temp addin
If Me.Name <> "AppsCollection.xla" Then
KillMyself Me
End If
End Sub
Private Sub KillMyself(oWB As Workbook)
Dim sPathName As String
sPathName = oWB.FullName
oWB.ChangeFileAccess xlReadOnly
Kill sPathName
oWB.Saved = True
End SubNow, install this addin before you can use the Class shown in the next step.
STEP2- Create a workbook , add a Class Module to it's VBProject and name the Class : clsAppsCollection.
Place the following code in this Class Module :
Code:
Option Explicit
Private Declare Function ShowWindow Lib "user32" _
(ByVal hwnd As Long, ByVal nCmdShow As Long) As Long
Private Declare Function GetComputerName Lib "kernel32" Alias _
"GetComputerNameA" (ByVal lpBuffer As String, nSize As Long) As Long
Private Const MAX_COMPUTERNAME_LENGTH As Long = 31
Private oColApps As Collection
Private ap As Application
Private byMaxInstances As Byte
Private WithEvents wbCloseEvent As Workbook
Public Property Get Count() As Long
Call UpdateAppsCollection
Count = oColApps.Count
End Property
Public Property Let MaximumInstancesAllowed(ByVal vNewValue As Byte)
'\\store this value in the registry so it can be accessed by all
'\\other running xl applications
SaveSetting "XLInstances", "MaxAllowed", "Max=", CStr(vNewValue)
byMaxInstances = vNewValue
End Property
Public Property Get MaximumInstancesAllowed() As Byte
MaximumInstancesAllowed = byMaxInstances
End Property
Public Function OpenNew _
(Optional visible As Boolean = True, Optional WBPathName As Variant) As Excel.Application
Dim sErrMsg As String
If Not WeAreExceedingMaxXLInstances Then
'\\if there is 'WBPathName' this xl instance will open it
If Not IsMissing(WBPathName) Then
If Len(Dir(WBPathName)) <> 0 Then
Set OpenNew = OpenNewXLApp(visible, WBPathName)
Else
'\\wrong pathname entered ?, warn the user and get out
sErrMsg = sErrMsg & "Check the spelling of the path name."
MsgBox "Path name : ' " & WBPathName & " ' not found." & vbCrLf _
& vbCrLf & sErrMsg, vbExclamation
End If
Else
Set OpenNew = OpenNewXLApp(visible)
End If
End If
End Function
Public Function Item(NameOrIndex As Variant) As Excel.Application
'\\this routine allows to reference the applications by their index #
'\\or the name of any of its children workbooks for easier use of this proprety
Dim i As Byte
Dim oWBk As Workbook
Call UpdateAppsCollection
If Not IsNumeric(NameOrIndex) Then
For i = 1 To oColApps.Count
For Each oWBk In oColApps(i).Workbooks
If UCase(oWBk.Name) = UCase(NameOrIndex) Then
Set Item = oColApps(i)
Exit Function
End If
Next oWBk
Next i
End If
Set Item = oColApps(NameOrIndex)
End Function
Public Sub ActivateApp(App As Excel.Application)
'\\this is just a nice convinience
'\\when you want to quickly activate one
'\\particular xl instance
Call UpdateAppsCollection
If App.visible Then
App.WindowState = xlMaximized
AppActivate App.Caption
End If
End Sub
Public Property Get HostComputer() As String
'\\property similar to the standard Parent prop
Dim lLen As Long
Dim sBuffer As String
'Create a buffer
lLen = MAX_COMPUTERNAME_LENGTH + 1
sBuffer = Space(lLen)
'Get the computer name
GetComputerName sBuffer, lLen
'get only the actual data
sBuffer = Left(sBuffer, lLen)
'Show the computer name
HostComputer = sBuffer
End Property
Private Sub Class_Initialize()
'set up the 'Before_Close' event sink
Set wbCloseEvent = ThisWorkbook
End Sub
Private Sub wbCloseEvent_BeforeClose(Cancel As Boolean)
'\\make sure we delete the registry entry that
'\\stores the # of xl instances once the class workbook is closed
On Error Resume Next
DeleteSetting "XLInstances"
End Sub
Private Sub UpdateAppsCollection()
'\\this routine updates the current # of insatnces
'\\and assigned their respective pointers to the module
'\\level collection.
'\\this routine is run every time a member of this class
'\\is executed. this is vital to keep upto date with
'\\the changing number of open xl instances.
Dim i As Byte
Dim vAddInLocations As Variant
Set oColApps = New Collection
vAddInLocations = GetAllSettings("MyRunningApps", "AddInLocations")
For i = LBound(vAddInLocations, 1) To UBound(vAddInLocations, 1)
oColApps.Add GetObject((vAddInLocations(i, 1))).Parent
Next i
End Sub
Private Function WeAreExceedingMaxXLInstances() As Boolean
Dim vAddInLocations As Variant
vAddInLocations = GetAllSettings("MyRunningApps", "AddInLocations")
If byMaxInstances <> 0 Then
If UBound(vAddInLocations, 1) >= byMaxInstances - 1 Then
WeAreExceedingMaxXLInstances = True
End If
End If
End Function
Private Function OpenNewXLApp _
(Optional ByVal bVisible As Boolean = True, Optional ByVal sWBPathName As Variant) As Excel.Application
Dim oNewApp As Application
Dim sAddInPathName As String
Set oNewApp = CreateObject("EXCEL.APPLICATION")
oNewApp.UserControl = True
sAddInPathName = AddIns("AppsCollection").FullName
oNewApp.Workbooks.Open sAddInPathName
Call UpdateAppsCollection
oNewApp.visible = bVisible
If Not IsMissing(sWBPathName) Then
oNewApp.Workbooks.Open sWBPathName
End If
Set OpenNewXLApp = oNewApp
End FunctionThat's it.
Here are two examples you can try once the AddIn has been insatlled & loaded and the Class has been added to your project.
Start a few instances of Excel and run the test routine below :
Example 1
Code:
'In a Standard Module
Option Explicit
Private Applications As clsAppsCollection
Sub Test()
'\\open a few xl applications instances and
'\\run this code to create an 'Applications' collection
'\\and display info about each xl instance
Dim App As Excel.Application
Dim i As Byte, j As Byte
Dim sMsg As String
Set Applications = New clsAppsCollection
With Applications
For i = 1 To .Count
sMsg = sMsg & " Application: " & i & vbCrLf
sMsg = sMsg & "--------------" & vbCrLf
sMsg = sMsg & " WorkBooks Count: " & _
Applications.Item(i).Workbooks.Count & vbCrLf & vbCrLf
For j = 1 To .Item(i).Workbooks.Count
With .Item(i).Workbooks(j)
sMsg = sMsg & " WorkBook: " & j & " Sheets Count : " _
& .Sheets.Count & vbCrLf
End With
Next j
sMsg = sMsg & vbCrLf & vbCrLf
Next i
End With
MsgBox sMsg
End SubExample 2:
Code:
'In a Standard Module
Option Explicit
Private Applications As clsAppsCollection
Sub Test2()
'\\allow no more than 3 xl instances @ a time
'\\and use the OpenNew Method to open one
Set Applications = New clsAppsCollection
With Applications
.MaximumInstancesAllowed = 3
.OpenNew
End With
End SubThe MaximumInstancesAllowed Property can be particularly troublesome if edited !
Tested in XL 2002 Office XP.
Any feedback would be much appreciated.
Regards.
