Event triggered when a shape is moved

[justin-uk]

I have searched the forums for an answer to this and haven't found anything, but I am forever hopeful!

Is there a way to trigger a macro when a shape is moved by the user? If I set the OnAction property for a shape, then the cursor changes to a hand when it is over the shape, and I can detect a mouse click on the shape, but I cannot drag and drop the shape. If I reset the OnAction property to "" (empty quotes), then I can drag and drop again within the worksheet, but I can't trigger the macro.

Worksheet_Change or Worksheet_SelectionChange are not triggered by this event.

People have suggested using timers to continuously poll the shapes and determine their locations, but is there an easier way?

What I am trying to do is create a sheet where the user can visually move around objects (in this case representing employees) and deposit them in various zones. The spreadsheet would then apply certain attributes to the shape i.e. change colour according to where the shape is and if it is in an unsuitable zone. I can do all of this, but I want it to work the instant the shape is moved, not rely on the user to hit a button.

Thanks,

Justin

 

[Tom Urtis]

What type(s) of shape(s) exactly are you talking about, and how did you create them...Drawing toolbar, Forms toolbar, control toolbox, pictures you embedded on the sheet from your hard drive...inquiring minds want to know.

 

[justin-uk]

They are regular shapes from the Autoshapes Drawing menu, but I am more than happy to use any other object, so long as it can have text added to it. Thanks.

 

[Legacy 98055]

Hi Justin.

"various zones"

Are these zones defined by a range of cells? A shape? What is a "zone". My first thought would be to use an activeX image control. You can capture the mouse down/up events and "watch" the cursor in between these events. You cannot use the mouse move events because the object itself will be moved. Using the image control, you could easily represent any shape or range as a picture.

 

[Legacy 98055]

The first link is a working example using the code below. The second link provides a workbook that demonstrates various ways of rendering various objects.

<A HREF="http://cid-ea73b3a00e16f94f.skydrive.live.com/self.aspx/Mr%20Excel%20Example/DragNDropImageControl.zip" TARGET="_blank">Example Workbook: DragNDropImageControl.xls.zip</A>

<A HREF="http://cid-ea73b3a00e16f94f.skydrive.live.com/self.aspx/Mr%20Excel%20Example/CopyPictureToIPicture.zip" TARGET="_blank">Example Workbook: CopyPictureToIPicture.xls.zip</A>

Here is an example using an image control that takes its formatting from several ranges. You can use autoshapes or pretty much anything that you can convert into a picture. The behavior is such that only zone_2 will allow a drop. A valid zone drop/intersection is defined as any one corner intersecting a zone. This could easily be changed to, for example, make it mandatory for the entire shape to be encapsulated within a zone to consider it to be a valid drop.

The heart of the code as far as you are concerned is:

DroppedWhere = ValidateDropZone(pt)
    If DroppedWhere <> "NONE" Then
        Select Case DroppedWhere
            Case "ZONE_0"
                'do something
            Case "ZONE_1"
                'do something else
            Case ...more zones
        End Select
    Else
        'drop did not intersect any zones
    End If

Of course you will want to create a custom class to compensate for your various controls. If you need help with this, just reply here.

Option Explicit

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

Private Declare Function GetCursorPos Lib "user32" (lpPoint As POINTAPI) 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 GetDC Lib "user32" (ByVal hwnd As Long) As Long
Private Declare Function ReleaseDC Lib "user32" (ByVal hwnd As Long, ByVal hdc As Long) As Long
Private Declare Function GetDeviceCaps Lib "gdi32" (ByVal hdc As Long, ByVal nIndex 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 PtInRect Lib "user32" (lpRect As RECT, ByVal x As Long, ByVal y As Long) As Long
Private Declare Function DeleteObject Lib "gdi32" (ByVal hObject As Long) As Long

Private Const LOGPIXELSX As Long = 88
Private Const LOGPIXELSY As Long = 90

Private StopLoop As Boolean
Private ActiveControl As MSForms.Image
Private DpiX As Long, DpiY As Long
Private OffsetX As Long, OffsetY As Long
Private StartingPosX As Single, StartingPosY As Single
Private Zones(3) As RECT, hRect(3) As Long

Private Sub Image1_MouseDown(ByVal Button As Integer, ByVal Shift As Integer, ByVal x As Single, ByVal y As Single)
    If Button = 1 Then
        Dim hdc As Long
        
        DefineDropZones
        hdc = GetDC(Application.hwnd)
        DpiX = GetDeviceCaps(hdc, LOGPIXELSX)
        DpiY = GetDeviceCaps(hdc, LOGPIXELSY)
        OffsetX = x
        OffsetY = y
        StartingPosX = Image1.Left
        StartingPosY = Image1.Top
        ReleaseDC Application.hwnd, hdc
        Application.Cursor = xlNorthwestArrow
        Set ActiveControl = Image1
        StopLoop = False
        StartLoop
    End If
End Sub

Private Sub Image1_MouseUp(ByVal Button As Integer, ByVal Shift As Integer, ByVal x As Single, ByVal y As Single)
    StopLoop = True
    Application.Cursor = xlDefault
End Sub

Private Sub StartLoop()
    Dim pt As POINTAPI, DroppedWhere As String
    
    Do Until StopLoop
        GetCursorPos pt
        pt = ScreenPixelsToWorkSheetPoints(pt)
        With ActiveControl
            .Left = pt.x
            .Top = pt.y
        End With
        DoEvents
    Loop
    
    DroppedWhere = ValidateDropZone(pt)
    'this is where you would call your code to respond
    'to the specific drop zone or the absense of a valid drop zone
    If DroppedWhere <> "NONE" Then
        Select Case DroppedWhere
            Case "ZONE_2"
                Set Image1.Picture = IPictureFromCopyPicture(Sheet2.Range("A3"))
                MsgBox "Dropped in " & DroppedWhere
            Case Else
                Set Image1.Picture = IPictureFromCopyPicture(Sheet2.Range("A1"))
                DoEvents
                MsgBox "Invalid Dropzone..."
                ActiveControl.Left = StartingPosX
                ActiveControl.Top = StartingPosY
            End Select
    Else
        'was not dropped in a valid drop zone
        'returned to original position on mouse up
        Set Image1.Picture = IPictureFromCopyPicture(Sheet2.Range("A1"))
        ActiveControl.Left = StartingPosX
        ActiveControl.Top = StartingPosY
    End If
    Set ActiveControl = Nothing
End Sub

Private Function ScreenPixelsToWorkSheetPoints(pt As POINTAPI) As POINTAPI
    pt.x = pt.x - ActiveWindow.PointsToScreenPixelsX(0)
    pt.y = pt.y - ActiveWindow.PointsToScreenPixelsY(0)
    pt.x = ((72 / DpiX) * pt.x) - OffsetX
    pt.y = ((72 / DpiY) * pt.y) - OffsetY
    ScreenPixelsToWorkSheetPoints = pt
End Function

'you cannot use ActiveWindow.RangeFromPoint here because
'the object returned will likely be the image control and not a range
'also see the RectInRegion Function
Private Function ValidateDropZone(pt As POINTAPI) As String
    Dim x As Integer, y As Integer, Corners(3) As POINTAPI
    
    'upper left
    Corners(0).x = ActiveControl.Left
    Corners(0).y = ActiveControl.Top
    'upper right
    Corners(1).x = Corners(0).x + ActiveControl.Width
    Corners(1).y = Corners(0).y
    'lower left
    Corners(2).x = Corners(0).x
    Corners(2).y = Corners(0).y + ActiveControl.Height
    'lower right
    Corners(3).x = Corners(1).x
    Corners(3).y = Corners(2).y
    
    ValidateDropZone = "NONE"
    For x = 0 To 3
        For y = 0 To 3
            If PtInRect(Zones(x), Corners(y).x, Corners(y).y) <> 0 Then
                ValidateDropZone = "ZONE_" & CStr(x)
                GoTo Intersected
            End If
        Next
    Next
    
Intersected:
    DeleteObject hRect(0)
    DeleteObject hRect(1)
    DeleteObject hRect(2)
    DeleteObject hRect(3)
End Function

Private Sub DefineDropZones()
    Dim x As Integer
    
    For x = 0 To 3
        With Range("ZONE_" & CStr(x))
            hRect(x) = SetRect(Zones(x), .Left, .Top, .Left + .Width, .Top + .Height)
        End With
    Next
End Sub

Option Explicit

Private Declare Function OpenClipboard Lib "user32" (ByVal hwnd As Long) As Long
Private Declare Function GetClipboardData Lib "user32" (ByVal wFormat As Integer) As Long
Private Declare Function CloseClipboard Lib "user32" () As Long
Private Declare Function CopyImage Lib "user32" (ByVal hImage As Long, ByVal uType As Long, ByVal PixelWidth As Long, ByVal PixelHeight As Long, ByVal Flags As Long) As Long
Private Declare Function OleCreatePictureIndirect Lib "olepro32.dll" (pPictDesc As PictDesc, riid As Guid, ByVal fOwn As Long, ppvObj As IPicture) As Long

Type Guid
    Data1 As Long
    Data2 As Integer
    Data3 As Integer
    Data4(0 To 7) As Byte
End Type
        
Type PictDesc
    cbSizeofStruct As Long
    picType As Long
    hImage As Long
    xExt As Long
    yExt As Long
End Type

Private Const CF_BITMAP = 2
Private Const S_OK As Long = &H0
Private Const LR_COPYRETURNORG = &H4

Function IPictureFromCopyPicture(Source As Object, Optional StretchWidth As Single, Optional StretchHeight As Single) As IPictureDisp
    Dim hBmp As Long
    Dim PictDesc As PictDesc
    Dim IDispatch As Guid
    Dim SaveWidth As Single
    Dim SaveHeight As Single
    Dim PicIsRng As Boolean
       
    If StretchWidth <> 0 Or StretchHeight <> 0 Then
        If TypeOf Source Is Range Then
            Source.CopyPicture
            ActiveSheet.PasteSpecial "Picture (Enhanced Metafile)"
            Set Source = Selection
            PicIsRng = True
        End If
        
        SaveWidth = Source.Width
        SaveHeight = Source.Height
        Source.Width = IIf(StretchWidth = 0, Source.Width, StretchWidth)
        Source.Height = IIf(StretchHeight = 0, Source.Height, StretchHeight)
        Source.CopyPicture xlScreen, xlBitmap
        
        If PicIsRng Then
            Source.Delete
        Else
            Source.Width = SaveWidth
            Source.Height = SaveHeight
        End If
    Else
        Source.CopyPicture xlScreen, xlBitmap
    End If

    If OpenClipboard(0) <> 0 Then
        hBmp = GetClipboardData(CF_BITMAP)
        hBmp = CopyImage(hBmp, 0, 0, 0, LR_COPYRETURNORG)
        CloseClipboard
        If hBmp <> 0 Then
                  
            With IDispatch
               .Data1 = &H20400
               .Data4(0) = &HC0
               .Data4(7) = &H46
            End With
            
            With PictDesc
               .cbSizeofStruct = Len(PictDesc)
               .picType = 1
               .hImage = hBmp
            End With
            
            If OleCreatePictureIndirect(PictDesc, IDispatch, False, IPictureFromCopyPicture) <> S_OK Then
                Set IPictureFromCopyPicture = Nothing
            End If
        End If
    End If
End Function

 

[justin-uk]

WOW! That is amazing. Thanks! I hope this was something you were already working on, but looking at the times of your posts I suspect you put a lot of time into this. That is really appreciated!

I think I follow most of the code, although I have never used ActiveX controls before. I think it could be useable in close to its current form, but I would like to ask if the following are possible?

1. I can't see an obvious way to have multiple images to move on the sheet.
2. Where in the code is the initial location of the moveable image set? Thought it was LOGPIXEL but changing those makes it stop.
3. The DefineZones sub seems too simple to me. I can't quite see how it knows where the zones are? How would I create more zones? as 4 zones seems to be hard coded throughout. My attempts to add another failed!

This is exactly the functionality I had imagined though. Thanks again.

 

[Legacy 98055]

Hi Justin. I did spend an unusual amount of time on this because I enjoy this type of stuff and thought that I might be able to use the whole "zone" thing down the road with the type of interactive apps I dev for schools. To answer your questions.

1. It will be easier to show you. You would create a class and create instances of it. You'll understand it when you see an example of it.

2. StartingPosX = Image1.Left and StartingPosY = Image1.Top

3. How you define your zones may vary. I used four named ranges and simply created four rect structures by way of the dimensions of said ranges. I imagine that I would create a class for creating zones as well where you might provide useful methods such as CreatZoneByRange, CreateZoneByObject, CreateZoneByPoints. Where object might be any shape. For this project, I would probably just use CreateZoneByPoints and make the client provide the points. You'll understand when you see a better example. Your zones are likely rectangular but they need not be. You can use a complex polygon if you wish.

Question.
How are you now defining your zones?

Thx - Tom

 

[justin-uk]

1. Yes, please keep me up to date with any further developments.
2. Understood now.
3. Hadn't spotted that the ranges were named... clever.

To explain a bit more about my application of this. We are embarking on a job grading process later this year. I want the manager to answer a few quick questions about the job role attributes which will determine an approximate job level (i.e. Budget control, people management), and then the manager will move the job role to it's final grade position, and they will want to do that in relation to the other employees in their group (hence the need for multiple images). I figured using a visual UI to do this would be very user friendly.

So there will be 9 job levels (9 zones), probably represented as a horizontal or vertical stack of rectangles. The starting positions of the 'job role' images would be determined by the first 'attributes' exercise. If the manager attempts to move a role into a level where it really shouldn't be (determined by the job role attributes), it will either be spat out (like your demo) or will change to red / fire a warning msgbox etc.

Determining the final resting locations (google getShapeProc() for my initial idea of how to do that) and I could also check that salaries fit, management roll-ups are maintained, and then the manager could submit a report of their final grading back to HR.

Easy-peesy!

The world is a better place for people like you willing to explore the boundaries and share it! Thanks again.

 

[Legacy 98055]

Ok Justin. I think I understand the jist of what you are trying to do here. It might be a while but I will maintain this thread with you. Let me know of any ideas or suggestions you come up with as far as breaking up the complexity or delegating functionality to certain classes. I tend to develop classes that do too much and have issues when it comes to KISS. <b>K</b>eep <b>I</b>t <b>S</b>imple <b>S</b>tupid.

 

[Legacy 98055]

Hi Justin. I have been fiddling around with this and am wondering how you will go about determining valid zones. None of the classes I mentioned are dependant upon this but I was trying to come up with a relevant example. Let me know if you have any ideas. I've figured out a much better way to do this than the previous example that uses a loop.