Makro pro zavření sešitu podle části názvu Vyřešeno

[jiri255]

Zdravím,
mám prosbu o radu ohledně makra na zavření sešitu. Vím, že lze zavřít sešit pomocí,

Kód: Vybrat vše

Workbooks("sesit.xls").Close SaveChanges:=False


ale já bych potřeboval zavřít sešit na základě části názvu sešitu. Tedy například mám
otevřených několik sešitů třeba crd112.xls, crd118.xls, crd1120.xls, bla558.xls, atd...
a makro má zavřít část znich, které v názvu obsahují text "crd"
Nevíte někdo, jak něco takového udělat?

Předem děkuji za pomoc.

[Reklama]

[cmuch]

Šlo by použít tuto, jde pouze na sešity otevřené pod jednou instancí.
Prvně zavře sešity co obsahují hledaný text mimo aktivního,
nakonec se zavře sešit aktivní pokud obsahuje hledaný text.

Kód: Vybrat vše

Sub CloseExcel()
  Dim wn As Excel.Window
  For Each wn In Application.Windows
    If InStr(wn.Caption, "crd") > 1 And Not wn.Caption = wn.Activate Then
      wn.Close False
    End If
  Next wn
  For Each wn In Application.Windows
    If InStr(wn.Caption, "crd") > 1 Then
      wn.Close False
    End If
  Next wn
End Sub


[jiri255]

děkuji, ale toto pro mě bohužel není použitelné, každý dokument je otevřený v nové instanci
Šlo by to makro nějak poupravit?

[cmuch]

To nevím jak upravit,
možná by bylo jednodušší upravit makro co otevírá ty sešity, aby je otvíralo v jedné instanci.
Pokud jsou otvírány ručně tak se musí otevřít v jedné instanci.

[jiri255]

spouští se bez makra automaticky, jako výstup, každý v jiné instanci s tím nic nenadělám...,
tak třeba někdo bude vědět, i tak děkuji

[cmuch]

Tak vyzkoušej tuto, v poslední fci si zadáš slovo co to má hledat v názvu sešitu.
Spouští se makrem GetAllWorkbookWindowNames (Alt+F8)

Kód: Vybrat vše

'------------- 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


'------------- Code (Module, Form) --------------

Const IID_IDispatch As String = "{00020400-0000-0000-C000-000000000046}"
Const OBJID_NATIVEOM As Long = &HFFFFFFF0

'Sub Command1_Click()
Sub GetAllWorkbookWindowNames()
    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
       
        Dim wbCount As Integer
        For wbCount = 1 To objApp.Workbooks.Count
       
            ' Debug.Print objApp.Workbooks(wbCount).name
           
            ' Sheets Workbooks
            ' Dim myWorksheet As Worksheet
            ' For Each myWorksheet In objApp.Workbooks(1).Worksheets
            '     Debug.Print "     " & myWorksheet.name
            '     DoEvents
            ' Next
           
            If InStr(objApp.Workbooks(wbCount).name, "crd") > 0 Then
       
                objApp.Workbooks(wbCount).Close False
                wbCount = wbCount - 1
                If wbCount = objApp.Workbooks.Count Then Exit For
            End If
        Next
        fOk = True
    End If

    GetExcelObjectFromHwnd = fOk

    Exit Function

MyErrorHandler:
    MsgBox "GetExcelObjectFromHwnd" & vbCrLf & vbCrLf & "Err = " & Err.Number & vbCrLf & "Description: " & Err.Description
End Function


[jiri255]

tak to je přesně to co jsem potřeboval... sice jsem nepochopil, jak to makro funguje ,
ale funguje skvěle.
Děkuji mnohokrát za pomoc