Przegląd otwartych skoroszytów we wszystkich Instancjach Excela   strona główna:
A po co ten Excel ;-)
 
Mam plik: "C:\Users\MiTKuchta\Desktop\~\Oszczędności.xls" I zasadnicze pytanie: Czy ten plik jest otwarty?  
 
    Sprawa wydawałaby się dość prosta: jeżeli w kolekcji Workbooks znajduje się plik Oszczędności.xls plik jest otwarty. Pomijam tu  
fakt że mogą to być inne oszczędności (a wszystkim życzę jak największej ilości oszczędności ;-) ) bo jak już ustalimy że plik o  
takiej nazwie znajduje się w naszej kolekcji Workbooks to sprawdzimy jego .FullName. Jeżeli nie będzie to nasza ścieżka to i tak inny  
plik o takiej samej nazwie w danej kolekcji być nie może! Więc "sprawa czysta".  
    Przy takim podejściu powinna wystarczyć funkcja…  
 
Function IsWorkbookOpen(xlApp As Excel.Application, _  
                        strXLFileName As String) As Boolean  
    Dim xlWkb As Excel.Workbook  
      
    On Error Resume Next  
    Set xlWkb = xlApp.Workbooks(strXLFileName)  
    On Error GoTo 0  
    IsWorkbookOpen = Not xlWkb Is Nothing  
End Function  
 
Jednak gdyby mój plik "odpalić" tak…  
 
Sub test()  
    Dim xlApp As Excel.Application  
      
    Set xlApp = New Excel.Application  
    With xlApp  
        .Visible = True  
        .Workbooks.Open "C:\Users\MiTKuchta\Desktop\~\Oszczędności.xls"  
    End With  
      
    Debug.Print IsWorkbookOpen(xlApp, "Oszczędności.xls")  
      
    Set xlApp = Nothing  
End Sub  
 
Plik zostanie otwarty. Funkcja IsWorkbookOpen zwróci True do okna Immediate, ale czy taki plik będzie w kolekcji Workbooks..  
 
Sub WB()  
    Dim xlWkb As Excel.Workbook  
      
    Debug.Print IsWorkbookOpen(Application, "Oszczędności.xls")  
      
    For Each xlWkb In Application.Workbooks  
        Debug.Print xlWkb.Name  
    Next  
      
    Set xlWkb = Nothing  
End Sub  
 
Okazuje się że NIE :-) Jak więc sprawdzić czy ten plik jest otwarty?  
  Check if Excel File is Open
AND by Who
W sieci można znaleźć funkcję która podchodzi do sprawy inaczej. Funkcja podejmuje próbę otwarcia pliku "na wyłączność".   
Jej działanie można sprawdzić procedurą:  
 
Sub IsOpen()  
    Debug.Print IsFileOpen("C:\Users\MiTKuchta\Desktop\~\Oszczędności.xls")  
End Sub  
 
Otrzymujemy True :-) Jest jednak wyjątek.. Jeżeli sprawdzany plik ma atrybut "Tylko do Odczytu" funkcja zawsze będzie twierdzić  
że plik jest otwarty. Poza tym założenie naszego programu może być inne. Nie wystarczy nam wiedza czy plik jest otwarty. Będziemy  
chcieli korzystać z jego obiektów: np.: pobrać z nie go dane, zamknąć plik i/lub instancję Excela w której jest otwarty.  
    I tu przychodzi nam z pomocą coś innego..  
 
Option Explicit  
   
Private Declare Function FindWindowExA _  
    Lib "user32" ( _  
    ByVal hWnd1 As Long, _  
    ByVal hWnd2 As Long, _  
    ByVal lpsz1 As String, _  
    ByVal lpsz2 As String) As Long  
      
Private Declare Function AccessibleObjectFromWindow _  
    Lib "oleacc" ( _  
    ByVal hwnd As Long, _  
    ByVal dwId As Long, _  
    riid As GUID, _  
    xlWB As Object) As Long  
   
Type GUID  
    lData1 As Long  
    iData2 As Integer  
    iData3 As Integer  
    aBData4(0 To 7) As Byte  
End Type  
   
Private Const OBJID_NATIVEOM = &HFFFFFFF0  
   
Public Function GetXlApps() As Variant  
    ' na podstawie  
    ' http://www.mrexcel.com/forum/showthread.php?p=1361232  
    Dim WBobj As Object, xlWnd&, WBsWnd&, WBWnd&  
    Dim IDispatch As GUID: SetIDispatch IDispatch  
    Dim tbl() As Excel.Application, i As Integer  
      
    Do  
        xlWnd = FindWindowExA(0, xlWnd, "XLMAIN", vbNullString)  
        If xlWnd = 0 Then  
            Exit Do  
        Else  
            WBsWnd = FindWindowExA(xlWnd, 0&, "XLDESK", vbNullString)  
            WBWnd = FindWindowExA(WBsWnd, 0&, "EXCEL7", vbNullString)  
            If WBWnd Then  
                AccessibleObjectFromWindow WBWnd, OBJID_NATIVEOM, IDispatch, WBobj  
                i = i + 1  
                ReDim Preserve tbl(i)  
                Set tbl(i) = WBobj.Application  
            End If  
        End If  
    Loop  
      
    GetXlApps = tbl  
    Set WBobj = Nothing  
End Function  
   
Private Sub SetIDispatch(ByRef ID As GUID)  
   'Defines the IDispatch variable. The interface  
   'ID is {00020400-0000-0000-C000-000000000046}.  
    With ID  
        .lData1 = &H20400  
        .iData2 = &H0  
        .iData3 = &H0  
        .aBData4(0) = &HC0  
        .aBData4(1) = &H0  
        .aBData4(2) = &H0  
        .aBData4(3) = &H0  
        .aBData4(4) = &H0  
        .aBData4(5) = &H0  
        .aBData4(6) = &H0  
        .aBData4(7) = &H46  
    End With  
End Sub  
 
A więc.. Funkcja GetXlApps ma nam zwrócić tablicę ze wszystkimi otwartymi instancjami Excela. Teraz wystarczy z niej skorzystać.  
    Jak więc zamknąć nasz plik i jeżeli jest/był to jedyny otwarty plik w tej instancji to zamknąć całą aplikację?  
 
Sub ZamknijSkoroszyt()  
    On Error GoTo ZamknijSkoroszyt_Error  
 
    Dim xlWkb As Excel.Workbook  
    Const strFileFullName As String = "C:\Users\MiTKuchta\Desktop\~\Oszczędności.xls"  
 
    Dim tbl As Variant, i As Long  
      
    tbl = GetXlApps()  
    For i = 1 To UBound(tbl)  
        With tbl(i)  
            For Each xlWkb In .Workbooks  
                With xlWkb  
                    If .FullName = strFileFullName Then  
                        .Close SaveChanges:=False  
                    End If  
                End With  
            Next  
            If .Workbooks.Count = 0 Then .Quit  
        End With  
        Set tbl(i) = Nothing  
    Next  
 
ZamknijSkoroszyt_Exit:  
    On Error Resume Next  
    For i = 1 To UBound(tbl)  
        Set tbl(i) = Nothing  
    Next  
    Exit Sub  
 
ZamknijSkoroszyt_Error:  
    MsgBox "Byk Numer - " & Err.Number & vbCrLf & vbCrLf & _  
            Err.Description, vbExclamation, "VBAProject - WysZam"  
    Debug.Print Err.Number & Space(2) & Err.Description  
    Resume ZamknijSkoroszyt_Exit  
 
End Sub  
 
Zobaczmy jeszcze jeden test. Będziemy próbować w nim korzystać z danych pochodzących ze skoroszytu w innej instancji Excela.  
    Tworzymy zatem skoroszyt i wypełniamy zakres A1:E5 wartościami oraz pewnym kolorem wypełnienia.  
 
Sub TworzTest2()  
    On Error GoTo Test2_Error  
 
    Dim xlApp As Excel.Application  
    Dim xlWkb As Excel.Workbook  
    Dim xlWks As Excel.Worksheet, i As Long, j As Integer  
      
    Randomize  
    Set xlApp = New Excel.Application  
    With xlApp  
        .Visible = True  
        Set xlWkb = .Workbooks.Add  
        Set xlWks = xlWkb.Worksheets(1)  
        With xlWks  
            For i = 1 To 5  
                For j = 1 To 5  
                    With .Cells(i, j)  
                        .Value = Int(100 * Rnd)  
                        .Interior.ColorIndex = Int(50 * Rnd) + 1  
                    End With  
                Next  
            Next  
        End With  
    End With  
    Set xlWks = Nothing  
    Set xlWkb = Nothing  
    Set xlApp = Nothing  
      
Test2_Exit:  
    On Error Resume Next  
    Set xlWks = Nothing  
    If Not xlWkb Is Nothing Then  
        xlWkb.Close Savechanges:=False  
        Set xlWkb = Nothing  
    End If  
    If Not xlApp Is Nothing Then  
        xlApp.Quit  
        Set xlApp = Nothing  
    End If  
    Exit Sub  
 
Test2_Error:  
    MsgBox "Byk Numer - " & Err.Number & vbCrLf & vbCrLf & _  
            Err.Description, vbExclamation, "VBAProject - Test2"  
    Resume Test2_Exit  
End Sub  
 
Spróbujmy teraz skopiować ten zakres do naszego pliku.  
 
Sub ReadTest2()  
    On Error GoTo Test2_Error  
    Dim tbl As Variant, i As Long, bFlag As Boolean  
    Dim xlWkb As Excel.Workbook  
    Dim xlWks As Excel.Worksheet  
      
    Set xlWks = ThisWorkbook.Worksheets("Arkusz1")  
      
    tbl = GetXlApps()  
    For i = 1 To UBound(tbl)  
        With tbl(i)  
            If Application.hwnd <> tbl(i).hwnd Then  
                For Each xlWkb In .Workbooks  
                    With xlWkb  
                        If .FullName = "Zeszyt1" Then  
                              
                            Dim tblDane As Variant  
                            tblDane = .Worksheets(1).Range("A1:E5")  
                            xlWks.[A1].Resize(5, 5) = tblDane  
                              
                            '.Worksheets(1).Range("A1:E5").Copy Destination:=xlWks.[A1]  
                              
                            bFlag = True  
                        End If  
                    End With  
                    If bFlag Then Exit For  
                Next  
            End If  
        End With  
        If bFlag Then Exit For  
    Next  
      
Test2_Exit:  
    On Error Resume Next  
    For i = 1 To UBound(tbl)  
        Set tbl(i) = Nothing  
    Next  
    Exit Sub  
      
Test2_Error:  
    MsgBox "Byk Numer - " & Err.Number & vbCrLf & vbCrLf & _  
            Err.Description, vbExclamation, "VBAProject - Test2"  
    Resume Test2_Exit  
End Sub  
 
Przeanalizujmy procedurę kopiowania danych:  
 
    tbl = GetXlApps()  
    For i = 1 To UBound(tbl)  
        With tbl(i)  
            If Application.hwnd <> tbl(i).hwnd Then  
 
zapisujemy do tbl istniejące instancję Excela i przeglądając tę tablicę sprawdzamy czy to aby nie nasza.  
 
                For Each xlWkb In .Workbooks  
                    With xlWkb  
                        If .FullName = "Zeszyt1" Then  
 
Utworzony przez procedurę TworzTest2 skoroszyt ma nazwę "Zeszyt1" i jest nigdzie nie zapisany.  
 
                            Dim tblDane As Variant  
                            tblDane = .Worksheets(1).Range("A1:E5")  
                            xlWks.[A1].Resize(5, 5) = tblDane  
                              
                            '.Worksheets(1).Range("A1:E5").Copy Destination:=xlWks.[A1]  
                              
                            bFlag = True  
 
… i kopiujemy z niego dane metodą Copy obiektu Range… i byk!!!  
Błąd nr 1004: Metoda Copy z klasy Range nie powiodła się  
to ten wy komentowany fragment.  
 
obejście to zapis zakresu w skoroszycie Zeszyt1 do tablicy i zwrócenie tablicy do pliku docelowego. Minusem jest fakt że przepadło  
formatowanie. Jak je nadać w pliku docelowym? Po prostu..  
 
    Dim iW As Long, iK As Integer  
    For iW = 1 To 5  
        For iK = 1 To 5  
            xlWks.Cells(iW, iK).Interior.ColorIndex = .Worksheets(1).Cells(iW, iK).Interior.ColorIndex  
        Next  
    Next  
 
Metoda więc doskonała nie jest ale możliwości daje duże.. Mam nadzieję że Wam się przyda :-)