这是我写的代码请新建一个工程，放一个图片框控件在窗体上，不改控件名称，放入以下代码Option Explicit'矩形结构Private Type RECT  Left   As Long  Top    As Long  Right   As Long  Bottom  As LongEnd Type'操作类型Enum OpType  None = 0  Draw  DragEnd EnumDim rc As RECT '所画矩形Dim ot As OpType '操作类型Dim m_X As Long '当拖动矩形时，鼠标位置的 X 坐标Dim m_Y As Long '当拖动矩形时，鼠标位置的 Y 坐标Private Sub Form_Load()  ot = None  With Picture1    .ScaleMode = vbPixels    .AutoRedraw = False    .Appearance = 0  End WithEnd SubPrivate Sub Form_Resize()  Picture1.Move ScaleX(8, vbPixels, ScaleMode), ScaleY(8, vbPixels, ScaleMode), _      ScaleWidth - ScaleX(16, vbPixels, ScaleMode), _      ScaleHeight - ScaleY(16, vbPixels, ScaleMode)End SubPrivate Sub Picture1_MouseDown(Button As Integer, Shift As Integer, X As Single, Y As Single)  If vbLeftButton = (Button And vbLeftButton) Then    Select Case ot    Case OpType.None      With rc        If X > .Left And X < .Right And Y > .Top And Y < .Bottom Then          '如果已经画好了矩形，如果点击矩形范围内任意位置，则视为拖动矩形          m_X = X          m_Y = Y          ot = Drag        Else          '反之则视为重画矩形          Call DrawRect          .Left = X          .Right = X          .Top = Y          .Bottom = Y          ot = Draw        End If      End With    Case OpType.Draw    Case OpType.Drag    End Select  End IfEnd SubPrivate Sub Picture1_MouseMove(Button As Integer, Shift As Integer, X As Single, Y As Single)  If vbLeftButton = (Button And vbLeftButton) Then    With rc      Select Case ot      Case OpType.None      Case OpType.Draw        '画矩形时，先画一次清除上次画的矩形

        Call DrawRect        '矩形的其中一个角不变        .Right = X        .Bottom = Y        '再画新的矩形，达到移动矩形的目的        Call DrawRect      Case OpType.Drag        '画矩形时，先画一次清除上次画的矩形        Call DrawRect        '移动整个矩形        .Left = .Left - m_X + X        .Top = .Top - m_Y + Y        .Right = .Right - m_X + X        .Bottom = .Bottom - m_Y + Y        m_X = X        m_Y = Y        '再画新的矩形，达到移动矩形的目的        Call DrawRect      End Select    End With  End IfEnd SubPrivate Sub Picture1_MouseUp(Button As Integer, Shift As Integer, X As Single, Y As Single)  If vbLeftButton = (Button And vbLeftButton) Then    Select Case ot    Case OpType.None    Case OpType.Draw      '为了下次拖动，将矩形调整好，左边比右边的坐标小，上边比下边坐标小      Dim tmp As Long      With rc        If .Right < .Left Then          tmp = .Right          .Right = .Left          .Left = tmp        End If        If .Bottom < .Top Then          tmp = .Bottom          .Bottom = .Top          .Top = tmp        End If      End With    Case OpType.Drag    End Select    ot = None  End IfEnd Sub'画矩形Private Sub DrawRect()  With rc    If .Right = .Left Or .Bottom = .Top Then Exit Sub    Dim drMode As Integer    drMode = Picture1.DrawMode    Picture1.DrawMode = vbNotXorPen    Picture1.Line (.Left, .Top)-(.Right, .Bottom), vbRed, B    Picture1.DrawMode = drMode  End WithEnd Sub'控件重画时，要重画矩形Private Sub Picture1_Paint()  Picture1.Cls  Call DrawRectEnd Sub

把 AutoRedraw = False 改为 AutoRedraw = True，可以去掉 Private Sub Picture1_Paint()

替换以下过程，防止窗体最小化时和窗体调整大小调整得太小时异常Private Sub Form_Resize()  If WindowState = vbMinimized Then Exit Sub  If ScaleX(ScaleWidth, ScaleMode, vbPixels) < 24 Or _    ScaleY(ScaleHeight, ScaleMode, vbPixels) < 24 Then Exit Sub  Picture1.Move ScaleX(8, vbPixels, ScaleMode), ScaleY(8, vbPixels, ScaleMode), _      ScaleWidth - ScaleX(16, vbPixels, ScaleMode), _      ScaleHeight - ScaleY(16, vbPixels, ScaleMode)End Sub

'画虚线矩形框Private Sub DrawRect()  With rc    If .Right = .Left Or .Bottom = .Top Then Exit Sub    Dim drMode As Integer, dsMode As Integer    drMode = Picture1.DrawMode    Picture1.DrawMode = vbNotXorPen    dsMode = Picture1.DrawStyle    Picture1.DrawStyle = vbBSDash '画虚线矩形框    Picture1.Line (.Left, .Top)-(.Right, .Bottom), vbRed, B    Picture1.DrawMode = drMode    Picture1.DrawStyle = dsMode  End WithEnd Sub替换控件被鼠标按下的事件代码        '如果刚好按下的是矩形的边框，为了可以拖动矩形，所以要加上等号        If (X >= .Left And X <= .Right And Y >= .Top And Y <= .Bottom) And _            Not (.Left = .Right Or .Bottom = .Top) Then

谢谢楼上的发表自己的意见不过，我提点一，你使用If Button = 1 Then '确认按下了左键如果在画的过程当中，用户同时按下了鼠标右键，那么你的操作就会失效了，所以我用的是以下代码，不要小看这一行，与你的，区别上可大了If vbLeftButton = (Button And vbLeftButton) Then二，你直接修改了窗体的ScaleMode属性，那么窗体原来可能有用到与此属性相关的操作，将会受此影响三、你直接修改了控件的DrawStyle属性，后果也会同上，可能用户需要在此控件上还要画其它内容所以，我使用以下代码，并不是多此一举 Dim drMode As Integer drMode = Picture1.DrawMode Picture1.DrawMode = vbNotXorPen Picture1.Line (.Left, .Top)-(.Right, .Bottom), vbRed, B Picture1.DrawMode = drMode 还原原来的属性是个好习惯

谢谢大家相互讨论和研究

还有一点刚才忘了说了，就是你在第一次画的时候，没有考虑是否已经画过，所以，当用户第一次近下鼠标时，也会画一个(0,0)-(当前鼠标x坐标,当前鼠标y坐标)和矩形，但这个矩形用户并没有画

移动shape控件卡的很，不流畅

不是我说用Shape控件不行，是原楼主说他用这个不能满足他的要求，才想着用画矩形的方式来实现的，不知道他需要在图片框上画什么，会影响移动控件时会卡，我只是按他的要求画矩形，当然仅仅要实现画矩形和移动矩形，不一定要采用画的方式，方法有很多种，谢谢大家能发表自己的意见，我放入图片到图片框或窗体上，效果与云霞人实现的差不多，没有太明显的区别

不过散人的，第一次按下鼠标时，控件会显示出原来的大小并闪一下，拖放的时候，会有轻度的闪烁感，我用这个控件做的进度条，也会很明显的闪烁感