如何在picturebox在画个一个矩形框，并可以移动它，类似photoshop中选择框

[nansa2000]

如何在picturebox在画个一个矩形框，并可以移动它，类似photoshop中选择框,让用户保存框内截取的图片

[VBToy]

用XOR笔画或直接用shape控件的矩形,至于如何截取图片，可以计算。

[nansa2000]

用XOR笔画没有用过，能不能指点一下啊

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

[laviewpbt]

模范ＰＳ的选取框，俺以实现，不过不想公开代码，其实很简单，不超过１００行代码!呵呵

[IamDeane]

同志们拿砖头砸楼上，呵呵

[clear_zero]

我没做过，友情帮顶

[laviewpbt]

呵呵!

[VBToy]

的确，“人一定要靠自己”。不过可以参考一下这个：http://community.csdn.net/Expert/topic/5502/5502963.xml?temp=.7847559

[laviewpbt]

答辩后公布那个代码，大家鼓励我吧，我就是不想写论文啊！郁闷！！！！！

[meritw]

mark

[犀山居士]

记住矩形的位置宽度和高度，画的时候，以vbXorPan方式，第一次只画一次，你用鼠标移动后，先画一次，就会清除以前画的，再画一次，就是新的

[犀山居士]

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

Option Explicit

'矩形结构
Private Type RECT
Left As Long
Top As Long
Right As Long
Bottom As Long
End Type

'操作类型
Enum OpType
None = 0
Draw
Drag
End Enum


Dim 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 With
End Sub

Private Sub Form_Resize()
Picture1.Move ScaleX(8, vbPixels, ScaleMode), ScaleY(8, vbPixels, ScaleMode), _
ScaleWidth - ScaleX(16, vbPixels, ScaleMode), _
ScaleHeight - ScaleY(16, vbPixels, ScaleMode)
End Sub

Private 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 If
End Sub

Private 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 If
End Sub

Private 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 If
End 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 With
End Sub

'控件重画时，要重画矩形
Private Sub Picture1_Paint()
Picture1.Cls
Call DrawRect
End Sub

[犀山居士]

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