VB6怎么实现准确截取部分图像内容（框选）

VB6如何实现准确截取部分图像内容（框选）？
最近用VB6做个东东，需要从某图像中框选部分内容到另一图像框中，已实现利用可拖曳的shape框在源picture控件中框选，然后所选内容在picturebox2中显示出来。但目前的问题是：shape框选的图像范围与picturebox2中截取的图像不一致。试了很多方法总是无法实现两边精确一致。
软件截图：

代码如下：

VB code

Dim cx As Single, cy As SinglePrivate Sub Form_Load()Picture1.Picture = LoadPicture(App.Path & "\temp.jpg")Picture2.ScaleWidth = Shape1.WidthPicture2.ScaleHeight = Shape1.HeightEnd SubPrivate Sub Picture1_DragDrop(Source As Control, X As Single, Y As Single)Source.Move X + cx, Y + cyPicture2.ClsPicture2.PaintPicture Picture1.Picture, 0, 0, Shape1.Width, Shape1.Height, X, Y, Shape1.Width, Shape1.HeightPicture2.AutoRedraw = TrueEnd SubPrivate Sub Picture1_MouseDown(Button As Integer, Shift As Integer, X As Single, Y As Single)  If X >= Shape1.Left And X <= Shape1.Left + Shape1.Width And Y >= Shape1.Top And Y <= Shape1.Top + Shape1.Height Then        cx = Shape1.Left - X        cy = Shape1.Top - Y        Shape1.Drag End IfEnd Sub

求大家帮忙解决一下。

[解决办法]
Dim cx As Single, cy As Single
Private Sub Form_Load()
Picture1.Picture = LoadPicture(App.Path & "\temp.jpg")
Picture2.Width = Shape1.Width
Picture2.Height = Shape1.Height
End Sub

Private Sub Picture1_DragDrop(Source As Control, X As Single, Y As Single)

Source.Move X + cx, Y + cy
Picture2.Cls
Picture2.PaintPicture Picture1.Picture, 0, 0, Shape1.Width, Shape1.Height, X + cx, Y + cy, Shape1.Width, Shape1.Height
Picture2.AutoRedraw = True
End Sub

Private Sub Picture1_MouseDown(Button As Integer, Shift As Integer, X As Single, Y As Single)
If X >= Shape1.Left And X <= Shape1.Left + Shape1.Width And Y >= Shape1.Top And Y <= Shape1.Top + Shape1.Height Then
cx = Shape1.Left - X
cy = Shape1.Top - Y
Shape1.Drag
End If
End Sub

OMG.. 为什么不能自己编辑自己的


[解决办法]
你的代码太复杂了，以下代码就可实际你要的功能
Private Sub Form_Load()
Picture2.Width = Shape1.Width
Picture2.Height = Shape1.Height
Picture1.ScaleMode = vbPixels
Picture2.ScaleMode = vbPixels
End Sub
Private Sub Picture1_MouseMove(Button As Integer, Shift As Integer, X As Single, Y As Single)
DoEvents
Shape1.Move X, Y
Picture2.Cls
Picture2.PaintPicture Picture1.Picture, 0, 0, Shape1.Width, Shape1.Height, X, Y, Shape1.Width, Shape1.Height
Picture2.AutoRedraw = True
End Sub

查看更多 下一篇