Option Explicit
Private Type GUID
Data1 As Long
Data2 As Integer
Data3 As Integer
Data4(0 To 7) As Byte
End Type
#If VBA7 Then
Private Declare PtrSafe Function DispCallFunc Lib "oleAut32.dll" (ByVal pvInstance As LongPtr, ByVal offsetinVft As LongPtr, ByVal CallConv As Long, ByVal retTYP As Integer, ByVal paCNT As Long, ByRef paTypes As Integer, ByRef paValues As LongPtr, ByRef retVAR As Variant) As Long
Private Declare PtrSafe Function StringFromGUID2 Lib "ole32" (ByRef rguid As GUID, ByVal lpsz As LongPtr, ByVal cchMax As Long) As Long
Private Declare PtrSafe Function CLSIDFromString Lib "ole32" (ByVal OleStringCLSID As LongPtr, ByRef cGUID As GUID) As Long
Private Declare PtrSafe Function CoCreateInstance Lib "ole32" (ByRef rclsid As GUID, ByVal pUnkOuter As LongPtr, ByVal dwClsContext As Long, ByRef riid As GUID, ByRef ppv As LongPtr) As Long
Private Declare PtrSafe Function SysReAllocString Lib "oleAut32.dll" (ByVal pBSTR As LongPtr, Optional ByVal pszStrPtr As LongPtr) As Long
Private Declare PtrSafe Function SetProcessDPIAware Lib "user32" () As Long
Private Declare PtrSafe Sub SetLastError Lib "kernel32" (ByVal dwErrCode As Long)
Private Declare PtrSafe Function GetCursorPos Lib "user32" (lpPoint As Currency) As Long
Private Declare PtrSafe Function GetAsyncKeyState Lib "user32" (ByVal vKey As Long) As Integer
#Else
Private Declare Function DispCallFunc Lib "oleAut32.dll" (ByVal pvInstance As Long, ByVal offsetinVft As Long, ByVal CallConv As Long, ByVal retTYP As Integer, ByVal paCNT As Long, ByRef paTypes As Integer, ByRef paValues As Long, ByRef retVAR As Variant) As Long
Private Declare Function StringFromGUID2 Lib "ole32" (ByRef rguid As GUID, ByVal lpsz As Long, ByVal cchMax As Long) As Long
Private Declare Function CLSIDFromString Lib "ole32" (ByVal OleStringCLSID As Long, ByRef cGUID As GUID) As Long
Private Declare Function CoCreateInstance Lib "ole32" (ByRef rclsid As GUID, ByVal pUnkOuter As Long, ByVal dwClsContext As Long, ByRef riid As GUID, ByRef ppv As Long) As Long
Private Declare Function SysReAllocString Lib "oleAut32.dll" (ByVal pBSTR As Long, Optional ByVal pszStrPtr As Long) As Long
Private Declare Function SetProcessDPIAware Lib "user32" () As Long
Private Declare Sub SetLastError Lib "kernel32" (ByVal dwErrCode As Long)
Private Declare Function GetCursorPos Lib "user32" (lpPoint As Currency) As Long
Private Declare Function GetAsyncKeyState Lib "user32" (ByVal vKey As Long) As Integer
#End If
Public bCancelled As Boolean
Sub ShowSheetsPopUp()
On Error GoTo ErrHandler
bCancelled = False
SetTimer Application.hwnd, 0, 0, AddressOf MonitorMouseLeave
If ActiveWorkbook.Sheets.Count <= 16 Then
Application.CommandBars("Workbook Tabs").ShowPopup 500, 225
Else
Application.CommandBars("Workbook Tabs").Controls("More Sheets...").Execute
End If
ErrHandler:
KillTimer Application.hwnd, 0
End Sub
Private Sub MonitorMouseLeave()
#If VBA7 Then
#If Win64 Then
Const PTR_FACTOR = 2
#Else
Const PTR_FACTOR = 1
#End If
Dim pAuto As LongPtr
Dim pElement As LongPtr
Dim pCurrentName As LongPtr
#Else
Const PTR_FACTOR = 1
Dim pAuto As Long
Dim pElement As Long
Dim pCurrentName As Long
#End If
Const S_OK = 0&
Const CLSCTX_INPROC_SERVER = &H1
Const CC_STDCALL = 4&
Const IUnknownRelease = 8&
Const IID_CUIAUTOMATION = "{FF48DBA4-60EF-4201-AA87-54103EEF594E}"
Const IID_IUIAUTOMATION = "{30CBE57D-D9D0-452A-AB13-7AC5AC4825EE}"
Dim iidCuiAuto As GUID, iidIuiAuto As GUID, tPt As Currency
Dim lRet As Long, VTableOffset As Long
On Error Resume Next
lRet = CLSIDFromString(StrPtr(IID_CUIAUTOMATION), iidCuiAuto)
Call DispGUID(iidCuiAuto)
lRet = CLSIDFromString(StrPtr(IID_IUIAUTOMATION), iidIuiAuto)
Call DispGUID(iidIuiAuto)
lRet = CoCreateInstance(iidCuiAuto, 0, CLSCTX_INPROC_SERVER, iidIuiAuto, pAuto)
If lRet = S_OK Then
Call GetCursorPos(tPt)
VTableOffset = 28 * PTR_FACTOR
lRet = CallFunction_COM(pAuto, VTableOffset, vbLong, CC_STDCALL, tPt, VarPtr(pElement))
If lRet = S_OK Then
VTableOffset = 92 * PTR_FACTOR
lRet = CallFunction_COM(pElement, VTableOffset, vbLong, CC_STDCALL, VarPtr(pCurrentName))
If lRet = S_OK Then
If GetStrFromPtrW(pCurrentName) = "Cancel" Or GetStrFromPtrW(pCurrentName) = "Close" Then
KillTimer Application.hwnd, 0
bCancelled = True
End If
Call CallFunction_COM(pElement, IUnknownRelease, vbLong, CC_STDCALL)
End If
Call CallFunction_COM(pAuto, IUnknownRelease, vbLong, CC_STDCALL)
End If
End If
End Sub
#If VBA7 Then
Private Function CallFunction_COM(ByVal InterfacePointer As LongPtr, ByVal VTableOffset As Long, ByVal FunctionReturnType As Long, ByVal CallConvention As Long, ParamArray FunctionParameters() As Variant) As Variant
Dim vParamPtr() As LongPtr
#Else
Private Function CallFunction_COM(ByVal InterfacePointer As Long, ByVal VTableOffset As Long, ByVal FunctionReturnType As Long, ByVal CallConvention As Long, ParamArray FunctionParameters() As Variant) As Variant
Dim vParamPtr() As Long
#End If
Dim pIndex As Long, pCount As Long
Dim vParamType() As Integer
Dim vRtn As Variant, vParams() As Variant
vParams() = FunctionParameters()
pCount = Abs(UBound(vParams) - LBound(vParams) + 1&)
If pCount = 0& Then
ReDim vParamPtr(0 To 0)
ReDim vParamType(0 To 0)
Else
ReDim vParamPtr(0 To pCount - 1&)
ReDim vParamType(0 To pCount - 1&)
For pIndex = 0& To pCount - 1&
vParamPtr(pIndex) = VarPtr(vParams(pIndex))
vParamType(pIndex) = VarType(vParams(pIndex))
Next
End If
pIndex = DispCallFunc(InterfacePointer, VTableOffset, CallConvention, FunctionReturnType, pCount, vParamType(0), vParamPtr(0), vRtn)
If pIndex = 0& Then
CallFunction_COM = vRtn
Else
SetLastError pIndex
End If
End Function
#If VBA7 Then
Private Function GetStrFromPtrW(ByVal Ptr As LongPtr) As String
#Else
Private Function GetStrFromPtrW(ByVal Ptr As Long) As String
#End If
SysReAllocString VarPtr(GetStrFromPtrW), Ptr
End Function
Private Sub DispGUID(objGuid As GUID)
Dim lRet As Long
Dim sTmp As String
Dim buf(100) As Byte
lRet = StringFromGUID2(objGuid, VarPtr(buf(0)), UBound(buf) - 1)
sTmp = buf
End Sub