移动形状妙招，单击鼠标让形状自动跟随来移动形状

Public Const GREY_FILL As Long = 14277081
Public Const YELLOW_FILL As Long = 65535
Public selectedShape As Shape
Sub selectShape()
 If Not selectedShape Is Nothing Then
   If Sheet1.Shapes(Application.Caller) Is selectedShape Then
     deselectShape
     Exit Sub
   End If
 End If
 Set selectedShape = Sheet1.Shapes(Application.Caller)
 selectedShape.Fill.ForeColor.RGB = YELLOW_FILL
 selectedShape.ZOrder msoBringToFront
 With Sheet1.Label1
   .BringToFront
   .width = selectedShape.width
   .height = selectedShape.height
   .Top = selectedShape.Top
   .Left = selectedShape.Left
 End With
 DoEvents
End Sub

Sub deselectShape()
 With Sheet1.Label1
   .SendToBack
   .width = 1
   .height = 1
   .Top = 1
   .Left = 1
 End With
 If Not selectedShape Is Nothing Then
   selectedShape.Fill.ForeColor.RGB = GREY_FILL
   Set selectedShape = Nothing
 End If
End Sub

Private Sub Label1_Click()
 deselectShape
 DoEvents
End Sub

Private Sub Label1_MouseMove(ByVal Button As Integer, ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single)
 Dim midX As Double
 Dim midY As Double
 
 Debug.Print X, Y
 'Exit Sub
 If Not selectedShape Is Nothing Then
   X = X + selectedShape.Left
   Y = Y + selectedShape.Top
   With Label1
     midX = .Left + (.width / 2)
     midY = .Top + (.height / 2)
     If X - .Left < midX Then
       .Left = Application.Max(0, X - (.width / 2))
     ElseIf (.Left + .width) - X < midX Then
       .Left = X + (.width / 2)
     End If
     If Y - .Top < midY Then
       .Top = Application.Max(0, Y - (.height / 2))
     ElseIf (.Top + .height) - Y < midY Then
       .Top = Y + (.height / 2)
     End If
     selectedShape.Left = .Left
     selectedShape.Top = .Top
   End With
   DoEvents
 End If
End Sub