Macro: Open native dialog box in center of Excel

C

centerdialog

New Member
Joined
Sep 26, 2018
Messages
25
I am trying to make an Excel macro that opens the worksheet "Activate" dialog box (normally opened by right clicking on the navigation arrows in the bottom left of the workbook) in the center of the Excel workbook (must work for a multi-monitor set up).


The below code (from: https://www.mrexcel.com/forum/excel-questions/5268-macro-choose-worksheet-view-all-wor-3.html) is just about the most elegant way to open the "Activate" dialog box. I would like to amend this code so that the native dialog box will always open in the center of the Excel workbook no matter its size or which monitor Excel is running in. I do not want to make a Userform or Msgbox for this.


Unfortunately, I do not know how to code or where to begin with making this amendment. Would anyone be able to help or does anyone have any idea how this would be done? Thanks very much.



<code class="yklcuq-7 iRRQrr">x = ActiveWorkbook.Sheets.Count
If x > 16 Then
Application.CommandBars("Workbook Tabs").Controls("More Sheets...").Execute
Else
Application.CommandBars("Workbook Tabs").ShowPopup
End If</code>
 
Sort by date Sort by votes
See if this works for you :


Workbook Example


Sans titrexx.png





In a Standard Module :
VBA Code: 
Option Explicit

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

Private Type POINTAPI
    X As Long
    Y As Long
End Type

Private Type RECT
    Left As Long
    Top As Long
    Right As Long
    Bottom As Long
End Type


#If VBA7 Then

    #If Win64 Then
        Private Declare PtrSafe Function PtInRect Lib "user32" (lpRect As RECT, ByVal arg2 As LongPtr) As Long
        Private Declare PtrSafe Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (Destination As Any, Source As Any, ByVal Length As LongPtr)
    #Else
        Private Declare PtrSafe Function PtInRect Lib "user32" (lpRect As RECT, ByVal arg1 As Long, ByVal arg2 As Long) As Long
    #End If

    Private Declare PtrSafe Function FindWindow Lib "user32" Alias "FindWindowA" (ByVal lpClassName As String, ByVal lpWindowName As String) As LongPtr
    Private Declare PtrSafe Function SetTimer Lib "user32" (ByVal hwnd As LongPtr, ByVal nIDEvent As LongPtr, ByVal uElapse As Long, ByVal lpTimerFunc As LongPtr) As LongPtr
    Private Declare PtrSafe Function KillTimer Lib "user32" (ByVal hwnd As LongPtr, ByVal nIDEvent As LongPtr) As Long
    Private Declare PtrSafe Function SetRect Lib "user32" (lpRect As RECT, ByVal X1 As Long, ByVal Y1 As Long, ByVal X2 As Long, ByVal Y2 As Long) As Long
    Private Declare PtrSafe Function GetAsyncKeyState Lib "user32" (ByVal vKey As Long) As Integer
    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 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 IIDFromString Lib "ole32.dll" (ByVal lpsz As LongPtr, ByVal lpiid As LongPtr) As LongPtr
    Private Declare PtrSafe Function GetAncestor Lib "user32" (ByVal hwnd As LongPtr, ByVal gaFlags As Long) As LongPtr
    Private Declare PtrSafe Function SetWindowPos Lib "user32" (ByVal hwnd As LongPtr, ByVal hWndInsertAfter As LongPtr, ByVal X As Long, ByVal Y As Long, ByVal cx As Long, ByVal cy As Long, ByVal wFlags As Long) As Long
    Private Declare PtrSafe Function GetWindowRect Lib "user32" (ByVal hwnd As LongPtr, lpRect As RECT) As Long
    Private Declare PtrSafe Function ShowWindow Lib "user32" (ByVal hwnd As LongPtr, ByVal nCmdShow As Long) As Long
    Private Declare PtrSafe Function InvalidateRect Lib "user32" (ByVal hwnd As LongPtr, ByVal lpRect As Long, ByVal bErase 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 IsWindow Lib "user32" (ByVal hwnd As LongPtr) As Long
    Private Declare PtrSafe Function SetCursorPos Lib "user32" (ByVal X As Long, ByVal Y As Long) As Long
    Private Declare PtrSafe Function GetCursorPos Lib "user32.dll" (lpPoint As POINTAPI) As Long
    Private Declare PtrSafe Function SetFocus Lib "user32" (ByVal hwnd As LongPtr) As LongPtr

#Else

    Private Declare Function PtInRect Lib "user32" (lpRect As RECT, ByVal arg1 As Long, ByVal arg2 As Long) As Long
    Private Declare Function FindWindow Lib "user32" Alias "FindWindowA" (ByVal lpClassName As String, ByVal lpWindowName As String) As Long
    Private Declare Function SetTimer Lib "user32" (ByVal hwnd As Long, ByVal nIDEvent As Long, ByVal uElapse As Long, ByVal lpTimerFunc As Long) As Long
    Private Declare Function KillTimer Lib "user32" (ByVal hwnd As Long, ByVal nIDEvent As Long) As Long
    Private Declare Function SetRect Lib "user32" (lpRect As RECT, ByVal X1 As Long, ByVal Y1 As Long, ByVal X2 As Long, ByVal Y2 As Long) As Long
    Private Declare Function GetAsyncKeyState Lib "user32" (ByVal vKey As Long) As Integer
    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 AccessibleObjectFromWindow Lib "OLEACC.DLL" (ByVal hwnd As Long, ByVal dwId As Long, ByVal riid As Long, ppvObject As Any) As Long
    Private Declare Function IIDFromString Lib "ole32.dll" (ByVal lpsz As Long, ByVal lpiid As Long) As Long
    Private Declare Function GetAncestor Lib "user32" (ByVal hwnd As Long, ByVal gaFlags As Long) As Long
    Private Declare Function SetWindowPos Lib "user32" (ByVal hwnd As Long, ByVal hWndInsertAfter As Long, ByVal X As Long, ByVal Y As Long, ByVal cx As Long, ByVal cy As Long, ByVal wFlags As Long) As Long
    Private Declare Function GetWindowRect Lib "user32" (ByVal hwnd As Long, lpRect As RECT) As Long
    Private Declare Function ShowWindow Lib "user32" (ByVal hwnd As Long, ByVal nCmdShow As Long) As Long
    Private Declare Function InvalidateRect Lib "user32" (ByVal hwnd As Long, ByVal lpRect As Long, ByVal bErase As Long) As Long
    Private Declare Function SendMessage Lib "user32" Alias "SendMessageA" (ByVal hwnd As Long, ByVal wMsg As Long, ByVal wParam As Long, lParam As Any) As Long
    Private Declare Function IsWindow Lib "user32" (ByVal hwnd As Long) As Long
    Private Declare Function SetCursorPos Lib "user32" (ByVal X As Long, ByVal Y As Long) As Long
    Private Declare Function GetCursorPos Lib "user32.dll" (lpPoint As POINTAPI) As Long
    Private Declare Function SetFocus Lib "user32" (ByVal hwnd As Long) As Long

#End If


Private Const ID_ACCESSIBLE As String = "{618736E0-3C3D-11CF-810C-00AA00389B71}"
Private Const CHILDID_SELF = &H0&
Private Const OBJID_SELF = &H0&
Private Const NAVDIR_FIRSTCHILD = &H7&
Private Const NAVDIR_DOWN = &H2&
Private Const S_OK = &H0
Private Const SWP_NOSIZE = &H1
Private Const SWP_NOACTIVATE = &H10
Private Const SWP_SHOWWINDOW = &H40
Private Const WM_SETREDRAW = &HB
Private Const GA_PARENT = 1
Private Const GA_ROOT = 2


Private lInitCurX As Long, lInitCurY As Long
Private lTempCurX As Long, lTempCurY As Long
Private sSelectedSheet As String




Public Sub Center_Sheets_List_Dialog()
    If ActiveWorkbook.Sheets.Count < 17 Then
        SetFocus GetAncestor(Application.hwnd, GA_ROOT)
        SetTimer Application.hwnd, Application.hwnd, 0, AddressOf SetListPos
        SendMessage GetAncestor(Application.hwnd, GA_PARENT), ByVal WM_SETREDRAW, ByVal 0, 0
        Application.CommandBars("Workbook Tabs").ShowPopup
    Else
        SetTimer Application.hwnd, 0, 0, AddressOf SetListPos
        Application.CommandBars("Workbook Tabs").Controls(16).Execute
        If Len(sSelectedSheet) Then Worksheets(sSelectedSheet).Activate
    End If
    
End Sub



#If VBA7 Then
    Private Sub SetListPos(ByVal hwnd As LongPtr, ByVal MSG As Long, ByVal nIDEvent As LongPtr, ByVal dwTimer As Long)
    Dim hPopUp As LongPtr
#Else
    Private Sub SetListPos(ByVal hwnd As Long, ByVal MSG As Long, ByVal nIDEvent As Long, ByVal dwTimer As Long)
    Dim hPopUp As Long
#End If

    
    '***************************
    Dim tRectApp As RECT, tRectPopUp As RECT
    Dim cxChild As Long, cyChild As Long, cxParent As Long, cyParent As Long
    Dim X As Long, Y As Long
    Dim sCaption As String, iLCID As Integer
    Dim oCtrl As IAccessible
    '*****************************************
    Dim tGUID(0 To 3) As Long
    Dim oIAcc As IAccessible
    Dim oIAccChild  As IAccessible
    Dim vFocus As Variant
    Dim vAcc As Variant
    Dim tCursPos As POINTAPI
    Dim tOKRect As RECT, tCancelRect As RECT, tListRect As RECT, tXbuttonRect As RECT
    Dim lLeft As Long, lTop As Long, lWidth As Long, lHeight As Long
    Dim bCancel As Boolean
    '*******************************************
    
    On Error Resume Next
    
    KillTimer hwnd, nIDEvent
    
    iLCID = Application.LanguageSettings.LanguageID(msoLanguageIDInstall)

    Select Case iLCID
        Case 1033, 3081, 10249, 4105, 6153, 8201, 5129, 7177, 11273, 2057
            sCaption = "Activate" 'english
        Case 2060, 3084, 5132, 4108, 1036
            sCaption = "Activer" 'french
        Case 1034, 11274, 16394, 13322, 9226, 5130, 7178, 12298, 4106, 18442, 2058, 19466, 6154, 10250, 20490, 15370, 17418, 8202
            sCaption = "Activar" 'spanish
    End Select

    hPopUp = IIf(nIDEvent = hwnd, FindWindow("MsoCommandBarPopup", vbNullString), FindWindow("bosa_sdm_XL9", sCaption))


    'Set the position of the workbook tabs Commandbar Pop-Up or Dialog at the center of the excel window.
    '***************************************************************************************************
    If hPopUp Then

        GetWindowRect hwnd, tRectApp
        GetWindowRect hPopUp, tRectPopUp

        With tRectPopUp
            cxChild = .Right - .Left
            cyChild = .Bottom - .Top
        End With

        With tRectApp
            cxParent = .Right - .Left
            cyParent = .Bottom - .Top
        End With

        X = tRectApp.Left + (cxParent - cxChild) / 2
        Y = tRectApp.Top + (cyParent - cyChild) / 2
        

        If nIDEvent = hwnd Then
            ShowWindow hPopUp, 0
            SendMessage GetAncestor(hwnd, GA_PARENT), ByVal WM_SETREDRAW, ByVal 1&, 0&
            InvalidateRect 0, 0, 0
            For Each oCtrl In Application.CommandBars("Workbook Tabs").Controls
                If oCtrl.accState(CHILDID_SELF) = &H100010 Then
                    oCtrl.accSelect 1, CHILDID_SELF
                    Exit For
                End If
            Next
        End If

        SetWindowPos hPopUp, 0, X, Y, 0, 0, SWP_NOSIZE Or SWP_SHOWWINDOW + SWP_NOACTIVATE
    End If
    
    'Handle special case when there are more than 16 sheets and the Workbooks tab Dialog is shown.
    '********************************************************************************************
    If FindWindow("bosa_sdm_XL9", sCaption) Then
    
        If IIDFromString(StrPtr(ID_ACCESSIBLE), VarPtr(tGUID(0))) = S_OK Then
        
            If AccessibleObjectFromWindow(hPopUp, OBJID_SELF, VarPtr(tGUID(0)), oIAcc) = S_OK Then
            
                Set vAcc = oIAcc
                
                Set oIAccChild = vAcc.accNavigate(NAVDIR_FIRSTCHILD, CHILDID_SELF)
                
                Set oIAccChild = oIAccChild.accNavigate(NAVDIR_DOWN, CHILDID_SELF)
                
                AccessibleChildren vAcc, 1, 1, vAcc, 1
                
                oIAccChild.accChild(4&).accLocation lLeft, lTop, lWidth, lHeight, CHILDID_SELF
                
                SetRect tListRect, lLeft, lTop, lWidth + lLeft, lHeight + lTop

                GetCursorPos tCursPos
                
                lInitCurX = tCursPos.X: lInitCurY = tCursPos.Y
                
                lTempCurX = lLeft + 40: lTempCurY = lTop + 40
                
                'brively move the mouse pointer over the dialog and back... needed to trigger 'accHitTest' !!
                SetTimer Application.hwnd, 0, 0, AddressOf MoveCursor
      
                Do While IsWindow(hPopUp)
                
                    'Store the dialog tabs List Rect.
                    Call oIAccChild.accChild(4&).accLocation(lLeft, lTop, lWidth, lHeight, CHILDID_SELF)
                    SetRect tListRect, lLeft, lTop, lWidth + lLeft, lHeight + lTop

                   'Store the dialog X-Close Menu Rect.
                    vAcc.accLocation lLeft, lTop, lWidth, lHeight, 5&
                    SetRect tXbuttonRect, lLeft, lTop, lLeft + lWidth, lTop + lHeight
        
                    GetCursorPos tCursPos
                    
                    If Err.Number = 0 And TypeName(vFocus.accFocus) <> "Empty" And _
                    TypeName(vFocus.accFocus) <> "IAccessible" Then
                        Set vFocus = oIAcc.accHitTest(tCursPos.X, tCursPos.Y)
                    End If
                    
                    If vFocus.accFocus = 1 Then 'OK button has the focus.
                        sSelectedSheet = oIAccChild.accChild(4&).accValue
                        bCancel = False
                    ElseIf vFocus.accFocus = 2 Then 'Cancel button has the focus.
                        bCancel = True
                    End If
                    
                    'Dialog closed via ESC key or ALT+F4.
                    If (GetAsyncKeyState(vbKeyEscape) <> 0) _
                    Or (GetAsyncKeyState(vbKeyF4) <> 0) Then
                        bCancel = True
                    End If
                    
                    'Dialog closed via the X-close menu.
                    #If VBA7 Then
                        #If Win64 Then
                            Dim lngPtr As LongPtr
                            CopyMemory lngPtr, tCursPos, LenB(tCursPos)
                            If PtInRect(tXbuttonRect, lngPtr) _
                            And (GetAsyncKeyState(vbKeyLButton) <> 0) Then
                                bCancel = True
                            End If
                        #Else
                            If PtInRect(tXbuttonRect, tCursPos.X, tCursPos.Y) _
                            And (GetAsyncKeyState(vbKeyLButton) <> 0) Then
                                bCancel = True
                            End If
                        #End If
                    #Else
                        
                        If PtInRect(tXbuttonRect, tCursPos.X, tCursPos.Y) _
                        And (GetAsyncKeyState(vbKeyLButton) <> 0) Then
                            bCancel = True
                        End If
                    #End If

                    DoEvents
                    
                Loop
                
            End If
            
        End If
        
    End If
    
Xit:
  
    SendMessage GetAncestor(hwnd, GA_PARENT), ByVal WM_SETREDRAW, ByVal 1&, 0&
    
    If bCancel Then sSelectedSheet = ""

End Sub


Private Sub RestoreCursorPos()
    KillTimer Application.hwnd, 0
    Call SetCursorPos(lInitCurX, lInitCurY)
End Sub


Private Sub MoveCursor()
    KillTimer Application.hwnd, 0
    Call SetCursorPos(lTempCurX, lTempCurY)
    SetTimer Application.hwnd, 0, 0, AddressOf RestoreCursorPos
End Sub
 
Upvote 0

Excel Facts

What does custom number format of ;;; mean?
Three semi-colons will hide the value in the cell. Although most people use white font instead.
When I realised what you wanted (in post#2) I quoted Jaafar for you in the hope that he might pop along and I am very glad that he did.
Since then have watched this thread develop - it's been great to watch the expert working through the problem.
I applaud the amazing efforts of @Jaafar Tribak ??? and determination of @centerdialog to pursue this

@Jaafar Tribak Am I missing something here?
Your code opens a standard dialog box allowing user to go to another sheet in the active workbook
It seems simpler to use a Listbox on Userform (in personal macro workbook) as illustrated in the picture and code below


ListSheets.jpg


Code In Personal Workbook
Rich (BB code): 
in Module1
Sub OpenUF()
    UF_ListSheets.Show
End Sub

UserForm code
Private Sub ListBox1_Click()
    ActiveWorkbook.Sheets(ListBox1.Text).Activate
    Unload Me
End Sub
Private Sub UserForm_Initialize()
    Dim ws As Worksheet
    For Each ws In ActiveWorkbook.Worksheets
        ListBox1.AddItem ws.Name
    Next ws
End Sub
 
Upvote 0
Jaafar Tribak said:
See if this works for you :


Workbook Example


View attachment 12892




In a Standard Module :
VBA Code: 
Option Explicit

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

Private Type POINTAPI
    X As Long
    Y As Long
End Type

Private Type RECT
    Left As Long
    Top As Long
    Right As Long
    Bottom As Long
End Type


#If VBA7 Then

    #If Win64 Then
        Private Declare PtrSafe Function PtInRect Lib "user32" (lpRect As RECT, ByVal arg2 As LongPtr) As Long
        Private Declare PtrSafe Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (Destination As Any, Source As Any, ByVal Length As LongPtr)
    #Else
        Private Declare PtrSafe Function PtInRect Lib "user32" (lpRect As RECT, ByVal arg1 As Long, ByVal arg2 As Long) As Long
    #End If

    Private Declare PtrSafe Function FindWindow Lib "user32" Alias "FindWindowA" (ByVal lpClassName As String, ByVal lpWindowName As String) As LongPtr
    Private Declare PtrSafe Function SetTimer Lib "user32" (ByVal hwnd As LongPtr, ByVal nIDEvent As LongPtr, ByVal uElapse As Long, ByVal lpTimerFunc As LongPtr) As LongPtr
    Private Declare PtrSafe Function KillTimer Lib "user32" (ByVal hwnd As LongPtr, ByVal nIDEvent As LongPtr) As Long
    Private Declare PtrSafe Function SetRect Lib "user32" (lpRect As RECT, ByVal X1 As Long, ByVal Y1 As Long, ByVal X2 As Long, ByVal Y2 As Long) As Long
    Private Declare PtrSafe Function GetAsyncKeyState Lib "user32" (ByVal vKey As Long) As Integer
    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 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 IIDFromString Lib "ole32.dll" (ByVal lpsz As LongPtr, ByVal lpiid As LongPtr) As LongPtr
    Private Declare PtrSafe Function GetAncestor Lib "user32" (ByVal hwnd As LongPtr, ByVal gaFlags As Long) As LongPtr
    Private Declare PtrSafe Function SetWindowPos Lib "user32" (ByVal hwnd As LongPtr, ByVal hWndInsertAfter As LongPtr, ByVal X As Long, ByVal Y As Long, ByVal cx As Long, ByVal cy As Long, ByVal wFlags As Long) As Long
    Private Declare PtrSafe Function GetWindowRect Lib "user32" (ByVal hwnd As LongPtr, lpRect As RECT) As Long
    Private Declare PtrSafe Function ShowWindow Lib "user32" (ByVal hwnd As LongPtr, ByVal nCmdShow As Long) As Long
    Private Declare PtrSafe Function InvalidateRect Lib "user32" (ByVal hwnd As LongPtr, ByVal lpRect As Long, ByVal bErase 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 IsWindow Lib "user32" (ByVal hwnd As LongPtr) As Long
    Private Declare PtrSafe Function SetCursorPos Lib "user32" (ByVal X As Long, ByVal Y As Long) As Long
    Private Declare PtrSafe Function GetCursorPos Lib "user32.dll" (lpPoint As POINTAPI) As Long
    Private Declare PtrSafe Function SetFocus Lib "user32" (ByVal hwnd As LongPtr) As LongPtr

#Else

    Private Declare Function PtInRect Lib "user32" (lpRect As RECT, ByVal arg1 As Long, ByVal arg2 As Long) As Long
    Private Declare Function FindWindow Lib "user32" Alias "FindWindowA" (ByVal lpClassName As String, ByVal lpWindowName As String) As Long
    Private Declare Function SetTimer Lib "user32" (ByVal hwnd As Long, ByVal nIDEvent As Long, ByVal uElapse As Long, ByVal lpTimerFunc As Long) As Long
    Private Declare Function KillTimer Lib "user32" (ByVal hwnd As Long, ByVal nIDEvent As Long) As Long
    Private Declare Function SetRect Lib "user32" (lpRect As RECT, ByVal X1 As Long, ByVal Y1 As Long, ByVal X2 As Long, ByVal Y2 As Long) As Long
    Private Declare Function GetAsyncKeyState Lib "user32" (ByVal vKey As Long) As Integer
    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 AccessibleObjectFromWindow Lib "OLEACC.DLL" (ByVal hwnd As Long, ByVal dwId As Long, ByVal riid As Long, ppvObject As Any) As Long
    Private Declare Function IIDFromString Lib "ole32.dll" (ByVal lpsz As Long, ByVal lpiid As Long) As Long
    Private Declare Function GetAncestor Lib "user32" (ByVal hwnd As Long, ByVal gaFlags As Long) As Long
    Private Declare Function SetWindowPos Lib "user32" (ByVal hwnd As Long, ByVal hWndInsertAfter As Long, ByVal X As Long, ByVal Y As Long, ByVal cx As Long, ByVal cy As Long, ByVal wFlags As Long) As Long
    Private Declare Function GetWindowRect Lib "user32" (ByVal hwnd As Long, lpRect As RECT) As Long
    Private Declare Function ShowWindow Lib "user32" (ByVal hwnd As Long, ByVal nCmdShow As Long) As Long
    Private Declare Function InvalidateRect Lib "user32" (ByVal hwnd As Long, ByVal lpRect As Long, ByVal bErase As Long) As Long
    Private Declare Function SendMessage Lib "user32" Alias "SendMessageA" (ByVal hwnd As Long, ByVal wMsg As Long, ByVal wParam As Long, lParam As Any) As Long
    Private Declare Function IsWindow Lib "user32" (ByVal hwnd As Long) As Long
    Private Declare Function SetCursorPos Lib "user32" (ByVal X As Long, ByVal Y As Long) As Long
    Private Declare Function GetCursorPos Lib "user32.dll" (lpPoint As POINTAPI) As Long
    Private Declare Function SetFocus Lib "user32" (ByVal hwnd As Long) As Long

#End If


Private Const ID_ACCESSIBLE As String = "{618736E0-3C3D-11CF-810C-00AA00389B71}"
Private Const CHILDID_SELF = &H0&
Private Const OBJID_SELF = &H0&
Private Const NAVDIR_FIRSTCHILD = &H7&
Private Const NAVDIR_DOWN = &H2&
Private Const S_OK = &H0
Private Const SWP_NOSIZE = &H1
Private Const SWP_NOACTIVATE = &H10
Private Const SWP_SHOWWINDOW = &H40
Private Const WM_SETREDRAW = &HB
Private Const GA_PARENT = 1
Private Const GA_ROOT = 2


Private lInitCurX As Long, lInitCurY As Long
Private lTempCurX As Long, lTempCurY As Long
Private sSelectedSheet As String




Public Sub Center_Sheets_List_Dialog()
    If ActiveWorkbook.Sheets.Count < 17 Then
        SetFocus GetAncestor(Application.hwnd, GA_ROOT)
        SetTimer Application.hwnd, Application.hwnd, 0, AddressOf SetListPos
        SendMessage GetAncestor(Application.hwnd, GA_PARENT), ByVal WM_SETREDRAW, ByVal 0, 0
        Application.CommandBars("Workbook Tabs").ShowPopup
    Else
        SetTimer Application.hwnd, 0, 0, AddressOf SetListPos
        Application.CommandBars("Workbook Tabs").Controls(16).Execute
        If Len(sSelectedSheet) Then Worksheets(sSelectedSheet).Activate
    End If
   
End Sub



#If VBA7 Then
    Private Sub SetListPos(ByVal hwnd As LongPtr, ByVal MSG As Long, ByVal nIDEvent As LongPtr, ByVal dwTimer As Long)
    Dim hPopUp As LongPtr
#Else
    Private Sub SetListPos(ByVal hwnd As Long, ByVal MSG As Long, ByVal nIDEvent As Long, ByVal dwTimer As Long)
    Dim hPopUp As Long
#End If

   
    '***************************
    Dim tRectApp As RECT, tRectPopUp As RECT
    Dim cxChild As Long, cyChild As Long, cxParent As Long, cyParent As Long
    Dim X As Long, Y As Long
    Dim sCaption As String, iLCID As Integer
    Dim oCtrl As IAccessible
    '*****************************************
    Dim tGUID(0 To 3) As Long
    Dim oIAcc As IAccessible
    Dim oIAccChild  As IAccessible
    Dim vFocus As Variant
    Dim vAcc As Variant
    Dim tCursPos As POINTAPI
    Dim tOKRect As RECT, tCancelRect As RECT, tListRect As RECT, tXbuttonRect As RECT
    Dim lLeft As Long, lTop As Long, lWidth As Long, lHeight As Long
    Dim bCancel As Boolean
    '*******************************************
   
    On Error Resume Next
   
    KillTimer hwnd, nIDEvent
   
    iLCID = Application.LanguageSettings.LanguageID(msoLanguageIDInstall)

    Select Case iLCID
        Case 1033, 3081, 10249, 4105, 6153, 8201, 5129, 7177, 11273, 2057
            sCaption = "Activate" 'english
        Case 2060, 3084, 5132, 4108, 1036
            sCaption = "Activer" 'french
        Case 1034, 11274, 16394, 13322, 9226, 5130, 7178, 12298, 4106, 18442, 2058, 19466, 6154, 10250, 20490, 15370, 17418, 8202
            sCaption = "Activar" 'spanish
    End Select

    hPopUp = IIf(nIDEvent = hwnd, FindWindow("MsoCommandBarPopup", vbNullString), FindWindow("bosa_sdm_XL9", sCaption))


    'Set the position of the workbook tabs Commandbar Pop-Up or Dialog at the center of the excel window.
    '***************************************************************************************************
    If hPopUp Then

        GetWindowRect hwnd, tRectApp
        GetWindowRect hPopUp, tRectPopUp

        With tRectPopUp
            cxChild = .Right - .Left
            cyChild = .Bottom - .Top
        End With

        With tRectApp
            cxParent = .Right - .Left
            cyParent = .Bottom - .Top
        End With

        X = tRectApp.Left + (cxParent - cxChild) / 2
        Y = tRectApp.Top + (cyParent - cyChild) / 2
       

        If nIDEvent = hwnd Then
            ShowWindow hPopUp, 0
            SendMessage GetAncestor(hwnd, GA_PARENT), ByVal WM_SETREDRAW, ByVal 1&, 0&
            InvalidateRect 0, 0, 0
            For Each oCtrl In Application.CommandBars("Workbook Tabs").Controls
                If oCtrl.accState(CHILDID_SELF) = &H100010 Then
                    oCtrl.accSelect 1, CHILDID_SELF
                    Exit For
                End If
            Next
        End If

        SetWindowPos hPopUp, 0, X, Y, 0, 0, SWP_NOSIZE Or SWP_SHOWWINDOW + SWP_NOACTIVATE
    End If
   
    'Handle special case when there are more than 16 sheets and the Workbooks tab Dialog is shown.
    '********************************************************************************************
    If FindWindow("bosa_sdm_XL9", sCaption) Then
   
        If IIDFromString(StrPtr(ID_ACCESSIBLE), VarPtr(tGUID(0))) = S_OK Then
       
            If AccessibleObjectFromWindow(hPopUp, OBJID_SELF, VarPtr(tGUID(0)), oIAcc) = S_OK Then
           
                Set vAcc = oIAcc
               
                Set oIAccChild = vAcc.accNavigate(NAVDIR_FIRSTCHILD, CHILDID_SELF)
               
                Set oIAccChild = oIAccChild.accNavigate(NAVDIR_DOWN, CHILDID_SELF)
               
                AccessibleChildren vAcc, 1, 1, vAcc, 1
               
                oIAccChild.accChild(4&).accLocation lLeft, lTop, lWidth, lHeight, CHILDID_SELF
               
                SetRect tListRect, lLeft, lTop, lWidth + lLeft, lHeight + lTop

                GetCursorPos tCursPos
               
                lInitCurX = tCursPos.X: lInitCurY = tCursPos.Y
               
                lTempCurX = lLeft + 40: lTempCurY = lTop + 40
               
                'brively move the mouse pointer over the dialog and back... needed to trigger 'accHitTest' !!
                SetTimer Application.hwnd, 0, 0, AddressOf MoveCursor
     
                Do While IsWindow(hPopUp)
               
                    'Store the dialog tabs List Rect.
                    Call oIAccChild.accChild(4&).accLocation(lLeft, lTop, lWidth, lHeight, CHILDID_SELF)
                    SetRect tListRect, lLeft, lTop, lWidth + lLeft, lHeight + lTop

                   'Store the dialog X-Close Menu Rect.
                    vAcc.accLocation lLeft, lTop, lWidth, lHeight, 5&
                    SetRect tXbuttonRect, lLeft, lTop, lLeft + lWidth, lTop + lHeight
       
                    GetCursorPos tCursPos
                   
                    If Err.Number = 0 And TypeName(vFocus.accFocus) <> "Empty" And _
                    TypeName(vFocus.accFocus) <> "IAccessible" Then
                        Set vFocus = oIAcc.accHitTest(tCursPos.X, tCursPos.Y)
                    End If
                   
                    If vFocus.accFocus = 1 Then 'OK button has the focus.
                        sSelectedSheet = oIAccChild.accChild(4&).accValue
                        bCancel = False
                    ElseIf vFocus.accFocus = 2 Then 'Cancel button has the focus.
                        bCancel = True
                    End If
                   
                    'Dialog closed via ESC key or ALT+F4.
                    If (GetAsyncKeyState(vbKeyEscape) <> 0) _
                    Or (GetAsyncKeyState(vbKeyF4) <> 0) Then
                        bCancel = True
                    End If
                   
                    'Dialog closed via the X-close menu.
                    #If VBA7 Then
                        #If Win64 Then
                            Dim lngPtr As LongPtr
                            CopyMemory lngPtr, tCursPos, LenB(tCursPos)
                            If PtInRect(tXbuttonRect, lngPtr) _
                            And (GetAsyncKeyState(vbKeyLButton) <> 0) Then
                                bCancel = True
                            End If
                        #Else
                            If PtInRect(tXbuttonRect, tCursPos.X, tCursPos.Y) _
                            And (GetAsyncKeyState(vbKeyLButton) <> 0) Then
                                bCancel = True
                            End If
                        #End If
                    #Else
                       
                        If PtInRect(tXbuttonRect, tCursPos.X, tCursPos.Y) _
                        And (GetAsyncKeyState(vbKeyLButton) <> 0) Then
                            bCancel = True
                        End If
                    #End If

                    DoEvents
                   
                Loop
               
            End If
           
        End If
       
    End If
   
Xit:
 
    SendMessage GetAncestor(hwnd, GA_PARENT), ByVal WM_SETREDRAW, ByVal 1&, 0&
   
    If bCancel Then sSelectedSheet = ""

End Sub


Private Sub RestoreCursorPos()
    KillTimer Application.hwnd, 0
    Call SetCursorPos(lInitCurX, lInitCurY)
End Sub


Private Sub MoveCursor()
    KillTimer Application.hwnd, 0
    Call SetCursorPos(lTempCurX, lTempCurY)
    SetTimer Application.hwnd, 0, 0, AddressOf RestoreCursorPos
End Sub
Click to expand...


Thank you Jafaar, so kind of you to return to this tedious puzzle. I have tested the new code, but unfortunately the Command Bar issue is now an intermittent one.

In my first trial run, running the macro with the following number of worksheets in the Excel workbook caused the blank white screen to appear: 1, 2, 3, 5, 6, 7, 10, 12, 13, 15, and 16.

I did a second trial run but this time the following number of worksheet's caused the blank white screen: 4, 5, 6, 9, 10, 12. So the issue seems to be intermittent and unpredictable to me.

Any ideas on this? Also, please let me know how you were so quickly able to diagnose the issue as I'd love to learn your approach so I can improve.
 
Upvote 0
Yongle said:
When I realised what you wanted (in post#2) I quoted Jaafar for you in the hope that he might pop along and I am very glad that he did.
Since then have watched this thread develop - it's been great to watch the expert working through the problem.
I applaud the amazing efforts of @Jaafar Tribak ??? and determination of @centerdialog to pursue this

@Jaafar Tribak Am I missing something here?
Your code opens a standard dialog box allowing user to go to another sheet in the active workbook
It seems simpler to use a Listbox on Userform (in personal macro workbook) as illustrated in the picture and code below


View attachment 12901

Code In Personal Workbook
Rich (BB code): 
in Module1
Sub OpenUF()
    UF_ListSheets.Show
End Sub

UserForm code
Private Sub ListBox1_Click()
    ActiveWorkbook.Sheets(ListBox1.Text).Activate
    Unload Me
End Sub
Private Sub UserForm_Initialize()
    Dim ws As Worksheet
    For Each ws In ActiveWorkbook.Worksheets
        ListBox1.AddItem ws.Name
    Next ws
End Sub
Click to expand...

Hi Yongle, thanks for your reply and for connecting me with Jafaar. Fully agree he is a pure professional (and a generous one), but I'm like a rabid dog trying to chase a carrot here so I don't deserve much praise haha.

As you mentioned, I provided certain stipulations in the solution I was looking for (namely, a native dialog box solution given my OCD and finicky experience with listboxes in the past) and Jafaar has been kind enough to help me stick to this native dialog box route. I did not fully appreciate the challenges with this path or the effort it would require but it helps put my OCD to rest if nothing else.
 
Upvote 0
@Yongle
Thanks for the follow up and interest.
As you mentioned, using a userform with a listbox would be ideal for solving this and straightforward to code but since the OP didn't want to use a listbox, I thought maybe I can try manipulating the excel native commandbar & dialog with a few API calls and see if that would give us the desired results and at the same time I would learn something in the process.

@centerdialog
I tested the code in excel 2016 and works well consistently for me. I didn't experience the intermittent commandbar issue you described.
Is the issue happening in excel 2019 or 2016?

Regards.
 
Upvote 0
Ok- Here is a completly different approach in which I now use the SetWinEventHook API instead of a Windows Timer ... I think this approach is more solid, doesn't block screen redrawing and should hopefully work without issues.

Workbook Example


- In a Standard Module : (Run the "Center_Sheets_List_Dialog" routine)
VBA Code: 
Option Explicit

Private Type RECT
    Left As Long
    Top As Long
    Right As Long
    Bottom As Long
End Type

#If VBA7 Then
    Private Declare PtrSafe Function SetWinEventHook Lib "user32.dll" (ByVal eventMin As Long, ByVal eventMax As Long, ByVal hmodWinEventProc As LongPtr, ByVal pfnWinEventProc As LongPtr, ByVal idProcess As Long, ByVal idThread As Long, ByVal dwFlags As Long) As LongPtr
    Private Declare PtrSafe Function UnhookWinEvent Lib "user32" (ByVal hWinEventHook As LongPtr) As LongPtr
    Private Declare PtrSafe Function GetWindowRect Lib "user32" (ByVal hwnd As LongPtr, lpRect As RECT) As Long
    Private Declare PtrSafe Function SetWindowPos Lib "user32" (ByVal hwnd As LongPtr, ByVal hWndInsertAfter As LongPtr, ByVal X As Long, ByVal Y As Long, ByVal cx As Long, ByVal cy As Long, ByVal wFlags As Long) As Long
    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 SetProp Lib "user32" Alias "SetPropA" (ByVal hwnd As LongPtr, ByVal lpString As String, ByVal hData As LongPtr) As Long
    Private Declare PtrSafe Function GetProp Lib "user32" Alias "GetPropA" (ByVal hwnd As LongPtr, ByVal lpString As String) As LongPtr
    Private Declare PtrSafe Function RemoveProp Lib "user32" Alias "RemovePropA" (ByVal hwnd As LongPtr, ByVal lpString As String) As LongPtr
#Else
    Private Declare Function SetWinEventHook Lib "user32.dll" (ByVal eventMin As Long, ByVal eventMax As Long, ByVal hmodWinEventProc As Long, ByVal pfnWinEventProc As Long, ByVal idProcess As Long, ByVal idThread As Long, ByVal dwFlags As Long) As Long
    Private Declare Function UnhookWinEvent Lib "user32" (ByVal hWinEventHook As Long) As Long
    Private Declare Function GetWindowRect Lib "user32" (ByVal hwnd As Long, lpRect As RECT) As Long
    Private Declare Function SetWindowPos Lib "user32" (ByVal hwnd As Long, ByVal hWndInsertAfter As Long, ByVal X As Long, ByVal Y As Long, ByVal cx As Long, ByVal cy As Long, ByVal wFlags As Long) As Long
    Private Declare Function GetClassName Lib "user32" Alias "GetClassNameA" (ByVal hwnd As Long, ByVal lpClassName As String, ByVal nMaxCount As Long) As Long
    Private Declare Function SetProp Lib "user32" Alias "SetPropA" (ByVal hwnd As Long, ByVal lpString As String, ByVal hData As Long) As Long
    Private Declare Function GetProp Lib "user32" Alias "GetPropA" (ByVal hwnd As Long, ByVal lpString As String) As Long
    Private Declare Function RemoveProp Lib "user32" Alias "RemovePropA" (ByVal hwnd As Long, ByVal lpString As String) As Long
#End If



Public Sub Center_Sheets_List_Dialog()
            
    Dim X As Long, Y As Long
    Dim cxChild As Long, cyChild As Long, cxParent As Long, cyParent As Long
    Dim tRectApp As RECT, tRectPopUp As RECT
  
    If ActiveWorkbook.Sheets.Count < 17 Then
        GetWindowRect Application.hwnd, tRectApp
        With tRectApp
            cxParent = .Right - .Left
            cyParent = .Bottom - .Top
        End With
        With tRectPopUp
            cxChild = Application.CommandBars("Workbook Tabs").Width
            cyChild = Application.CommandBars("Workbook Tabs").Height
        End With
        X = tRectApp.Left + (cxParent - cxChild) / 2
        Y = tRectApp.Top + (cyParent - cyChild) / 2
        Application.CommandBars("Workbook Tabs").ShowPopup X, Y
    Else
        EnableHook = True
            Application.CommandBars("Workbook Tabs").Controls(16).Execute
        EnableHook = False
    End If

End Sub



Public Property Let EnableHook(ByVal Enable As Boolean)

    #If VBA7 Then
        Dim hEventHook As LongPtr
    #Else
        Dim hEventHook As Long
    #End If

    Const EVENT_SYSTEM_FOREGROUND As Long = &H3&
    Const WINEVENT_OUTOFCONTEXT = 0
  
    If Enable Then
        If GetProp(Application.hwnd, "EventHook") = 0 Then
             hEventHook = SetWinEventHook(EVENT_SYSTEM_FOREGROUND, EVENT_SYSTEM_FOREGROUND, 0&, AddressOf WinEventFunc, 0, 0, WINEVENT_OUTOFCONTEXT)
             If hEventHook Then
                Call SetProp(Application.hwnd, "EventHook", hEventHook)
                Debug.Print "Hook Enabled"
            End If
        End If
    Else
        Call UnhookWinEvent(GetProp(Application.hwnd, "EventHook"))
        Call RemoveProp(Application.hwnd, "EventHook")
        Debug.Print "Hook Disabled"
    End If

End Property



#If VBA7 Then
    Private Function WinEventFunc(ByVal HookHandle As LongPtr, ByVal LEvent As Long, ByVal hwnd As LongPtr, ByVal idObject As Long, ByVal idChild As Long, ByVal idEventThread As Long, ByVal dwmsEventTime As Long) As LongPtr
        Dim hDlg As LongPtr
#Else
    Private Function WinEventFunc(ByVal HookHandle As Long, ByVal LEvent As Long, ByVal hwnd As Long, ByVal idObject As Long, ByVal idChild As Long, ByVal idEventThread As Long, ByVal dwmsEventTime As Long) As Long
        Dim hDlg As Long
#End If

    Const EVENT_SYSTEM_FOREGROUND As Long = &H3&
    Const SWP_NOSIZE = &H1
    Const SWP_NOACTIVATE = &H10
    Const SWP_SHOWWINDOW = &H40

    Dim tRectApp As RECT, tRectDlg As RECT
    Dim lRet As Long, sBuff As String * 256
    Dim X As Long, Y As Long
    Dim cxChild As Long, cyChild As Long, cxParent As Long, cyParent As Long

    If LEvent = EVENT_SYSTEM_FOREGROUND Then
        If hwnd = Application.hwnd Then
            EnableHook = False
        Else
            Call GetWindowRect(Application.hwnd, tRectApp)
            Call GetWindowRect(hwnd, tRectDlg)
            lRet = GetClassName(hwnd, sBuff, 256)
            If Left(sBuff, lRet) = "bosa_sdm_XL9" Then
                With tRectApp
                    cxParent = .Right - .Left
                    cyParent = .Bottom - .Top
                End With
                With tRectDlg
                    cxChild = .Right - .Left
                    cyChild = .Bottom - .Top
                End With
                X = tRectApp.Left + (cxParent - cxChild) / 2
                Y = tRectApp.Top + (cyParent - cyChild) / 2
                Call SetWindowPos(hwnd, 0, X, Y, 0, 0, SWP_NOSIZE Or 0 + SWP_NOACTIVATE)
            End If
        End If
    End If

End Function
 
Upvote 0
Jaafar Tribak said:
Ok- Here is a completly different approach in which I now use the SetWinEventHook API instead of a Windows Timer ... I think this approach is more solid, doesn't block screen redrawing and should hopefully work without issues.

Workbook Example


- In a Standard Module : (Run the "Center_Sheets_List_Dialog" routine)
VBA Code: 
Option Explicit

Private Type RECT
    Left As Long
    Top As Long
    Right As Long
    Bottom As Long
End Type

#If VBA7 Then
    Private Declare PtrSafe Function SetWinEventHook Lib "user32.dll" (ByVal eventMin As Long, ByVal eventMax As Long, ByVal hmodWinEventProc As LongPtr, ByVal pfnWinEventProc As LongPtr, ByVal idProcess As Long, ByVal idThread As Long, ByVal dwFlags As Long) As LongPtr
    Private Declare PtrSafe Function UnhookWinEvent Lib "user32" (ByVal hWinEventHook As LongPtr) As LongPtr
    Private Declare PtrSafe Function GetWindowRect Lib "user32" (ByVal hwnd As LongPtr, lpRect As RECT) As Long
    Private Declare PtrSafe Function SetWindowPos Lib "user32" (ByVal hwnd As LongPtr, ByVal hWndInsertAfter As LongPtr, ByVal X As Long, ByVal Y As Long, ByVal cx As Long, ByVal cy As Long, ByVal wFlags As Long) As Long
    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 SetProp Lib "user32" Alias "SetPropA" (ByVal hwnd As LongPtr, ByVal lpString As String, ByVal hData As LongPtr) As Long
    Private Declare PtrSafe Function GetProp Lib "user32" Alias "GetPropA" (ByVal hwnd As LongPtr, ByVal lpString As String) As LongPtr
    Private Declare PtrSafe Function RemoveProp Lib "user32" Alias "RemovePropA" (ByVal hwnd As LongPtr, ByVal lpString As String) As LongPtr
#Else
    Private Declare Function SetWinEventHook Lib "user32.dll" (ByVal eventMin As Long, ByVal eventMax As Long, ByVal hmodWinEventProc As Long, ByVal pfnWinEventProc As Long, ByVal idProcess As Long, ByVal idThread As Long, ByVal dwFlags As Long) As Long
    Private Declare Function UnhookWinEvent Lib "user32" (ByVal hWinEventHook As Long) As Long
    Private Declare Function GetWindowRect Lib "user32" (ByVal hwnd As Long, lpRect As RECT) As Long
    Private Declare Function SetWindowPos Lib "user32" (ByVal hwnd As Long, ByVal hWndInsertAfter As Long, ByVal X As Long, ByVal Y As Long, ByVal cx As Long, ByVal cy As Long, ByVal wFlags As Long) As Long
    Private Declare Function GetClassName Lib "user32" Alias "GetClassNameA" (ByVal hwnd As Long, ByVal lpClassName As String, ByVal nMaxCount As Long) As Long
    Private Declare Function SetProp Lib "user32" Alias "SetPropA" (ByVal hwnd As Long, ByVal lpString As String, ByVal hData As Long) As Long
    Private Declare Function GetProp Lib "user32" Alias "GetPropA" (ByVal hwnd As Long, ByVal lpString As String) As Long
    Private Declare Function RemoveProp Lib "user32" Alias "RemovePropA" (ByVal hwnd As Long, ByVal lpString As String) As Long
#End If



Public Sub Center_Sheets_List_Dialog()
           
    Dim X As Long, Y As Long
    Dim cxChild As Long, cyChild As Long, cxParent As Long, cyParent As Long
    Dim tRectApp As RECT, tRectPopUp As RECT
 
    If ActiveWorkbook.Sheets.Count < 17 Then
        GetWindowRect Application.hwnd, tRectApp
        With tRectApp
            cxParent = .Right - .Left
            cyParent = .Bottom - .Top
        End With
        With tRectPopUp
            cxChild = Application.CommandBars("Workbook Tabs").Width
            cyChild = Application.CommandBars("Workbook Tabs").Height
        End With
        X = tRectApp.Left + (cxParent - cxChild) / 2
        Y = tRectApp.Top + (cyParent - cyChild) / 2
        Application.CommandBars("Workbook Tabs").ShowPopup X, Y
    Else
        EnableHook = True
            Application.CommandBars("Workbook Tabs").Controls(16).Execute
        EnableHook = False
    End If

End Sub



Public Property Let EnableHook(ByVal Enable As Boolean)

    #If VBA7 Then
        Dim hEventHook As LongPtr
    #Else
        Dim hEventHook As Long
    #End If

    Const EVENT_SYSTEM_FOREGROUND As Long = &H3&
    Const WINEVENT_OUTOFCONTEXT = 0
 
    If Enable Then
        If GetProp(Application.hwnd, "EventHook") = 0 Then
             hEventHook = SetWinEventHook(EVENT_SYSTEM_FOREGROUND, EVENT_SYSTEM_FOREGROUND, 0&, AddressOf WinEventFunc, 0, 0, WINEVENT_OUTOFCONTEXT)
             If hEventHook Then
                Call SetProp(Application.hwnd, "EventHook", hEventHook)
                Debug.Print "Hook Enabled"
            End If
        End If
    Else
        Call UnhookWinEvent(GetProp(Application.hwnd, "EventHook"))
        Call RemoveProp(Application.hwnd, "EventHook")
        Debug.Print "Hook Disabled"
    End If

End Property



#If VBA7 Then
    Private Function WinEventFunc(ByVal HookHandle As LongPtr, ByVal LEvent As Long, ByVal hwnd As LongPtr, ByVal idObject As Long, ByVal idChild As Long, ByVal idEventThread As Long, ByVal dwmsEventTime As Long) As LongPtr
        Dim hDlg As LongPtr
#Else
    Private Function WinEventFunc(ByVal HookHandle As Long, ByVal LEvent As Long, ByVal hwnd As Long, ByVal idObject As Long, ByVal idChild As Long, ByVal idEventThread As Long, ByVal dwmsEventTime As Long) As Long
        Dim hDlg As Long
#End If

    Const EVENT_SYSTEM_FOREGROUND As Long = &H3&
    Const SWP_NOSIZE = &H1
    Const SWP_NOACTIVATE = &H10
    Const SWP_SHOWWINDOW = &H40

    Dim tRectApp As RECT, tRectDlg As RECT
    Dim lRet As Long, sBuff As String * 256
    Dim X As Long, Y As Long
    Dim cxChild As Long, cyChild As Long, cxParent As Long, cyParent As Long

    If LEvent = EVENT_SYSTEM_FOREGROUND Then
        If hwnd = Application.hwnd Then
            EnableHook = False
        Else
            Call GetWindowRect(Application.hwnd, tRectApp)
            Call GetWindowRect(hwnd, tRectDlg)
            lRet = GetClassName(hwnd, sBuff, 256)
            If Left(sBuff, lRet) = "bosa_sdm_XL9" Then
                With tRectApp
                    cxParent = .Right - .Left
                    cyParent = .Bottom - .Top
                End With
                With tRectDlg
                    cxChild = .Right - .Left
                    cyChild = .Bottom - .Top
                End With
                X = tRectApp.Left + (cxParent - cxChild) / 2
                Y = tRectApp.Top + (cyParent - cyChild) / 2
                Call SetWindowPos(hwnd, 0, X, Y, 0, 0, SWP_NOSIZE Or 0 + SWP_NOACTIVATE)
            End If
        End If
    End If

End Function
Click to expand...


Brilliant, man. This works perfectly on all monitors and in all cases. Thanks for restoring the macro and finding a new solution. To answer your earlier question, the issue was happening in Excel 2019 only which I'm sure was the culprit.


Also, in the spirit of learning that you mentioned and since you and Yongle insisted a listbox is ideal, I decided to try it out. Apologies for my incompetence, but after creating a user form, making it a list box, pasting in Yongle's code and then pasting in Yongle's code for the module, I kept getting the "Runtime Error 424" error with message "Object Required". Was this because I didn't properly customize the user form using the tool box so that it matches your code, Yongle?
 
Upvote 0
centerdialog said:
but after creating a user form, making it a list box, pasting in Yongle's code and then pasting in Yongle's code for the module, I kept getting the "Runtime Error 424" error with message "Object Required". Was this because I didn't properly customize the user form using the tool box so that it matches your code, Yongle?
Click to expand...

The basics
(get it working first, customize later)

IN PERSONAL WORKBOOK
- add userform
- amend userform NAME property to UF_ListSheets
- add a ListBox (should be autonamed ListBox1 )
- add the code below

USERFORM CODE
VBA Code: 
Private Sub ListBox1_Click()
    ActiveWorkbook.Sheets(ListBox1.Text).Activate
    Unload Me
End Sub
Private Sub UserForm_Initialize()
    Dim ws As Worksheet
    For Each ws In ActiveWorkbook.Worksheets
        ListBox1.AddItem ws.Name
    Next ws
End Sub
IN A MODULE (also in Personal workbook)
VBA Code: 
Sub OpenUF()
    UF_ListSheets.Show
End Sub

To run from another workbook
- use a shortcut attached to a simple macro
VBA Code: 
Sub SelectSheet()
    Application.Run "Personal.XLSB!OpenUF"
End Sub

- or customise the ribbon \ and add it to quick access toolbar etc

Customiseribbon.jpg



As an Add-in
Consider creating your own add-in
(see link below for detailed instructions)
trumpexcel.com

How to Create and Use an Excel Add-in (Step-by-Step Tutorial)

In this tutorial, you'll learn how to create and use and Excel Add-in in all the Excel Workbooks. An add-in can be useful when you have to repeat tasks.
trumpexcel.com trumpexcel.com
 
Upvote 0
centerdialog said:
Brilliant, man. This works perfectly on all monitors and in all cases. Thanks for restoring the macro and finding a new solution. To answer your earlier question, the issue was happening in Excel 2019 only which I'm sure was the culprit.
Click to expand...

I am glad we got this working in the end :)
 
Upvote 0
Yongle said:
The basics
(get it working first, customize later)

IN PERSONAL WORKBOOK
- add userform
- amend userform NAME property to UF_ListSheets
- add a ListBox (should be autonamed ListBox1 )
- add the code below

USERFORM CODE
VBA Code: 
Private Sub ListBox1_Click()
    ActiveWorkbook.Sheets(ListBox1.Text).Activate
    Unload Me
End Sub
Private Sub UserForm_Initialize()
    Dim ws As Worksheet
    For Each ws In ActiveWorkbook.Worksheets
        ListBox1.AddItem ws.Name
    Next ws
End Sub
IN A MODULE (also in Personal workbook)
VBA Code: 
Sub OpenUF()
    UF_ListSheets.Show
End Sub

To run from another workbook
- use a shortcut attached to a simple macro
VBA Code: 
Sub SelectSheet()
    Application.Run "Personal.XLSB!OpenUF"
End Sub

- or customise the ribbon \ and add it to quick access toolbar etc

View attachment 12964


As an Add-in
Consider creating your own add-in
(see link below for detailed instructions)
trumpexcel.com

How to Create and Use an Excel Add-in (Step-by-Step Tutorial)

In this tutorial, you'll learn how to create and use and Excel Add-in in all the Excel Workbooks. An add-in can be useful when you have to repeat tasks.
trumpexcel.com trumpexcel.com
Click to expand...

Thanks for the walk through, I failed to rename the ListBox which is what caused the issues.

Initial observations regarding the ListBox:
1. Unlike the native dialog box , the ListBox does not allow the user to navigate the workbook's worksheets list using the up and down arrows because the ListBox instantly jumps to whatever worksheet is single-clicked or "soft" selected (no need to press enter, for example), so if the user has 50 sheets and runs the macro, his "cursor" will always "soft" select the first worksheet, and after he presses down arrow once on his way down the list, the ListBox will instantly navigate to the second worksheet and close the ListBox. The Home and End buttons, do function properly, however. I suspect this issue can't be fixed and I'm not surprised this is occurring, as I mentioned above, there are always finicky issues with custom solutions like this.

2. Unlike the native dialog box and even browser drop down menus, the ListBox does not allow the user to rapidly type the letters of a specific worksheet and skip to said worksheet, instead, the ListBox will instantly skip to and select the first worksheet that has the first letter typed and then it will close the ListBox (i.e., user's first worksheet is named "Car" and last is named "Call" with 50 worksheets in between, as soon as the user presses "C", ListBox will open worksheet "Car" and close itself. I suspect this issue can't be fixed.

3. I tried creating 50 worksheets and turned the ListBox's ScrollBars item to 2 to activate the vertical scroll bar. It did activate it, but only the top and bottom arrows on the scroll bar and not the actual slider, so no click dragging of slider, and no clicking up or down ScrollBar arrows to move up and down the list. In other words, because of issues #1 and #2 above, I tried to resort to a scroll bar to navigate within the ListBox and was still unable to do so. Will assume I was just doing this wrong and that it is indeed possible to get the scroll bar working.


Anyway, Yongle, I only did this to test the ListBox out and see what it brings to the table. I will be sticking completely to the native solution Jafaar provided so don't feel the need to waste your time addressing any of the above issues even if they can be fixed. Just wanted to share, and justify why I was adamant about a native solution.
 
Upvote 0
You must log in or register to reply here.

Similar threads

A
  • Question Question
Saving dialog box hanging after running macro
2
Replies
16
Views
302
Alex Blakenburg
A
T
  • Question Question
Save As Dialog Box with File Name Predetermined for Ppt file through Excel
2
Replies
10
Views
134
tbakbradley
T
A
  • Solved
Extract and Merge Files
Replies
1
Views
110
rowebca
rowebca
I
  • Question Question
Show the "Edit Name" dialog from VBA for a specific Name
Replies
1
Views
844
Jaafar Tribak
Jaafar Tribak
J
  • Solved
Macro gives message box every time something is deleted
Replies
7
Views
226
Peter_SSs
Peter_SSs

Forum statistics

Threads
1,223,904
Messages
6,175,295
Members
452,631
Latest member
a_potato

Share this page

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Back
Top