这是我写的代码请新建一个工程，放一个图片框控件在窗体上，不改控件名称，放入以下代码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

好贴 收藏

i ding too

'画虚线矩形框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

littleczb改进版:Option ExplicitDim StartX%, StartY%, OldX%, OldY% '% = IntegerDim WithEvents Picture1 As PictureBoxPrivate Sub Form_Load()Me.ScaleMode = 3'添加控件↓Set Picture1 = Me.Controls.Add("VB.PictureBox", "Picture1")With Picture1 .Top = 8 .Left = 8 .Width = Me.ScaleWidth - 16 'Scale……是窗体内部的什么什么属性 .Height = Me.ScaleHeight - 16 .Appearance = 0 '平面效果 .BackColor = RGB(255, 0, 128) '是为了让选框的反色效果更加明显 .AutoRedraw = True .DrawStyle = 2 '点状线 .Visible = TrueEnd With'*************************************************************End SubPrivate Sub Picture1_MouseDown(Button As Integer, Shift As Integer, X As Single, Y As Single)If Button = 1 Then '确认按下了左键 Picture1.MousePointer = 2 '十字形鼠标 Picture1.DrawMode = 6 '有反色效果的画笔,画两次可以擦除 Picture1.Line (StartX, StartY)-(OldX, OldY), , B '擦出原来画的 StartX = X StartY = Y OldX = X OldY = YEnd IfEnd SubPrivate Sub Picture1_MouseMove(Button As Integer, Shift As Integer, X As Single, Y As Single)If Button = 1 Then Picture1.Line (StartX, StartY)-(OldX, OldY), , B Picture1.Line (StartX, StartY)-(X, Y), , B OldX = X OldY = YEnd IfEnd SubPrivate Sub Picture1_MouseUp(Button As Integer, Shift As Integer, X As Single, Y As Single)If Button = 1 Then Picture1.MousePointer = 0 '恢复普通鼠标 Picture1.DrawMode = 13 '恢复正常画笔 若不画其他图案,则本句可以不要End IfEnd Sub

谢谢楼上的发表自己的意见不过，我提点一，你使用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 还原原来的属性是个好习惯

谢谢大家相互讨论和研究

lz
的程序要是支持画多个矩形和保存文件就更好了.

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

我觉得用一个Shape控件当矩形框比较方便，呵呵！

shape移动比较好用,我以前做截取部分图片的时候用过,挺好用的.

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

在窗体上加一个Shape1控件，代码如下：Option ExplicitDim CX As Single, CY As SingleDim ZhuangTai As IntegerPrivate Sub Form_Load()Shape1.Visible = FalseEnd SubPrivate Sub Form_MouseDown(Button As Integer, Shift As Integer, X As Single, Y As Single)Select Case ZhuangTaiCase 0 If Button = 1 Then CX = X: CY = Y Shape1.Visible = True End IfCase 1 CX = X - Shape1.Left: CY = Y - Shape1.TopEnd SelectEnd SubPrivate Sub Form_MouseMove(Button As Integer, Shift As Integer, X As Single, Y As Single)If Button = 0 Then If X > Shape1.Left And X < Shape1.Left + Shape1.Width And Y > Shape1.Top And Y < Shape1.Top + Shape1.Height And Shape1.Visible = True Then Me.MousePointer = vbSizePointer ZhuangTai = 1 Else Me.MousePointer = vbDefault ZhuangTai = 0 End IfEnd IfSelect Case ZhuangTaiCase 0 If Button = 1 Then ShapeSize CX, CY, X, Y End IfCase 1 If Button = 1 Then Shape1.Move X - CX, Y - CY End IfEnd SelectMe.Caption = ZhuangTaiEnd SubPrivate Sub ShapeSize(ByVal X1 As Single, ByVal Y1 As Single, ByVal X2 As Single, ByVal Y2 As Single)Dim X As Integer, Y As IntegerX = IIf(X1 < X2, X1, X2)Y = IIf(Y1 < Y2, Y1, Y2)Shape1.Move X, Y, Abs(X1 - X2), Abs(Y1 - Y2)End Sub

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

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

我要请教一下，如果我要在已经获取视频图像的picturebox控件里面的为什么看不到选区呢？