Home
Search
 
What's New
Index
Books
Links
Q & A
Newsletter
Banners
 
Feedback
Tip Jar
 
C# Helper...
 
XML RSS Feed
Follow VBHelper on Twitter
 
 
 
MSDN Visual Basic Community
 
 
 
 
 
TitleCrop a picture and save the result in Visual Basic 6
DescriptionThis example shows how to crop a picture and save the result in Visual Basic 6.
Keywordscrop picture, crop, trim, Visual Basic
CategoriesGraphics, Controls
 
When you use the menu's Open command, the program lets you pick an image file. It uses LoadPicture to display the image in the PictureBox named picOriginal.
 
Private Sub mnuFileOpen_Click()
    On Error Resume Next

    dlgOpen.ShowOpen
    If (Err.Number = cdlCancel) Then Exit Sub
    If (Err.Number <> 0) Then
        MsgBox "Error " & Err.Number & " selecting file." & _
            vbCrLf & _
            Err.Description, vbOKOnly Or vbExclamation, _
                "File Select Error"
            Exit Sub
    End If

    On Error GoTo mnuFileOpen_Error
    picOriginal.Picture = LoadPicture(dlgOpen.FileName)
    picOriginal.Visible = True
    picCropped.Visible = True
    Exit Sub

mnuFileOpen_Error:
    MsgBox "Error " & Err.Number & " opening file " & _
        dlgOpen.FileName & "." & vbCrLf & _
        Err.Description, vbOKOnly Or vbExclamation, "File " & _
            "Select Error"
    Exit Sub
End Sub
 
When you click and move the mouse over picOriginal, the program draws a rubberband box around the area you are selecting. Form-level variables m_Selecting, m_X1, m_Y1, m_X2, and m_Y2 keep track of the box.
 
Private m_Selecting As Boolean
Private m_X1 As Single
Private m_Y1 As Single
Private m_X2 As Single
Private m_Y2 As Single

Private Sub picOriginal_MouseDown(Button As Integer, Shift _
    As Integer, X As Single, Y As Single)
    m_Selecting = True
    m_X1 = X
    m_Y1 = Y
    m_X2 = X
    m_Y2 = Y

    ' Draw.
    picOriginal.Line (m_X1, m_Y1)-(m_X2, m_Y2), , B
End Sub

Private Sub picOriginal_MouseMove(Button As Integer, Shift _
    As Integer, X As Single, Y As Single)
    If Not m_Selecting Then Exit Sub

    ' Erase.
    picOriginal.Line (m_X1, m_Y1)-(m_X2, m_Y2), , B
    m_X2 = X
    m_Y2 = Y

    ' Draw.
    picOriginal.Line (m_X1, m_Y1)-(m_X2, m_Y2), , B
End Sub
 
When you release the mouse, the program finds the upper left corner, width, and height of the area you selected. It resizes the picCropped PictureBox so it is the right size to hold that area and then uses the control's PaintPicture method to copy the selected area into picCropped.
 
Private Sub picOriginal_MouseUp(Button As Integer, Shift As _
    Integer, X As Single, Y As Single)
Dim wid As Single
Dim hgt As Single
Dim temp As Single

    If Not m_Selecting Then Exit Sub
    m_Selecting = False

    ' Erase.
    picOriginal.Line (m_X1, m_Y1)-(m_X2, m_Y2), , B

    ' Make pt2 > pt1.
    If m_X1 > m_X2 Then
        temp = m_X1
        m_X1 = m_X2
        m_X2 = temp
    End If
    If m_Y1 > m_Y2 Then
        temp = m_Y1
        m_Y1 = m_Y2
        m_Y2 = temp
    End If

    wid = m_X2 - m_X1
    hgt = m_Y2 - m_Y1
    If (wid = 0) Or (hgt = 0) Then Exit Sub

    ' Size the result.
    picCropped.Width = wid + (picCropped.Width - _
        picCropped.ScaleWidth)
    picCropped.Height = hgt + (picCropped.Height - _
        picCropped.ScaleHeight)

    ' Copy the selected area.
    picCropped.PaintPicture picOriginal.Picture, 0, 0, wid, _
        hgt, m_X1, m_Y1, wid, hgt
    picCropped.Picture = picCropped.Image
End Sub
 
When you click the File menu's Save As command, the program lets you pick a file and it saves the result in that file. The program uses SavePicture, which only saves in the bitmap format.
 
Private Sub mnuFileSaveAs_Click()
    On Error Resume Next

    dlgSaveAs.ShowSave
    If (Err.Number = cdlCancel) Then Exit Sub
    If (Err.Number <> 0) Then
        MsgBox "Error " & Err.Number & " selecting file." & _
            vbCrLf & _
            Err.Description, vbOKOnly Or vbExclamation, _
                "File Select Error"
            Exit Sub
    End If

    On Error GoTo mnuFileSaveAs_Error
    SavePicture picCropped.Picture, dlgSaveAs.FileName
    Exit Sub

mnuFileSaveAs_Error:
    MsgBox "Error " & Err.Number & " saving file " & _
        dlgSaveAs.FileName & "." & vbCrLf & _
        Err.Description, vbOKOnly Or vbExclamation, "File " & _
            "Select Error"
    Exit Sub
End Sub
 
 
Copyright © 1997-2010 Rocky Mountain Computer Consulting, Inc.   All rights reserved.
  Updated