Event when shape is moved

An active-x object can be used to trigger VBA (when object loses focus, mouse move etc) - what is the shape being used for?

Why do you not want to use right-click to move and resize?

What type of shape are you using?
- attached workbook has a rectangle that can be moved and resized with right-click
- when user clicks on shape latest information is presented in a message box
- simple message box
- T = TOP, = LEFT, W = WIDTH, H = HEIGHT


.
Pic1.jpg


.

Pic2.jpg

.

Sub myShape1_Click()
Dim strDesc As String, dblH As Double, dblW As Double, dblT As Double, dblL As Double

strDesc = "1 am a blue rectangle"
With ActiveSheet.Shapes("MyShape1")
    dblH = Format(.Height, "0.00")
    dblW = Format(.Width, "0.00")
    dblT = Format(.Top, "0.00")
    dblL = Format(.Left, "0.00")
End With

MsgBox strDesc & vbCr & "H= " & dblH & " W= " & dblW & " T= " & dblT & " L= " & dblL
    
End Sub

Here the shape click event is used to move the shape (can also use to resize)
- ie not using right-click

The user is asked where to move the shape using an input box
- the shape is then moved to selected cell
- use a similar technique to ask user to resize the shape

Sub myShape1_Click()
Dim strDesc As String, dblH As Double, dblW As Double, dblT As Double, dblL As Double
Dim cel As Range

Set cel = Application.InputBox("Select where to move shape", , , , , , , 8)
With ActiveSheet.Shapes("MyShape1")
    .Top = cel.Top
    .Left = cel.Left
End With


strDesc = "1 am a blue rectangle"
With ActiveSheet.Shapes("MyShape1")
    dblH = Format(.Height, "0.00")
    dblW = Format(.Width, "0.00")
    dblT = Format(.Top, "0.00")
    dblL = Format(.Left, "0.00")
End With


MsgBox strDesc & vbCr & "H= " & dblH & " W= " & dblW & " T= " & dblT & " L= " & dblL
    
End Sub

Is this what you want?
Test in attached workbook

MoveAndResizeShapeWithoutRightClick.jpg

.

Only click events apply to shapes.
But here is a workaround using an active-x label:
- label is placed directly above the shape
- which allows label's MouseMove event to be used
- could be adapted to deal with many shapes

Const aShp = "myShape", aInf = "myInfo", aLbl = "myLabel"
Dim shp As Shape, lbl As Object, inf As Object, ShowInfo As Boolean
Dim L As Double, T As Double, W As Double, H As Double, TLC As String, BRC As String, myCaption As String

Private Sub Worksheet_SelectionChange(ByVal Target As Range)
    On Error Resume Next
    Select Case ShowInfo
        Case True: Call Update: Target.Activate: ShowInfo = False
        Case Else: Me.OLEObjects("myInfo").Visible = False
    End Select
End Sub

Private Sub myInfo_MouseMove(ByVal Button As Integer, ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single)
    Me.OLEObjects("myInfo").Visible = False
End Sub

Private Sub myLabel_MouseMove(ByVal Button As Integer, ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single)
    Call Update
    shp.Select
    lbl.Height = 0:   lbl.Width = 0     'temporary make label very small
End Sub

Sub Update()
    Set shp = Me.Shapes(aShp)
    Set lbl = Me.OLEObjects(aLbl)
    Set inf = Me.OLEObjects(aInf)
    Call ReAlign
    inf.Visible = True
    ShowInfo = True
End Sub

Private Sub ReAlign()
'shape details
    With shp
        L = .Left: T = .Top: H = .Height: W = .Width
        TLC = .TopLeftCell.Address(0, 0): BRC = .BottomRightCell.Address(0, 0)
    End With
'label position
    With lbl
        .Left = L: .Top = T: .Height = H:   .Width = W
    End With
'info position
    With inf
        .Left = L + W + 10: .Top = T
    End With
'amend caption
    myCaption = "Name =  " & shp.Name & vbCr & "Cell Ref = " & TLC & vbCr & Format(H, "0.0") & " (h  X  w) " & Format(W, "0.0")
    inf.Object.Caption = myCaption
End Sub

1. if shape selected (to show extra information about the meaning of shape) - YES
2. if the user changes the sieze of that shape AND (to change the information based on it's new size) - YES
3. if the user moved that same shape (to change the information based on it's new position) - YES

.

Similar (and simpler!) without using the label
- uses shape click event to achieve the same thing

Test in attached workbook by clicking on the shape
- after moving/resizing click on any cell

In Standard module:

Public Const aShp = "myShape", aInf = "myInfo"
Public shp As Shape, inf As Object, ShowInfo As Boolean, ws As Worksheet
Public L As Double, T As Double, W As Double, H As Double, TLC As String, BRC As String, myCaption As String

Sub myShape_Click()
    Call Update
    shp.Select
End Sub

Private Sub Update()
    Set ws = ActiveSheet
    Set shp = ws.Shapes(aShp)
    Set inf = ws.OLEObjects(aInf)
    Call ReAlign
    inf.Visible = True
    ShowInfo = True
End Sub

Private Sub ReAlign()
'shape details
    With shp
        L = .Left: T = .Top: H = .Height: W = .Width
        TLC = .TopLeftCell.Address(0, 0): BRC = .BottomRightCell.Address(0, 0)
    End With
'info position
    With inf
        .Left = L + W + 10: .Top = T
    End With
'amend caption
    myCaption = "Name =  " & shp.Name & vbCr & "Cell Ref = " & TLC & vbCr & Format(H, "0.0") & " (h  X  w) " & Format(W, "0.0")
    inf.Object.Caption = myCaption
End Sub

In Sheet module

Private Sub Worksheet_SelectionChange(ByVal Target As Range)
    On Error Resume Next
    Select Case ShowInfo
        Case True: Application.Run "Module1.Update": Target.Activate: ShowInfo = False
        Case Else: Me.OLEObjects("myInfo").Visible = False
    End Select
End Sub

Private Sub myInfo_MouseMove(ByVal Button As Integer, ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single)
    Me.OLEObjects("myInfo").Visible = False
End Sub

Hi,

There is an extremely complicated way to do this- https://www.mrexcel.com/forum/excel-...udo-event.html

@xlnitwit

Originally Posted by kev_

@xlnitwit

I liked your expression.

Originally Posted by xlnitwit

@kev_ Certainly not for the faint of heart.

I liked your reply. Lol

@kev_ Certainly not for the faint of heart.