Planet Source Code Jumbo …e CD Visual Basic 1 to 7/1_2002.ISO/Data/Zips/Advanced_S656403262002.psc/Source/VB/ScreenRipper/CaptureRectangle.frm

Visual Basic Form | 2002-03-21 | 8.4 KB | 294 lines

VERSION 5.00
Begin VB.Form frmCaptureRectangle
   Appearance      =   0  'Flat
   BorderStyle     =   0  'None
   ClientHeight    =   5475
   ClientLeft      =   0
   ClientTop       =   105
   ClientWidth     =   6825
   ControlBox      =   0   'False
   LinkTopic       =   "Form1"
   MousePointer    =   2  'Cross
   ScaleHeight     =   365
   ScaleMode       =   3  'Pixel
   ScaleWidth      =   455
   ShowInTaskbar   =   0   'False
   StartUpPosition =   2  'CenterScreen
   Begin VB.PictureBox picRectangle
      Appearance      =   0  'Flat
      AutoRedraw      =   -1  'True
      BackColor       =   &H80000005&
      BorderStyle     =   0  'None
      ForeColor       =   &H80000008&
      Height          =   855
      Left            =   2475
      ScaleHeight     =   57
      ScaleMode       =   3  'Pixel
      ScaleWidth      =   97
      TabIndex        =   1
      Top             =   3900
      Visible         =   0   'False
      Width           =   1455
   End
   Begin VB.PictureBox Picture1
      AutoRedraw      =   -1  'True
      Height          =   3165
      Left            =   0
      MousePointer    =   2  'Cross
      ScaleHeight     =   207
      ScaleMode       =   3  'Pixel
      ScaleWidth      =   448
      TabIndex        =   0
      Top             =   -15
      Width           =   6780
      Begin VB.Line Line4
         BorderStyle     =   3  'Dot
         Visible         =   0   'False
         X1              =   248
         X2              =   248
         Y1              =   56
         Y2              =   112
      End
      Begin VB.Line Line3
         BorderStyle     =   3  'Dot
         Visible         =   0   'False
         X1              =   168
         X2              =   240
         Y1              =   120
         Y2              =   120
      End
      Begin VB.Line Line2
         BorderStyle     =   3  'Dot
         Visible         =   0   'False
         X1              =   152
         X2              =   152
         Y1              =   56
         Y2              =   112
      End
      Begin VB.Line Line1
         BorderStyle     =   3  'Dot
         Visible         =   0   'False
         X1              =   160
         X2              =   240
         Y1              =   48
         Y2              =   48
      End
   End
Attribute VB_Name = "frmCaptureRectangle"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = False
Option Explicit
Private mbDown As Boolean
Private nOldX As Integer
Private nOldY As Integer
Private Sub Form_DblClick()
    Unload Me
End Sub
Private Sub Form_Load()
    '--- Set up the Snap Form to the size of the
    '--- Whole Screen capture we did when we choose
    '--- to Get the Rectangular area Capture.
    '--- The "-2" offset prevents the screen from shifting
    '--- slightly when switchting to display screen capture image.
    With Me
        .Left = -2
        .Top = -2
        .Width = Screen.Width + 2
        .Height = Screen.Height + 2
    End With
    With Picture1
        .Left = -2
        .Top = -2
        .Height = Me.Height
        .Width = Me.Width
    End With
End Sub
Public Sub ShowPicture(picBitmap As Variant)
    '--- Load the Screen that was Captured into Picture Box
    Load Me
    DoEvents
    Picture1.Picture = picBitmap
    Me.Show
    mbDown = False
End Sub
Private Sub Form_Unload(Cancel As Integer)
    frmScreenCapture.Show
End Sub
Private Sub Picture1_DblClick()
    Unload Me
End Sub
Private Sub Picture1_MouseDown(Button As Integer, Shift As Integer, X As Single, Y As Single)
'--- This where we set the Begainning of the Box
'--- that will be Drawn around the Capture Area
    mbDown = (Button = 1)
    With Line1
        .X1 = X
        .X2 = X
        .Y1 = Y
        .Y2 = Y
    End With

    With Line2
        .X1 = X
        .X2 = X
        .Y1 = Y
        .Y2 = Y
    End With

    With Line3
        .X1 = X
        .X2 = X
        .Y1 = Y
        .Y2 = Y
    End With

    With Line4
        .X1 = X
        .X2 = X
        .Y1 = Y
        .Y2 = Y
    End With

    Line1.Visible = True
    Line2.Visible = True
    Line3.Visible = True
    Line4.Visible = True
    nOldX = X
    nOldY = Y
End Sub
Private Sub Picture1_MouseMove(Button As Integer, Shift As Integer, X As Single, Y As Single)
'--- Where we Draw the Box around the Choosen Area as you hold down the Left Mouse
'--- button and Drag in any direction to create a rectangle
    If mbDown Then
        With Line1
            .X1 = nOldX
            .X2 = X
            .Y1 = nOldY
            .Y2 = nOldY
        End With

        With Line2
            .X1 = nOldX
            .X2 = nOldX
            .Y1 = nOldY
            .Y2 = Y
        End With

        With Line3
            .X1 = X
            .X2 = X
            .Y1 = nOldY
            .Y2 = Y
        End With

        With Line4
            .X1 = nOldX
            .X2 = X
            .Y1 = Y
            .Y2 = Y
        End With
    End If
End Sub
Private Sub Picture1_MouseUp(Button As Integer, Shift As Integer, X As Single, Y As Single)
    On Error Resume Next
    Dim XUpperLeft As Long
    Dim YUpperLeft As Long
    Dim XLowerRight As Long
    Dim YLowerRight As Long
    '--- Determine the upper left hand corner & lower right hand corner
    '--- XY coordinates.  By doing this, it doesn't matter which
    '--- direction the user "dragged" the rectangle:
    XUpperLeft = Line1.X1
    If Line1.X2 < XUpperLeft Then
        XUpperLeft = Line1.X2
    End If
    With Line2
        If .X1 < XUpperLeft Then
            XUpperLeft = .X1
        End If
        If .X2 < XUpperLeft Then
            XUpperLeft = .X2
        End If
    End With
    YUpperLeft = Line1.Y1
    If Line1.Y2 < YUpperLeft Then
        YUpperLeft = Line1.Y2
    End If
    With Line2
        If .Y1 < YUpperLeft Then
            YUpperLeft = .Y1
        End If
        If .Y2 < YUpperLeft Then
            YUpperLeft = .Y2
        End If
    End With
    XLowerRight = Line1.X1
    If Line1.X2 > XLowerRight Then
        XLowerRight = Line1.X2
    End If
    With Line2
        If .X1 > XLowerRight Then
            XLowerRight = .X1
        End If
        If .X2 > XLowerRight Then
            XLowerRight = .X2
        End If
    End With
    YLowerRight = Line1.Y1
    If Line1.Y2 > YLowerRight Then
        YLowerRight = Line1.Y2
    End If
    With Line2
        If .Y1 > YLowerRight Then
            YLowerRight = .Y1
        End If
        If .Y2 > YLowerRight Then
            YLowerRight = .Y2
        End If
    End With
    '--- Selected a single pixel (clicked, no drag)
    If XUpperLeft = XLowerRight Then XLowerRight = XLowerRight + 1
    If YUpperLeft = YLowerRight Then YLowerRight = YLowerRight + 1
    '--- Set the picRectangle to the size
    '--- we will paint the Image to
    With picRectangle
        .Picture = LoadPicture()
        .Cls
        DoEvents
        .Width = Abs(Line1.X2 - Line1.X1)
        .Height = Abs(Line2.Y2 - Line2.Y1)
        '--- Paint the Captured part of the screen to
        '--- form3 Picture1
        .PaintPicture Picture1, 0, 0, _
            XLowerRight - XUpperLeft, _
            YLowerRight - YUpperLeft, _
            XUpperLeft, YUpperLeft, _
            XLowerRight - XUpperLeft, _
            YLowerRight - YUpperLeft ', opcode

        '--- IMPORTANT: DO NOT REMOVE THIS DoEvents! Windows needs to "catchup"
        '--- before can use the "painted" picture.
        DoEvents
        mbDown = False
    End With
    '--- Put picture image back in calling form and show it
    With frmScreenCapture
        '--- Load selected rectangle image into picture box:
        With .Picture2
            '--- Just to be safe, clear picture before
            '--- loading new image:
            .Picture = LoadPicture()
            .Cls
            .Picture = picRectangle.Image
        End With
        '--- Show frmScreenCapture with the Captured Image
        '--- in frmScreenCapture.Picture2
        .Show

        '--- unload frmCaptureRectangle
        Unload Me
    End With
End Sub