Psychologist Needs a Way to Measure Motivation

[Excel_Fool]

Hello friends,

I am a PhD student in psychology and have a task built in excel for an upcoming experiment. I want to know if I can record the number of times participants move a shape (actually, I have about 10 shapes/groups of shapes).

I'm thinking that the event that need to be programmed is the movement of a shape. Then, each time the event is fired, a +1 needs to be added to a cell (to count the total number of shape moves).

Which shapes are moved doesn't matter. So, regardless of which shapes are moved, I'd like to have the total number of shape moves recorded in a single cell (on a different worksheet).

Any ideas?

Excel_Fool

 

[Dendro]

Hi,

You would need something like:
Sub ..... Change(ByVal Target as Range)

For each someshape in collectionofshapes
If someshape.Left<>previousX or someshape.Top<>previousY Then
somecounter+1
End if
Next
End Sub

The syntax isn't entirely correct, but i hope you can figure that out with google and recording in excel. If you get stuck, I'll take a look at it.
You would also have to declare and initiate your collection with shapes.
And this would require you to have a (hidden) sheet with a table of the positions before the move.

Another possibility is to create your own event in vba, but I wouldn't be able to help you with that(yet).

good luck

 

[Jaafar Tribak]

I had a play with this and this is what I came up with:

Try this in a blank worksheet

First , add a few shapes to the worksheet and then add Two Macro Buttons - ( One for the CountShapesMovemenets Macro and the other one for the Reset Macro )

Place this code in a standard module:

Option Explicit

Private Declare Function GetAsyncKeyState Lib "user32" (ByVal vKey As Long) As Integer

Private bXit As Boolean
Private bRunning As Boolean

Sub CountShapesMovemenets()
    Dim lLeft As Single
    Dim lTop As Single
    Dim iCount As Integer
    Dim oShape As Shape

    If bRunning = True Then Exit Sub
    For Each oShape In ActiveSheet.Shapes
        oShape.Placement = xlFreeFloating
    Next
    bXit = False
    Do While bXit = False
        bRunning = True
        If VarType(Selection) = vbObject Then
            If lLeft <> Selection.Left Or lTop <> Selection.Top Then
                If GetAsyncKeyState(vbKeyLButton) = 0 Then
                    iCount = iCount + 1
                    Range("A1") = "Last Shape Moved": Range("B1") = "Old TopLeft"
                    Range("C1") = "New TopLeft": Range("D1") = "Total Shapes moved so far"
                    Range("A1:D1").Font.Bold = True
                    With Selection
                        Range("A2") = .Name: Range("B2") = lLeft & " - " & lTop
                        Range("C2") = .Left & " - " & .Top: Range("D2") = iCount
                    End With
                    Range("A1:D1").EntireColumn.AutoFit
                    Application.SendKeys "{ESC}"
                End If
            End If
        End If
        lLeft = Selection.Left
        lTop = Selection.Top
        DoEvents
    Loop
    bRunning = False
End Sub

Sub Reset()
    bXit = True
    Range("A1:D2").Clear
End Sub

 

[Excel_Fool]

Seriously - holy ****! You are good. What do I owe you?

 

[Excel_Fool]

Some weird stuff is happening now, however. Often, I am getting an error message that says "Code execution has been interrupted". Debugging highlighs the first of 3 lines of "End If". Any idea what this means?

Also, the worksheet visual basic editor window sometimes freezes up on me such that I am not permitted to edit it. Ever have that problem?

-Fool

 

[Jaafar Tribak]

Some weird stuff is happening now, however. Often, I am getting an error message that says "Code execution has been interrupted". Debugging highlighs the first of 3 lines of "End If". Any idea what this means?

Also, the worksheet visual basic editor window sometimes freezes up on me such that I am not permitted to edit it. Ever have that problem?

-Fool

The error you are getting means you are ubruptly stopping the running of the loop code .. As you can see, the code runs a continious loop needed to monitor the shapes movements .. The code locks by default the visual basic editor which is one of the problems when using loops .. If you need to edit the code, do so after you execute the Reset Macro by clicikng the button associated with it

Other alternatives to using a loop that I can think of are the use of a smooth timer or the OnUpdate commandbars event but I am not sure how well & stably those alternative will work .. If I have time, i'll give this a go and post the result here

 

[Jaafar Tribak]

Ok - The following approach doesn't use a loop and so it puts a lesser burden on performance and is also less prone to throw runtime errors as opposed to the previous loop solution

Follow these steps :

1 - Add a few shapes to a new blank worksheet
2 - Right clcik on this new worksheet bottom tab , select Vieuw code from the context menu and place the following code in the blank worksheet Module pane:

Option Explicit
Option Base 1
Private WithEvents cmbrs As CommandBars
Private arPos() As Variant
Private arNames() As Variant
Private iCount As Integer

Public Sub StartCountingShapesMovemenets()
    Dim oShape As Shape
    For Each oShape In Me.Shapes
        oShape.Placement = xlFreeFloating
    Next
    Call GetShapesPositions
    Set cmbrs = Application.CommandBars
End Sub

Public Sub Reset()
    Set cmbrs = Nothing
    iCount = 0
    Range("A1:D2").Clear
End Sub

Private Sub cmbrs_OnUpdate()
    If Not Me Is ActiveSheet Then Exit Sub
    If VarType(Selection) = vbObject Then
        On Error Resume Next
            With Selection
                If Application.Match(.Top & " - " & .Left, arPos, 0) = 0 Then
        On Error GoTo 0
                    iCount = iCount + 1
                    Range("A1") = "Last Shape Moved : ": Range("B1") = "Old TopLeft Pos : "
                    Range("C1") = "New TopLeft Pos : ": Range("D1") = "Total Shape movements so far : "
                    Range("A1:D1").Font.Bold = True
                    Range("A2") = .Name: Range("B2") = arPos(Application.Match(.Name, arNames, 0))
                    Range("C2") = .Top & " - " & .Left: Range("D2") = iCount: Range("D2").Font.Color = vbRed
                    Range("A1:D1").EntireColumn.AutoFit
                    Application.SendKeys "{ESC}"
                    Erase arPos
                    Erase arNames
                    Call GetShapesPositions
                End If
        End With
    End If
End Sub

Private Sub GetShapesPositions()
    Dim i As Long
    For i = 1 To Me.Shapes.Count
        ReDim Preserve arPos(i)
        ReDim Preserve arNames(i)
        arPos(i) = Me.Shapes(i).Top & " - " & Me.Shapes(i).Left
        arNames(i) = Me.Shapes(i).Name
    Next
End Sub

3 - Finally, add two buttons to the worksheet - The first button will be assigned the StartCountingShapesMovemenets Macro clicking on which will start monitoring the shape movements and the second Button will be assigned the Reset Macro to stop monitoring and to clear things up

 

[Excel_Fool]

The error you are getting means you are ubruptly stopping the running of the loop code .. As you can see, the code runs a continious loop needed to monitor the shapes movements...

Thanks. Once I figured this out, I felt stupid for asking. You can also just hit the stop button in the toolbar of the VB editor.

 

[Excel_Fool]

Jaafar Tribak,

I tried the new code. I'm still getting occasional errors including "Code execution has been interrupted" (Debug highlights "Erase arPos").

I have a lot of intermingling macros in my workbook. Among other things, what I plan to do with this code is have another button that initiates a macro that (1) copies the number of shape moves and pastes that number into another sheet and (2) hides the sheet so that the user is automatically directed to the next sheet.

I know this might be stupid but I attempted to cut back the original code over the weekend in order to reduce processing demands. I wanted to remove the data entered into cells A1-D1 and A2-C2 since I only need the count (cell D2). Unfortunately, my edits prevent the counter from counting more than 9 shape moves. Any idea why?

Option Explicit

Private Declare PtrSafe Function GetAsyncKeyState Lib "user32" (ByVal vKey As Long) As Integer

Private bXit As Boolean
Private bRunning As Boolean

Sub CountShapesMovemenets()

    Dim iCount As Integer
    Dim oShape As Shape

    For Each oShape In ActiveSheet.Shapes
        oShape.Placement = xlFreeFloating
    Next
    Do While bXit = False
        If VarType(Selection) = vbObject Then
                If GetAsyncKeyState(vbKeyLButton) = 0 Then
                    iCount = iCount + 1

                    With Selection
                        Range("D2") = iCount
                    End With
                    Application.SendKeys "{ESC}"
                End If
            End If

        DoEvents
    Loop
    
End Sub

Sub Reset()
    Range("D2").Clear
End Sub