Dan Appleman's Visual Bas…s Guide to the Win32 API/Dan.Applmans.Visual.Basic.5.0.Programmers.Guide.To.The.Win32.API.1997.Ziff-Davis.Press.CD/VB5PG32.mdf/classlib/desaware/samplev4/rectapi/rectplay.frm

Visual Basic Form | 1996-01-02 | 9.5 KB | 253 lines

VERSION 4.00
Begin VB.Form RectPlay
   Appearance      =   0  'Flat
   BackColor       =   &H80000005&
   Caption         =   "RectPlay"
   ClientHeight    =   3990
   ClientLeft      =   1095
   ClientTop       =   1770
   ClientWidth     =   4950
   BeginProperty Font
      name            =   "MS Sans Serif"
      charset         =   0
      weight          =   700
      size            =   8.25
      underline       =   0   'False
      italic          =   0   'False
      strikethrough   =   0   'False
   EndProperty
   ForeColor       =   &H80000008&
   Height          =   4680
   Left            =   1035
   LinkMode        =   1  'Source
   LinkTopic       =   "Form1"
   ScaleHeight     =   3990
   ScaleWidth      =   4950
   Top             =   1140
   Width           =   5070
   Begin VB.PictureBox Picture1
      Appearance      =   0  'Flat
      BackColor       =   &H80000005&
      ForeColor       =   &H00000000&
      Height          =   3255
      Left            =   180
      ScaleHeight     =   215
      ScaleMode       =   3  'Pixel
      ScaleWidth      =   311
      TabIndex        =   0
      Top             =   540
      Width           =   4695
   End
   Begin VB.Label Label1
      Appearance      =   0  'Flat
      BackColor       =   &H80000005&
      Caption         =   "Label1"
      ForeColor       =   &H80000008&
      Height          =   255
      Left            =   120
      TabIndex        =   1
      Top             =   120
      Width           =   3735
   End
   Begin VB.Menu MenuViewBar
      Caption         =   "View"
      Begin VB.Menu MenuView
         Caption         =   "Rect&1"
         Checked         =   -1  'True
         Index           =   0
      End
      Begin VB.Menu MenuView
         Caption         =   "Rect&2"
         Checked         =   -1  'True
         Index           =   1
      End
      Begin VB.Menu MenuView
         Caption         =   "&Union"
         Index           =   2
      End
      Begin VB.Menu MenuView
         Caption         =   "&Intersect"
         Index           =   3
      End
      Begin VB.Menu MenuView
         Caption         =   "&Offset"
         Index           =   4
      End
      Begin VB.Menu MenuView
         Caption         =   "&Subtract"
         Index           =   5
      End
   End
   Begin VB.Menu ModeViewBar
      Caption         =   "Mode"
      Begin VB.Menu MenuMode
         Caption         =   "Point"
         Index           =   0
      End
      Begin VB.Menu MenuMode
         Caption         =   "SetRect1"
         Index           =   1
      End
      Begin VB.Menu MenuMode
         Caption         =   "SetRect2"
         Index           =   2
      End
   End
Attribute VB_Name = "RectPlay"
Attribute VB_Creatable = False
Attribute VB_Exposed = False
' One of the first changes from the original code
' was to add Option Explicit here.  The original
' program goes back to VB 1.0!
Option Explicit
'   Displays information about the point in the EndPoint
'   global variable (which is set during the Picture1
'   MouseUp event.
Private Sub DoPointDisplay()
    Dim outstring$, crlf$
    Dim tlong&
    ' Unfortunately, the order in which elements are
    ' placed on the stack differs for Win16 and Win32,
    ' So we have to do a swap as follows
    ' Define a newline string
    crlf$ = Chr$(13) + Chr$(10)
    ' Here we changed the PtInRect to accept the two
    ' POINTAPI fields individually instead of converting it first
    ' into a long as was done in the original 16 bit example.
    If Rect1.PtInRect(EndPoint) Then
        outstring$ = "is in Rect1" + crlf$
    End If
    If Rect2.PtInRect(EndPoint) Then
       outstring$ = outstring$ + "is in Rect2" + crlf$
    End If
    If RectUnion.PtInRect(EndPoint) Then
        outstring$ = outstring$ + "is in RectUnion" + crlf$
    End If
    If RectIntersect.PtInRect(EndPoint) Then
        outstring$ = outstring$ + "is in RectIntersect" + crlf$
    End If
    If RectSubtract.PtInRect(EndPoint) Then
        outstring$ = outstring$ + "is in RectSubtract" + crlf$
    End If
    'If RectOffset.PtInRect(EndPoint) Then
    '    outstring$ = outstring$ + "is in RectOffset" + crlf$
    'End If
    If outstring$ = "" Then outstring$ = "is not in any rectangle"
    MsgBox outstring$, 0, "Selected Point"
End Sub
Private Sub Form_Load()
    SettingState% = 1   ' Set the initial value
End Sub
'   Set the Label1 control based on the SettingState%
'   global variable to indicate to the user what the
'   operating mode is.
Private Sub Form_Paint()
    Select Case SettingState%
        Case 0
            Label1.Caption = "Point Detect"
        Case 1
            Label1.Caption = "Set Rect 1"
        Case 2
            Label1.Caption = "Set Rect 2"
    End Select
End Sub
'   Set the SettingState% variable according to the
'   mode command selected.
Private Sub MenuMode_Click(Index As Integer)
    SettingState% = Index
    RectPlay.Refresh
End Sub
'   Check or uncheck the item to view
'   Then redraw the picture box
Private Sub MenuView_Click(Index As Integer)
    If MenuView(Index).Checked Then
        MenuView(Index).Checked = 0
    Else: MenuView(Index).Checked = -1
    End If
    Picture1.Refresh
End Sub
'   Record the current mouse location in StartPoint, and
'   set the drawing mode to exclusive or
Private Sub Picture1_MouseDown(Button As Integer, Shift As Integer, X As Single, Y As Single)
    ' This conversion is safe, as we are in pixels
    ' Note: The original RectPlay program used explicit type
    ' conversions such as "StartPoint.X = CInt(X)"
    ' Because the point fields can be integers or longs depending
    ' on platform, it's better to just let VB do its automatic
    ' conversion than to coerce it to the wrong one or use conditional compilation.
    StartPoint.SetPoint X, Y
    EndPoint.SetPoint X, Y
    ' Drawing will be exclusive Or
    Picture1.DrawMode = vbNotXorPen
    HasCapture% = -1
End Sub
'   If mouse tracking is in effect, and a rectangle
'   is being drawn, erase the prior rectangle and draw
'   one based on the new location.
Private Sub Picture1_MouseMove(Button As Integer, Shift As Integer, X As Single, Y As Single)
    If SettingState% <> 0 And HasCapture% Then
        Picture1.Line (StartPoint.X, StartPoint.Y)-(EndPoint.X, EndPoint.Y), , B
        Picture1.Line (StartPoint.X, StartPoint.Y)-(X, Y), , B
    End If
    EndPoint.SetPoint X, Y
End Sub
'   Erase the prior rectangle and save the information
'   in the appropriate global rectangle.
Private Sub Picture1_MouseUp(Button As Integer, Shift As Integer, X As Single, Y As Single)
    ' If we're not mouse tracking, exit the subroutine
    If Not HasCapture% Then Exit Sub
    If SettingState% <> 0 Then
        Picture1.Line (StartPoint.X, StartPoint.Y)-(EndPoint.X, EndPoint.Y), , B
    End If
    EndPoint.SetPoint X, Y
    Select Case SettingState%
        Case 0
            DoPointDisplay  ' Show point information
        Case 1
            Rect1.SetRect StartPoint.X, StartPoint.Y, EndPoint.X, EndPoint.Y
        Case 2
            Rect2.SetRect StartPoint.X, StartPoint.Y, EndPoint.X, EndPoint.Y
    End Select
    HasCapture% = 0
    ' Restore the original drawing mode
    Picture1.DrawMode = vbCopyPen
    Picture1.Refresh
End Sub
'   Draw each of the rectangles that are requested,
'   each in a different color.
Private Sub Picture1_Paint()
    ' Find the union and intersection rectangles
    ' Using API calls
    Debug.Print "Offset Point" & EndPoint.X, EndPoint.Y
    Debug.Print "rect1 " & Rect1.left, Rect1.top, Rect1.right, Rect1.bottom
    Debug.Print "rect2 " & Rect2.left, Rect2.top, Rect2.right, Rect2.bottom
    Call RectIntersect.IntersectRect(Rect1, Rect2)
    Call RectUnion.UnionRect(Rect1, Rect2)
    'Debug.Print "Offset 2a " & RectOffset.left, RectOffset.top, RectOffset.right, RectOffset.bottom
    'RectOffset.OffsetRect 20, 20
    'Debug.Print "Offset 2afb " & RectOffset.left, RectOffset.top, RectOffset.right, RectOffset.bottom
    Call RectSubtract.SubtractRect(Rect1, Rect2)
    Debug.Print " Subtract " & RectSubtract.left, RectSubtract.top, RectSubtract.right, RectSubtract.bottom
    If MenuView(0).Checked Then ' Rect1
        Picture1.Line (Rect1.left, Rect1.top)-(Rect1.right, Rect1.bottom), QBColor(1), B
    End If
    If MenuView(1).Checked Then ' Rect2
        Picture1.Line (Rect2.left, Rect2.top)-(Rect2.right, Rect2.bottom), QBColor(2), B
    End If
    If MenuView(2).Checked Then ' Union
        Picture1.Line (RectUnion.left, RectUnion.top)-(RectUnion.right, RectUnion.bottom), QBColor(8), B
    End If
    If MenuView(3).Checked Then
        Picture1.Line (RectIntersect.left, RectIntersect.top)-(RectIntersect.right, RectIntersect.bottom), QBColor(4), B
    End If
    If MenuView(4).Checked Then
      '  Picture1.Line (Rect1.left, Rect1.top)-(Rect1.right, Rect1.bottom), QBColor(11), B
      '  Picture1.Line (RectOffset.left, RectOffset.top)-(RectOffset.right, RectOffset.bottom), QBColor(14), B
      '  Picture1.Line (Rect1.left, Rect1.top)-(RectOffset.bottom, RectOffset.right), QBColor(4), B
    End If
    If MenuView(5).Checked Then
        Picture1.Line (RectSubtract.left, RectSubtract.top)-(RectSubtract.right, RectSubtract.bottom), QBColor(14), B
    End If
         RectOffset.SetRectEmpty
End Sub