Select Portion Of Picture And Paste It To Picture Box

Draw with the mouse rectangle on the picture, and press the button. The area of the picture that found inside the rectangle will be pasted to the second picture box.

Preparations

Add 1 Command Button and 2 Picture Boxes to your form.
Add picture to Picture1 Picture Box.
Set Picture1 and Picture2 ScaleMode property to 3 - Pixel.

Module Code

Declare Function BitBlt Lib "gdi32" (ByVal hDestDC As Long, ByVal X As Long, _
   ByVal Y As Long, ByVal nWidth As Long, ByVal nHeight As Long, ByVal hSrcDC _
   As Long, ByVal xSrc As Long, ByVal ySrc As Long, ByVal dwRop As Long) As Long
Public Const SRCCOPY = &HCC0020
Form Code

Dim minX As Single
Dim maxX As Single
Dim minY As Single
Dim maxY As Single
Dim isRectExist As Boolean
 
Private Sub Command1_Click()
'clear Picture2
     Picture2.Cls
    
'assure that maxX will hold the maxium X value and minX the minimum X value.
     If maxX < minX Then
        temp = minX
        minX = maxX
        maxX = temp
     End If
     
'assure that maxY will hold the maxium Y value and minY the minimum Y value.
     If maxY < minY Then
        temp = minY
        minY = maxY
        maxY = temp
     End If
    
'will draw the rectangle area to Picture2. It will start drawing it from Picture2
'upper left corner. If you want to change the place of drawing, replace the
' "0,0" below with the starting point
     Result& = BitBlt(Picture2.hDC, 0, 0, maxX - minX, maxY - minY, Picture1.hDC, _
     minX, minY, SRCCOPY)

End Sub

Sub Form_Load()
    
    isBoxExist = False
    'initialize the rectangle
    minX = -10
    maxX = 10
    minY = -10
    maxY = 10
End Sub


Sub Picture1_MouseDown(Button As Integer, Shift As Integer, X As Single, Y As Single)
 
    If Button = 1 Then
'if a rectangle is already drawn, delete it
        If isRectExist Then
            Picture1.Cls    
            isBoxExist = False  
        End If
        minX = X
        maxY = Y
        maxX = X
        maxY = Y
    End If
  End Sub

  Sub Picture1_MouseMove(Button As Integer, Shift As Integer, X As Single, Y As Single)
    'Drawing the rectangle
    If Button = 1 Then
        Picture1.DrawMode = 10
        Picture1.Line (minX, maxY)-(maxX, minY), , B
        maxX = X
        minY = Y
        Picture1.Line (minX, maxY)-(maxX, minY), , B
        Picture1.DrawMode = 13
    End If
  End Sub


Private Sub Picture1_MouseUp(Button As Integer, Shift As Integer, X As Single, Y As Single)
'update the isRectExist variable, so the next time the user will start drawing the rectangle,
'we will know that a rectangle is already exist, and we will delete the old rectangle
    isRectExist = True
End Sub
Go Back