标签：VBA
有时候，我们需要在工作表中绘制形状，并将其移动到合适的位置。通常，我们都是单击该选择形状并按住鼠标左键不放来移动形状。ozgrid.com中有人给出了一个方法，点击选择形状，然后移动鼠标，该形状会随形状而移动，再次点击将形状放置在最终位置。
示例如下。
新建一个工作簿，在其中绘制一些形状，然后插入一个ActiveX标签控件，将其绘制得足够小且设置其不可见。
打开VBE，插入一个标准模块，输入下面的代码：
代码语言：javascript复制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打开形状所在的工作表代码模块，输入下面的代码：
代码语言：javascript复制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此时，只需要将鼠标放置在要移动的形状上单击，然后移动鼠标，形状会随着鼠标移动，移动到想要的位置后再次单击，如下图1所示。
图1
欢迎在下面留言，完善本文内容，让更多的人学到更完美的知识。
