Trigger VBA on action 'increase indent'

[msdejong79]

Hello all,

Modifying the indent of a cell is not picked up by excel as a change, yet I would like to have excel execute a macro when I increase or decrease the indent of a cell.

The furthest I came was with this post:

http://www.mrexcel.com/forum/excel-questions/448695-increase-indent-click-event-using-withevent.html

However, the solution provided here was for excel 2003. I am using 2010. Does anyone have an idea how I could trigger VBA upon changing the indent?

Thanks a bunch in advance!

 

[msdejong79]

@snb: but something does change, because of the custom function called 'indent' which returns the indentlevel of a cell. So yeah, upon an indent action some cells have their value changed.

@RoryA: thanks, that is helpful. With that, I think this thread can be 'archived'.

Thanks to all for your help.
Maarten

 

[Jaafar Tribak]

An alternative to modifying the CustomUI of the workbook to achive this, you could use the IAccessibility interface to mimic a commandbar control click event .. This is, IMHO, a less cumbersome approach

Place this code in the ThisWorkbook module and run the HookTheCommandBars routine :

Option Explicit

Private WithEvents CmbarsEvent As CommandBars

Private Type POINTAPI
    x As Long
    Y As Long
End Type

#If VBA7 Then
    Private Declare PtrSafe Function AccessibleObjectFromPoint Lib "Oleacc" (ByVal arg1 As LongPtr, ppacc As IAccessible, pvarChild As Variant) As Long
    Private Declare PtrSafe Function GetCursorPos Lib "user32.dll" (lpPoint As Any) As Long
#Else
    Private Declare Function AccessibleObjectFromPoint Lib "Oleacc" (ByVal lX As Long, ByVal lY As Long, ppacc As IAccessible, pvarChild As Variant) As Long
    Private Declare PtrSafe GetCursorPos Lib "user32" (lpPoint As POINTAPI) As Long
#End If
 
Private Const CHILDID_SELF = &H0&
Private Const S_OK As Long = &H0


Private Sub Workbook_Open()
    Call HookTheCommandBars
End Sub

Private Sub HookTheCommandBars()
    Set CmbarsEvent = Application.CommandBars
End Sub

Private Sub CmbarsEvent_OnUpdate()
    Call Pseudo_CommandBarButton_ClickEvent
End Sub

Private Sub Pseudo_CommandBarButton_ClickEvent()
    Dim oIA As IAccessible
    Dim oCmbar As CommandBar
    Dim lResult As Long

    #If VBA7 Then
        Dim lngPtr As LongPtr
        Dim arPt(0 To 1) As Long
        GetCursorPos arPt(0)
        lngPtr = arPt(1) * &H100000000^ Or arPt(0)
        lResult = AccessibleObjectFromPoint(lngPtr, oIA, 0)
    #Else
        Dim tPt As POINTAPI
        GetCursorPos tPt
        lResult = AccessibleObjectFromPoint(tPt.x, tPt.Y, oIA, 0)
    #End If
    
    If lResult = S_OK Then
        On Error Resume Next
        For Each oCmbar In Application.CommandBars
            Err.Clear
            Select Case oCmbar.Controls(oIA.accName(CHILDID_SELF)).ID
                Case 3161
                    If Err.Number = 0 Then
                        MsgBox "You clicked the 'Increase Indent Button'."
                    End If
                Case 3162
                    If Err.Number = 0 Then
                        MsgBox "You clicked the 'Decrease Indent Button'."
                    End If
            End Select
        Next
    End If
  End Sub

Note that in order for the code to take effect, the HookTheCommandBars routine must be executed in the Workbook_Open event upon opening the workbook

 

[Jaafar Tribak]

There is a mistake in the #Else part of the API declaration section related to the GetCursorPos function ... I missed the keyword "Function" !

So the correct API functions declaration should be :

#If VBA7 Then
    Private Declare PtrSafe Function AccessibleObjectFromPoint Lib "Oleacc" (ByVal arg1 As LongPtr, ppacc As IAccessible, pvarChild As Variant) As Long
    Private Declare PtrSafe Function GetCursorPos Lib "user32.dll" (lpPoint As Any) As Long
#Else
    Private Declare Function AccessibleObjectFromPoint Lib "Oleacc" (ByVal lX As Long, ByVal lY As Long, ppacc As IAccessible, pvarChild As Variant) As Long
[COLOR=#ff0000][B]    Private Declare Function GetCursorPos Lib "user32" (lpPoint As POINTAPI) As Long[/B][/COLOR]
#End If

 

[ZVI]

An alternative to modifying the CustomUI of the workbook to achive this, you could use the IAccessibility interface to mimic a commandbar control click event ..

Hi Jaafar,

Very impressive, thank you!

But in Win32 (Excel 2010+ 32 bit) this &H100000000^ causes a syntax error for debugger.
Thus I'd suggest using of #If Win64 instead of #If VBA7.

There is also minor problem - code does not trigger in case indent was made by Right Click - Format Cells.
Using of API timer (look each 0.1 sec into indent of the active cell) will solve such a problem but I don't like this.

Vlad

 

[Jaafar Tribak]

Thank you Vladimir for your valuable feedback

But in Win32 (Excel 2010+ 32 bit) this &H100000000^ causes a syntax error for debugger.
Thus I'd suggest using of #If Win64 instead of #If VBA7.

I have replaced the &H100000000^ part with the less obscure CopyMemory function to avoid compiler issues .. The weird difference between the definition of the AccessibleObjectFromPoint API function (first arg) in Win32 vs Win64 is the source of the difficulties in writing a generic multi-OS code

Anyway, here is the modified code that hopefully should now work accross different Office/Windows versions

On the ThisWorkbook module :

Option Explicit

Private WithEvents CmbarsEvent As CommandBars

Private Type POINTAPI
    x As Long
    Y As Long
End Type

#If VBA7 Then
    Private Declare PtrSafe Function GetCursorPos Lib "user32.dll" (lpPoint As POINTAPI) As Long
    #If Win64 Then
        Private Declare PtrSafe Function AccessibleObjectFromPoint Lib "Oleacc" (ByVal arg1 As LongPtr, ppacc As IAccessible, pvarChild As Variant) 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 AccessibleObjectFromPoint Lib "Oleacc" (ByVal lX As Long, ByVal lY As Long, ppacc As IAccessible, pvarChild As Variant) As Long
    #End If
#Else
    Private Declare Function GetCursorPos Lib "user32" (lpPoint As POINTAPI) As Long
    Private Declare Function AccessibleObjectFromPoint Lib "Oleacc" (ByVal lX As Long, ByVal lY As Long, ppacc As IAccessible, pvarChild As Variant) As Long
#End If
 
Private Const CHILDID_SELF = &H0&
Private Const S_OK As Long = &H0

Private Sub Workbook_Open()
    Call HookTheCommandBars
End Sub

Private Sub HookTheCommandBars()
    Set CmbarsEvent = Application.CommandBars
End Sub

Private Sub CmbarsEvent_OnUpdate()
    Call Pseudo_CommandBarButton_ClickEvent
End Sub

Private Sub Pseudo_CommandBarButton_ClickEvent()
    Dim oIA As IAccessible
    Dim oCmbar As CommandBar
    Dim lResult As Long
    Dim tPt As POINTAPI
    Dim oButton As IAccessible
    
    GetCursorPos tPt

    #If Win64 Then
        Dim lngPtr As LongPtr
        CopyMemory lngPtr, tPt, LenB(tPt)
        lResult = AccessibleObjectFromPoint(lngPtr, oIA, 0)
    #Else
        lResult = AccessibleObjectFromPoint(tPt.x, tPt.Y, oIA, 0)
    #End If
    
    If lResult = S_OK Then
        On Error Resume Next
        For Each oCmbar In Application.CommandBars
            Err.Clear
            Set oButton = oCmbar.Controls(oIA.accName(CHILDID_SELF))
            Select Case oButton.ID
                Case 3161
                    If Err.Number = 0 Then
                        MsgBox "You clicked :  '" & oButton.accName & "'"
                        Exit Sub
                    End If
                Case 3162
                    If Err.Number = 0 Then
                        MsgBox "You clicked :  '" & oButton.accName & "'"
                        Exit Sub
                    End If
            End Select
        Next
    End If
End Sub

 

[ZVI]

I have replaced the &H100000000^ part with the less obscure CopyMemory function to avoid compiler issues .. The weird difference between the definition of the AccessibleObjectFromPoint API function (first arg) in Win32 vs Win64 is the source of the difficulties in writing a generic multi-OS code

Anyway, here is the modified code that hopefully should now work accross different Office/Windows versions

Yes it works now like a charm.
BTH, your code of posts #12 & #13 also works good in case of simple replacing of #If VBA7 by #If Win64 in both places.

Happy to learn something new from your inputs!
Vlad

 

[msdejong79]

Many thanks Jaafar, it works pretty good!

Just one little 'bug': when I leave the cursor on one of the two indent icons after clicking, it will immediately resume the macro, as if you have clicked it again.

So, in your code: the messagebox would keep reappearing if you'd 'OK' it by enter button (mouse cursor remaining on the indent icon).

Can this be resolved??

 

[Jaafar Tribak]

Just one little 'bug': when I leave the cursor on one of the two indent icons after clicking, it will immediately resume the macro, as if you have clicked it again.

Strange ! I didn't experience the problem you are describing

Anyway, see if this modification solves the problem you are having :

Option Explicit

Private WithEvents CmbarsEvent As CommandBars

Private Type POINTAPI
    x As Long
    Y As Long
End Type

#If VBA7 Then
    Private Declare PtrSafe Function GetCursorPos Lib "user32.dll" (lpPoint As POINTAPI) As Long
    Private Declare PtrSafe Function GetAsyncKeyState Lib "user32" (ByVal vKey As Long) As Integer
    #If Win64 Then
        Private Declare PtrSafe Function AccessibleObjectFromPoint Lib "Oleacc" (ByVal arg1 As LongPtr, ppacc As IAccessible, pvarChild As Variant) 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 AccessibleObjectFromPoint Lib "Oleacc" (ByVal lX As Long, ByVal lY As Long, ppacc As IAccessible, pvarChild As Variant) As Long
    #End If
#Else
    Private Declare Function GetCursorPos Lib "user32" (lpPoint As POINTAPI) As Long
    Private Declare Function AccessibleObjectFromPoint Lib "Oleacc" (ByVal lX As Long, ByVal lY As Long, ppacc As IAccessible, pvarChild As Variant) As Long
    Private Declare Function GetAsyncKeyState Lib "user32" (ByVal vKey As Long) As Integer
#End If
 
Private Const CHILDID_SELF = &H0&
Private Const S_OK As Long = &H0


Private Sub Workbook_Open()
    Call HookTheCommandBars
End Sub

Private Sub HookTheCommandBars()
    Set CmbarsEvent = Application.CommandBars
End Sub

Private Sub CmbarsEvent_OnUpdate()
    Call Pseudo_CommandBarButton_ClickEvent
End Sub

Private Sub Pseudo_CommandBarButton_ClickEvent()
    Dim oIA As IAccessible
    Dim oCmbar As CommandBar
    Dim lResult As Long
    Dim tPt As POINTAPI
    Dim oButton As IAccessible
    
    GetCursorPos tPt

    #If Win64 Then
        Dim lngPtr As LongPtr
        CopyMemory lngPtr, tPt, LenB(tPt)
        lResult = AccessibleObjectFromPoint(lngPtr, oIA, 0)
    #Else
        lResult = AccessibleObjectFromPoint(tPt.x, tPt.Y, oIA, 0)
    #End If
    
    If lResult = S_OK Then
        On Error Resume Next
        For Each oCmbar In Application.CommandBars
            Err.Clear
            Set oButton = oCmbar.Controls(oIA.accName(CHILDID_SELF))
            Select Case oButton.ID
                Case 3161
                    If Err.Number = 0 Then
                        If GetAsyncKeyState(VBA.vbKeyLButton) <> 0 Then
                            MsgBox "You clicked :  '" & oButton.accName & "'"
                            Exit Sub
                        End If
                    End If
                Case 3162
                    If Err.Number = 0 Then
                        If GetAsyncKeyState(VBA.vbKeyLButton) <> 0 Then
                            MsgBox "You clicked :  '" & oButton.accName & "'"
                            Exit Sub
                        End If
                    End If
            End Select
        Next
    End If
End Sub

 

[msdejong79]

Yeah! It works now! Awesome work man.

 

[snb_]

This runs on my system:

Private WithEvents CmbarsEvent As CommandBars

Private Type POINTAPI
    x As Long
    Y As Long
End Type

#If VBA7 Then
    Private Declare PtrSafe Function GetCursorPos Lib "user32.dll" (lpPoint As POINTAPI) As Long
    #If Win64 Then
        Private Declare PtrSafe Function AccessibleObjectFromPoint Lib "Oleacc" (ByVal arg1 As LongPtr, ppacc As IAccessible, pvarChild As Variant) 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 AccessibleObjectFromPoint Lib "Oleacc" (ByVal lX As Long, ByVal lY As Long, ppacc As IAccessible, pvarChild As Variant) As Long
    #End If
#Else
    Private Declare Function GetCursorPos Lib "user32.dll" (lpPoint As POINTAPI) As Long
    Private Declare Function AccessibleObjectFromPoint Lib "Oleacc" (ByVal lX As Long, ByVal lY As Long, ppacc As IAccessible, pvarChild As Variant) As Long
#End If
 
Private Sub Workbook_Open()
    Set CmbarsEvent = Application.CommandBars
End Sub

Private Sub CmbarsEvent_OnUpdate()
    Dim oIA As IAccessible
    Dim lResult As Long
    Dim tPt As POINTAPI
    Dim lngPtr As LongPtr
    
    GetCursorPos tPt

    #If Win64 Then
        CopyMemory lngPtr, tPt, LenB(tPt)
        lResult = AccessibleObjectFromPoint(lngPtr, oIA, 0)
    #Else
        lResult = AccessibleObjectFromPoint(tPt.x, tPt.Y, oIA, 0)
    #End If
    
    If lResult = 0 And Right(oIA.accName(&H0&), 6) = "Indent" Then ActiveSheet.Calculate
End Sub