Recenter object after re-size

[Mike]

I needed a quick routine that would recenter an object after I resized it. I also needed to be able to move it if I did
not resize the object(s). Also, since I already had several objects that I needed to add this capability to, I had to
allow the code to update the EventXFMod and EventDrop cells to be able to call the code. The code allows selecting
multiple ubjects. To attach this code to an object, first put it in a module (I created a module called "amod", if you
do something differenct change this reference below), second in the visio window, select the object that you want to
apply this capability to and activate the macro (Tools->Macros->amod->recenter) to initialize the objects. Now just try
resizing the object and it should snap back to it's original location.

You can see that the Width is being used to monitor that change in size, you can use whatever value you desire, just
make the appropriate changes to the code.

One place to upgrade this is to allow dynamically maintaining the center while re-sizing.

Hope is helps someone,
Mike.

Sub recenter()
Dim VsoSelect As Visio.Selection
Dim VsoShape As Visio.Shape

Set VsoSelect = Visio.ActiveWindow.Selection

If VsoSelect.Count > 0 Then
For Each VsoShape In VsoSelect 'Loop thru selections
' Add recentering formulas and call to this code to opjects if they do not exist
If VsoShape.Cells("EventXFMod").Formula <> "RUNADDON(""amod.recenter"")" Then
VsoShape.Cells("EventXFMod").Formula = "RUNADDON(""amod.recenter"")"
End If
If VsoShape.Cells("EventDrop").Formula <> "SETF(GetRef(User.wd),Width)" Then
VsoShape.Cells("EventDrop").Formula = """SETF(GetRef(User.wd),Width)"""
End If
' Unprotect X and Y movement so user can move object
VsoShape.CellsU("LockMoveX") = 0
VsoShape.CellsU("LockMoveY") = 0
' Add User Rows for storing previous info if they do not exist
If Not VsoShape.CellExists("User.px", 0) Then
retVal = VsoShape.AddNamedRow(Visio.visSectionUser, "px", visTagDefault)
End If
If Not VsoShape.CellExists("User.py", 0) Then
retVal = VsoShape.AddNamedRow(Visio.visSectionUser, "py", visTagDefault)
End If
If Not VsoShape.CellExists("User.wd", 0) Then
retVal = VsoShape.AddNamedRow(Visio.visSectionUser, "wd", visTagDefault)
VsoShape.CellsU("User.wd") = VsoShape.CellsU("Width") 'update with latest width
End If
' Move shape back to original point if resized else allow movement and update temp locations
If VsoShape.CellsU("User.wd") <> VsoShape.CellsU("Width") Then
VsoShape.CellsU("PinX") = VsoShape.CellsU("User.px")
VsoShape.CellsU("PinY") = VsoShape.CellsU("User.py")
VsoShape.CellsU("User.wd") = VsoShape.CellsU("Width")
Else
VsoShape.CellsU("User.px") = VsoShape.CellsU("PinX")
VsoShape.CellsU("User.py") = VsoShape.CellsU("PinY")
End If
Next VsoShape
Else
MsgBox "You Must Have Something Selected"
End If
End Sub