Tarayıcı Sekmesi Kapatma Makrosu

[meslek5]

Merhaba değerli üstatlar
İnternet tarayıcısında açık olan sekmelerden aktif olan sekmeyi makro ile kapatabilmem mümkün müdür?
Örneğin 6 adet sekmeden görünür/aktif olan sekmeyi ya da son sekmeyi kapatmak istiyorum.

 

[programer]

Merhabalar,

Aşağıdaki kodlarda hem edge hemde Chrome tarayıcı için çalışır.

Option Explicit

#If Win64 Then
    Private Const NULL_PTR = 0^
#Else
    Private Const NULL_PTR = 0&
#End If

#If VBA7 Then
    Private Declare PtrSafe Function IIDFromString Lib "ole32.dll" (ByVal lpsz As LongPtr, ByVal lpiid As LongPtr) As LongPtr
    Private Declare PtrSafe Function AccessibleObjectFromWindow Lib "OLEACC.DLL" (ByVal hwnd As LongPtr, ByVal dwId As Long, ByVal riid As LongPtr, ppvObject As Any) As Long
    Private Declare PtrSafe Function AccessibleChildren Lib "oleacc" (ByVal paccContainer As Office.IAccessible, ByVal iChildStart As Long, ByVal cChildren As Long, ByRef rgvarChildren As Any, ByRef pcObtained As Long) As Long
    Private Declare PtrSafe Function GetNextWindow Lib "user32" Alias "GetWindow" (ByVal hwnd As LongPtr, ByVal wFlag As Long) As LongPtr
    Private Declare PtrSafe Function GetTopWindow Lib "user32" (ByVal hwnd As LongPtr) As LongPtr
    Private Declare PtrSafe Function GetClassName Lib "user32" Alias "GetClassNameA" (ByVal hwnd As LongPtr, ByVal lpClassName As String, ByVal nMaxCount As Long) As Long
    Private Declare PtrSafe Function SendMessage Lib "user32" Alias "SendMessageA" (ByVal hwnd As LongPtr, ByVal wMsg As Long, ByVal wParam As LongPtr, lParam As Any) As LongPtr
    Private Declare PtrSafe Function IsIconic Lib "user32" (ByVal hwnd As LongPtr) As Long
#Else
    Private Enum LongPtr
        [_]
    End Enum
    Private Declare Function IIDFromString Lib "ole32.dll" (ByVal lpsz As LongPtr, ByVal lpiid As LongPtr) As LongPtr
    Private Declare Function AccessibleObjectFromWindow Lib "OLEACC.DLL" (ByVal hwnd As LongPtr, ByVal dwId As Long, ByVal riid As LongPtr, ppvObject As Any) As Long
    Private Declare Function AccessibleChildren Lib "oleacc" (ByVal paccContainer As Office.IAccessible, ByVal iChildStart As Long, ByVal cChildren As Long, ByRef rgvarChildren As Any, ByRef pcObtained As Long) As Long
    Private Declare Function GetNextWindow Lib "user32" Alias "GetWindow" (ByVal hwnd As LongPtr, ByVal wFlag As Long) As LongPtr
    Private Declare Function GetTopWindow Lib "user32" (ByVal hwnd As LongPtr) As LongPtr
    Private Declare Function GetClassName Lib "user32" Alias "GetClassNameA" (ByVal hwnd As LongPtr, ByVal lpClassName As String, ByVal nMaxCount As Long) As Long
    Private Declare Function SendMessage Lib "user32" Alias "SendMessageA" (ByVal hwnd As LongPtr, ByVal wMsg As Long, ByVal wParam As LongPtr, lParam As Any) As LongPtr
    Private Declare Function IsIconic Lib "user32" (ByVal hwnd As LongPtr) As Long
#End If


Sub CloseEdgedTabs(ByVal PartialTabCaption As String)

    Const SC_RESTORE = &HF120&
    Const WM_SYSCOMMAND As Long = &H112
    Const SC_MAXIMIZE As Long = &HF030&
    Const GW_HWNDNEXT = 2&


    Dim AccWidgetWin As IAccessible, AccSystemPane As IAccessible, AccTab As IAccessible
    Dim vTemp As Variant
    Dim sClassName As String * 256&, lRet As Long, i As Long
    Dim hwnd As LongPtr

    hwnd = GetTopWindow(NULL_PTR)
    Do While hwnd <> NULL_PTR
        lRet = GetClassName(hwnd, sClassName, 256&)
        If Left(sClassName, lRet) = "Chrome_WidgetWin_1" Then
            If hwnd Then
                Set AccWidgetWin = HwndToAcc((hwnd))
                Set vTemp = AccWidgetWin
                For i = 1& To 7&
                    If TypeName(vTemp) <> "Empty" Then
                        Call AccessibleChildren(vTemp, Choose(i&, 0&, 0&, 3&, 0&, 0&, 1&, 0&), 1&, vTemp, 1&)
                    End If
                Next i&
                If TypeName(vTemp) <> "Empty" Then
                    Set AccSystemPane = vTemp
                    For i& = 1& To AccSystemPane.accChildCount
                        If InStr(1, AccSystemPane.accName(i&), PartialTabCaption, vbTextCompare) Then
                            DoEvents
                            If IsIconic(hwnd) Then
                                Call SendMessage(hwnd, WM_SYSCOMMAND, SC_MAXIMIZE, ByVal NULL_PTR)
                            End If
                            Set AccTab = AccSystemPane.accChild(i&)
                            AccTab.accDoDefaultAction (AccTab.accChildCount)
                        End If
                    Next i
                End If
            End If
        End If
        hwnd = GetNextWindow(hwnd, GW_HWNDNEXT)
    Loop

End Sub

Private Function HwndToAcc(ByVal hwnd As LongPtr) As IAccessible

    Const ID_ACCESSIBLE As String = "{618736E0-3C3D-11CF-810C-00AA00389B71}"
    Const OBJID_CLIENT = &HFFFFFFFC
    Const S_OK = &H0&

    Dim tGUID(0& To 3&) As Long
    Dim oIAc As IAccessible

    If IIDFromString(StrPtr(ID_ACCESSIBLE), VarPtr(tGUID(0&))) = S_OK Then
        If AccessibleObjectFromWindow(hwnd, OBJID_CLIENT, VarPtr(tGUID(0)), oIAc) = S_OK Then
           Set HwndToAcc = oIAc
        End If
    End If

End Function

Sub Exmaple1()
    'Başlıkları dizeyi içeren tüm sekmeleri kapatır "Excel"
    CloseEdgedTabs PartialTabCaption:="Excel"
End Sub

Sub Exmaple2()
    'Başlıkları dizeyi içeren tüm sekmeleri kapatır "Youtube"
    CloseEdgedTabs PartialTabCaption:="Youtube"
End Sub

Sub CloseChromeTabs(ByVal PartialTabCaption As String)

    Const SC_RESTORE = &HF120&
    Const WM_SYSCOMMAND As Long = &H112
    Const SC_MAXIMIZE As Long = &HF030&
    Const GW_HWNDNEXT = 2&


    Dim AccWidgetWin As IAccessible, AccSystemPane As IAccessible, AccTab As IAccessible
    Dim vTemp As Variant
    Dim sClassName As String * 256&, lRet As Long, i As Long
    Dim hwnd As LongPtr

    hwnd = GetTopWindow(NULL_PTR)
    Do While hwnd <> NULL_PTR
        lRet = GetClassName(hwnd, sClassName, 256&)
        If Left(sClassName, lRet) = "Chrome_WidgetWin_1" Then
            If hwnd Then
                Set AccWidgetWin = HwndToAcc((hwnd))
                Set vTemp = AccWidgetWin
                For i = 1& To 7&
                    If TypeName(vTemp) <> "Empty" Then
                        Call AccessibleChildren(vTemp, Choose(i&, 0&, 0&, 1&, 0&, 0&, 0&, 0&), 1&, vTemp, 1&)
                    End If
                Next i&
                If TypeName(vTemp) <> "Empty" Then
                    Set AccSystemPane = vTemp
                    For i& = 1& To AccSystemPane.accChildCount
                        If InStr(1, AccSystemPane.accName(i&), PartialTabCaption, vbTextCompare) Then
                            DoEvents
                            If IsIconic(hwnd) Then
                                Call SendMessage(hwnd, WM_SYSCOMMAND, SC_MAXIMIZE, ByVal NULL_PTR)
                            End If
                            Set AccTab = AccSystemPane.accChild(i&)
                            AccTab.accDoDefaultAction (AccTab.accChildCount)
                            AccTab.accDoDefaultAction (AccTab.accChildCount)
                        End If
                    Next i
                End If
            End If
        End If
        hwnd = GetNextWindow(hwnd, GW_HWNDNEXT)
    Loop

End Sub

Sub Exmaple1Chrome()
    'Başlıkları dizeyi içeren tüm sekmeleri kapatır "Excel"
    CloseChromeTabs PartialTabCaption:="Excel"
End Sub
Sub Exmaple2Chrome()
    'Başlıkları dizeyi içeren tüm sekmeleri kapatır "Youtube"
    CloseChromeTabs PartialTabCaption:="Youtube"
End Sub