private excel.application instance for only one workbook

[jogeslin]

Hi!

i'm trying to adapt a code i found in an old thread : Don't allow another workbook to open in this instance?

I want to secure an instance for only one workbook, so i adapted the code to fullfit my need.

when i open the workbook wich i want private instance, i see 2 situations

case situations

case 1

me.open​

app.wb > 1 then​

open me in the new instance​

​

at that point everything working correctly​

here my problem :​

​

** i want to keep stored my initial app to open all new workbook in this application (has it's should be) **​

​

trying to pass the initial application throught the process, due to the re-open i'm loosing my object​

​

case 2

me.open​

app.wb = 1​

secure the instance by openning all new workbook in an new and unique instance​

​

work correctly​

end case

see my adapted code below :

Option Explicit

Private WithEvents oAppEvents As Application
Private oWb As Workbook
Private old_app  As Application
 
Private Sub Workbook_Open()
 
    Dim oNewApp As New Application
    Dim tWb As Long

    If Application.Workbooks.Count > 1 Then

        tWb = Application.hWnd

        Me.ChangeFileAccess xlReadOnly
        oNewApp.Workbooks.Open Me.FullName
        oNewApp.Visible = True

        Me.Close False

        oNewApp.OnTime Now, "'" & Me.CodeName & ".save_mem " & tWb & "'"

    Else
    
        'where re-openning old_app should be set to initial application --- > if initial application have more than 1 workbook

        If old_app Is Nothing Then
            Debug.Print "old_app noting"
            Set old_app = New Application
            old_app.AutomationSecurity = msoAutomationSecurityForceDisable
        End If
    End If
 
    Set oAppEvents = Application
    
End Sub
 
Private Sub oAppEvents_NewWorkbook(ByVal Wb As Workbook)
      
    Wb.Close False
    old_app.Workbooks.Add
    If Not old_app.Visible Then old_app.Visible = True
 
End Sub
 
Private Sub oAppEvents_WorkbookOpen(ByVal Wb As Workbook)
 
    If Wb Is Me Then Exit Sub
        
    Set oWb = Wb
    oWb.ChangeFileAccess xlReadOnly
    Application.OnTime Now, Me.CodeName & ".CloseWB"
 
End Sub
 
Private Sub CloseWB()
    old_app.Workbooks.Open oWb.FullName
    If Not old_app.Visible Then old_app.Visible = True
    oWb.Close False
End Sub

Private Sub save_mem(wbapp As Long)

    Dim Wkb     As Workbook
    Dim XLapp   As Object
    
    Set XLapp = GetExcelObject(wbapp)
    Set Wkb = XLapp.Windows(1).ActiveSheet.Parent
    
    Set old_app = Wkb.Application
End Sub

save_mem function result come from this thread : Given the HWND values for several application windows, how to use vba to return each window as an object?

Option Explicit

' Written:  September 21, 2017
' Author:   Leith Ross


Private Const OBJID_NATIVEOM As Long = &HFFFFFFF0


Type GUID
    lData1 As Long
    iData2 As Integer
    iData3 As Integer
    aBData4(0 To 7) As Byte
End Type


Private Declare PtrSafe Function IIDFromString _
    Lib "ole32.dll" _
        (ByVal lpszIID As String, _
         ByRef lpIID As GUID) _
    As Long


Private Declare PtrSafe Function FindWindowEx _
    Lib "user32.dll" Alias "FindWindowExA" _
        (ByVal hWnd1 As LongPtr, _
         ByVal hWnd2 As LongPtr, _
         ByVal lpsz1 As String, _
         ByVal lpsz2 As String) _
    As LongPtr
    
Private Declare PtrSafe Function AccessibleObjectFromWindow _
    Lib "oleacc.dll" _
      (ByVal hWnd As LongPtr, _
       ByVal dwId As Long, _
       ByRef riid As GUID, _
       ByRef ppvObject As Object) _
    As Long
    
Public Function GetExcelObject(ByVal xlHwnd As LongPtr) As Object


    Dim CLSID   As String
    Dim IDisp   As GUID
    Dim ret     As Long
    Dim xlDesk  As LongPtr
    Dim xlWkb   As LongPtr
    Dim Wnd     As Object
    
        CLSID = StrConv("{00020400-0000-0000-C000-000000000046}", vbUnicode)
        ret = IIDFromString(CLSID, IDisp)
        
            xlDesk = FindWindowEx(xlHwnd, 0&, "XLDESK", vbNullString)
            xlWkb = FindWindowEx(xlDesk, 0&, "EXCEL7", vbNullString)
            
            If xlWkb <> 0 Then
                ret = AccessibleObjectFromWindow(xlWkb, OBJID_NATIVEOM, IDisp, Wnd)
                If ret = 0 Then
                    Set GetExcelObject = Wnd.Parent.Parent
                End If
            End If
                
End Function