Tools/WinSN5.0Ver.iso/PVb5.0/VB/SAMPLES/PGUIDE/BLANKER/BLANKER.FRM

Visual Basic Form | 1997-01-13 | 22.1 KB | 724 lines

VERSION 5.00
Begin VB.Form DemoForm
   BackColor       =   &H00000000&
   Caption         =   "
   ClientHeight    =   4380
   ClientLeft      =   960
   ClientTop       =   2535
   ClientWidth     =   7470
   BeginProperty Font
      Name            =   "MS Sans Serif"
      Size            =   8.25
      Charset         =   0
      Weight          =   700
      Underline       =   0   'False
      Italic          =   0   'False
      Strikethrough   =   0   'False
   EndProperty
   ForeColor       =   &H00000000&
   Icon            =   "BLANKER.frx":0000
   LinkMode        =   1  'Source
   LinkTopic       =   "Form1"
   PaletteMode     =   1  'UseZOrder
   ScaleHeight     =   4380
   ScaleWidth      =   7470
   WhatsThisHelp   =   -1  'True
   Begin VB.Timer Timer1
      Interval        =   1
      Left            =   6960
      Top             =   120
   End
   Begin VB.CommandButton cmdStartStop
      BackColor       =   &H00000000&
      Caption         =   "
      Default         =   -1  'True
      BeginProperty Font
         Name            =   "
         Size            =   9
         Charset         =   134
         Weight          =   700
         Underline       =   0   'False
         Italic          =   0   'False
         Strikethrough   =   0   'False
      EndProperty
      Height          =   390
      Left            =   240
      TabIndex        =   0
      Top             =   120
      Width           =   1830
   End
   Begin VB.PictureBox picBall
      AutoSize        =   -1  'True
      BackColor       =   &H00000000&
      BorderStyle     =   0  'None
      ForeColor       =   &H00FFFFFF&
      Height          =   480
      Left            =   1800
      Picture         =   "BLANKER.frx":030A
      ScaleHeight     =   480
      ScaleWidth      =   480
      TabIndex        =   1
      Top             =   720
      Visible         =   0   'False
      Width           =   480
   End
   Begin VB.Image imgMoon
      Height          =   480
      Index           =   8
      Left            =   6360
      Picture         =   "BLANKER.frx":0614
      Top             =   3720
      Visible         =   0   'False
      Width           =   480
   End
   Begin VB.Line linLineCtl
      BorderColor     =   &H00FF0000&
      BorderWidth     =   5
      Visible         =   0   'False
      X1              =   240
      X2              =   4080
      Y1              =   2760
      Y2              =   2760
   End
   Begin VB.Image imgMoon
      Height          =   480
      Index           =   7
      Left            =   5760
      Picture         =   "BLANKER.frx":091E
      Top             =   3720
      Visible         =   0   'False
      Width           =   480
   End
   Begin VB.Image imgMoon
      Height          =   480
      Index           =   6
      Left            =   5160
      Picture         =   "BLANKER.frx":0C28
      Top             =   3720
      Visible         =   0   'False
      Width           =   480
   End
   Begin VB.Image imgMoon
      Height          =   480
      Index           =   5
      Left            =   4560
      Picture         =   "BLANKER.frx":0F32
      Top             =   3720
      Visible         =   0   'False
      Width           =   480
   End
   Begin VB.Image imgMoon
      Height          =   480
      Index           =   4
      Left            =   3960
      Picture         =   "BLANKER.frx":123C
      Top             =   3720
      Visible         =   0   'False
      Width           =   480
   End
   Begin VB.Image imgMoon
      Height          =   480
      Index           =   3
      Left            =   3360
      Picture         =   "BLANKER.frx":1546
      Top             =   3720
      Visible         =   0   'False
      Width           =   480
   End
   Begin VB.Image imgMoon
      Height          =   480
      Index           =   2
      Left            =   2760
      Picture         =   "BLANKER.frx":1850
      Top             =   3720
      Visible         =   0   'False
      Width           =   480
   End
   Begin VB.Image imgMoon
      Height          =   480
      Index           =   1
      Left            =   2160
      Picture         =   "BLANKER.frx":1B5A
      Top             =   3720
      Visible         =   0   'False
      Width           =   480
   End
   Begin VB.Image imgMoon
      Height          =   480
      Index           =   0
      Left            =   1560
      Picture         =   "BLANKER.frx":1E64
      Top             =   3720
      Visible         =   0   'False
      Width           =   480
   End
   Begin VB.Shape shpClone
      BackColor       =   &H00000000&
      BackStyle       =   1  'Opaque
      BorderColor     =   &H00FF0000&
      FillColor       =   &H000000FF&
      Height          =   1215
      Index           =   0
      Left            =   240
      Top             =   720
      Visible         =   0   'False
      Width           =   1410
   End
   Begin VB.Shape Shape1
      Height          =   15
      Left            =   960
      Top             =   1080
      Width           =   15
   End
   Begin VB.Menu mnuOption
      Caption         =   "
(&O)"
      Begin VB.Menu mnuLineCtlDemo
         Caption         =   "
(&J)"
         Checked         =   -1  'True
      End
      Begin VB.Menu mnuCtlMoveDemo
         Caption         =   "
(&B)"
      End
      Begin VB.Menu mnuImageDemo
         Caption         =   "
(&S)"
      End
      Begin VB.Menu mnuShapeDemo
         Caption         =   "
(&M)"
      End
      Begin VB.Menu mnuPSetDemo
         Caption         =   "
(&C)"
      End
      Begin VB.Menu mnuLineDemo
         Caption         =   "
(&R)"
      End
      Begin VB.Menu mnuCircleDemo
         Caption         =   "
(&W)"
      End
      Begin VB.Menu mnuScaleDemo
         Caption         =   "
(&L)"
      End
      Begin VB.Menu sep1
         Caption         =   "-"
      End
      Begin VB.Menu mnuExit
         Caption         =   "
(&X)"
      End
   End
Attribute VB_Name = "DemoForm"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = False
Option Explicit
Dim FrameNum
Dim XPos
Dim YPos
 Do Loops
Dim DoFlag
Dim Motion
Dim R
Dim G
Dim B
Private Sub CircleDemo()
    '
    Dim Radius
    '
    R = 255 * Rnd
    G = 255 * Rnd
    B = 255 * Rnd
    '
    XPos = ScaleWidth / 2
    YPos = ScaleHeight / 2
    '
    Radius = ((YPos * 0.9) + 1) * Rnd
    '
    Circle (XPos, YPos), Radius, RGB(R, G, B)
End Sub
Private Sub cmdStartStop_Click()
Dim UnClone
Dim MakeClone
Dim X1
Dim Y1
    Select Case DoFlag
        Case True
            cmdStartStop.Caption = "
            DoFlag = False
            mnuOption.Enabled = True
            If mnuCtlMoveDemo.Checked = True Then
                '
                picBall.Visible = False
            ElseIf mnuLineDemo.Checked = True Then
                '
                Cls
            ElseIf mnuShapeDemo.Checked = True Then
                '
                For UnClone = 1 To 20
                    Unload shpClone(UnClone)
                Next UnClone
                '
                DemoForm.BackColor = QBColor(0)
                '
                Refresh
            ElseIf mnuPSetDemo.Checked = True Then
                '
                Cls
            ElseIf mnuLineCtlDemo.Checked = True Then
                '
 Line
                linLineCtl.Visible = False
                '
 Line
                Cls
            ElseIf mnuImageDemo.Checked = True Then
                '
                imgMoon(0).Visible = False
            ElseIf mnuScaleDemo.Checked = True Then
                '
                Cls
                '
                Scale
            ElseIf mnuCircleDemo.Checked = True Then
                '
                Cls
            End If
        Case False
            cmdStartStop.Caption = "
            DoFlag = True
            mnuOption.Enabled = False
            If mnuCtlMoveDemo.Checked = True Then
                '
picture box
                picBall.Visible = True
                '
 motion
                ' motion
 Do Loop
                Motion = Int(4 * Rnd + 1)
            ElseIf mnuLineDemo.Checked = True Then
                '
                Randomize
                '
                DrawWidth = 2
                '
                X1 = Int(DemoForm.Width * Rnd + 1)
                Y1 = Int(DemoForm.Height * Rnd + 1)
            ElseIf mnuShapeDemo.Checked = True Then
                '
                For MakeClone = 1 To 20
                    Load shpClone(MakeClone)
                Next MakeClone
            ElseIf mnuPSetDemo.Checked = True Then
                '
                DrawWidth = 5
            ElseIf mnuLineCtlDemo.Checked = True Then
                '
                linLineCtl.Visible = True
                '
                DrawWidth = 7
            ElseIf mnuImageDemo.Checked = True Then
                '
image
                imgMoon(0).Visible = True
                '
                FrameNum = 0
                '
 motion
                ' motion
 Do Loop
                Motion = Int(4 * Rnd + 1)
            ElseIf mnuScaleDemo.Checked = True Then
                '
                Randomize
                '
                DrawWidth = 1
                '
                '
 = 1,
                ScaleLeft = 1
                '
                ScaleTop = 10
                '
                ScaleWidth = Int(13 * Rnd + 3)
                '
                ' Y-
                ScaleHeight = -10
            ElseIf mnuCircleDemo.Checked = True Then
                '
                DrawWidth = 1
                '
                DrawStyle = vbDash
                '
 XOR pen
 pen
                DrawMode = vbXorPen
            End If
    End Select
End Sub
Private Sub CtlMoveDemo()
    Select Case Motion
    Case 1
        '
        picBall.Move picBall.Left - 20, picBall.Top - 20
        '
        If picBall.Left <= 0 Then
            Motion = 2
        '
        ElseIf picBall.Top <= 0 Then
            Motion = 4
        End If
    Case 2
        '
        picBall.Move picBall.Left + 20, picBall.Top - 20
        '
        '
        If picBall.Left >= (DemoForm.Width - picBall.Width) Then
            Motion = 1
        '
        ElseIf picBall.Top <= 0 Then
            Motion = 3
        End If
    Case 3
        '
        picBall.Move picBall.Left + 20, picBall.Top + 20
        '
        If picBall.Left >= (DemoForm.Width - picBall.Width) Then
            Motion = 4
        '
        '
        ElseIf picBall.Top >= (DemoForm.Height - picBall.Height) - 680 Then
            Motion = 2
        End If
    Case 4
        '
        picBall.Move picBall.Left - 20, picBall.Top + 20
        '
        If picBall.Left <= 0 Then
            Motion = 3
        '
        ElseIf picBall.Top >= (DemoForm.Height - picBall.Height) - 680 Then
            Motion = 1
        End If
    End Select
End Sub
Private Sub Delay()
    Dim Start
    Dim Check
    Start = Timer
    Do Until Check >= Start + 0.15
        Check = Timer
    Loop
End Sub
Private Sub Form_Load()
    DoFlag = False
End Sub
Private Sub Form_Resize()
    If mnuScaleDemo.Checked = True And DemoForm.WindowState = 0 Then
        '
        Randomize
        '
        DrawWidth = 1
        '
        '
        '
        ScaleLeft = 1
        '
        ScaleTop = 10
        '
        '
        ScaleWidth = Int(13 * Rnd + 3)
        '
        '
        ScaleHeight = -10
    End If
End Sub
Private Sub Form_Unload(Cancel As Integer)
    End
End Sub
Private Sub ImageDemo()
    Select Case Motion
    Case 1
        '
 100
        imgMoon(0).Move imgMoon(0).Left - 100, imgMoon(0).Top - 100
        '
        IncrFrame
        '
        If imgMoon(0).Left <= 0 Then
            Motion = 2
        '
        ElseIf imgMoon(0).Top <= 0 Then
            Motion = 4
        End If
    Case 2
        '
 100
        imgMoon(0).Move imgMoon(0).Left + 100, imgMoon(0).Top - 100
        '
        IncrFrame
        '
        '
        If imgMoon(0).Left >= (DemoForm.Width - imgMoon(0).Width) Then
            Motion = 1
        '
        ElseIf imgMoon(0).Top <= 0 Then
            Motion = 3
        End If
    Case 3
        '
 100
        imgMoon(0).Move imgMoon(0).Left + 100, imgMoon(0).Top + 100
        '
        IncrFrame
        '
        If imgMoon(0).Left >= (DemoForm.Width - imgMoon(0).Width) Then
            Motion = 4
        '
        '
        '
        ElseIf imgMoon(0).Top >= (DemoForm.Height - imgMoon(0).Height) - 680 Then
            Motion = 2
        End If
    Case 4
        '
        imgMoon(0).Move imgMoon(0).Left - 100, imgMoon(0).Top + 100
        '
        IncrFrame
        '
        If imgMoon(0).Left <= 0 Then
            Motion = 3
        '
        ElseIf imgMoon(0).Top >= (DemoForm.Height - imgMoon(0).Height) - 680 Then
            Motion = 1
        End If
    End Select
End Sub
Private Sub IncrFrame()
    '
    FrameNum = FrameNum + 1
    '
    If FrameNum > 8 Then
        FrameNum = 1
    End If
    '
IMAGE
    imgMoon(0).Picture = imgMoon(FrameNum).Picture
    '
    Me.Refresh
    Delay
End Sub
Private Sub LineCtlDemo()
    '
    linLineCtl.X1 = Int(DemoForm.Width * Rnd)
    linLineCtl.Y1 = Int(DemoForm.Height * Rnd)
    '
    linLineCtl.X2 = Int(DemoForm.Width * Rnd)
    linLineCtl.Y2 = Int(DemoForm.Height * Rnd)
    '
    Cls
    '
    Delay
End Sub
Private Sub LineDemo()
    '
    Dim X2
    Dim Y2
    '
 RGB
    R = 255 * Rnd
    G = 255 * Rnd
    B = 255 * Rnd
    '
(line)
    X2 = Int(DemoForm.Width * Rnd + 1)
    Y2 = Int(DemoForm.Height * Rnd + 1)
    '
    Line -(X2, Y2), RGB(R, G, B)
End Sub
Private Sub mnuCircleDemo_Click()
    Cls
    mnuCtlMoveDemo.Checked = False
    mnuLineDemo.Checked = False
    mnuShapeDemo.Checked = False
    mnuPSetDemo.Checked = False
    mnuLineCtlDemo.Checked = False
    mnuImageDemo.Checked = False
    mnuScaleDemo.Checked = False
    mnuCircleDemo.Checked = True
End Sub
Private Sub mnuCtlMoveDemo_Click()
    Cls
    mnuCtlMoveDemo.Checked = True
    mnuLineDemo.Checked = False
    mnuShapeDemo.Checked = False
    mnuPSetDemo.Checked = False
    mnuLineCtlDemo.Checked = False
    mnuImageDemo.Checked = False
    mnuScaleDemo.Checked = False
    mnuCircleDemo.Checked = False
End Sub
Private Sub mnuExit_Click()
    End
End Sub
Private Sub mnuImageDemo_Click()
    Cls
    mnuCtlMoveDemo.Checked = False
    mnuLineDemo.Checked = False
    mnuShapeDemo.Checked = False
    mnuPSetDemo.Checked = False
    mnuLineCtlDemo.Checked = False
    mnuImageDemo.Checked = True
    mnuScaleDemo.Checked = False
    mnuCircleDemo.Checked = False
End Sub
Private Sub mnuLineCtlDemo_Click()
    Cls
    mnuCtlMoveDemo.Checked = False
    mnuLineDemo.Checked = False
    mnuShapeDemo.Checked = False
    mnuPSetDemo.Checked = False
    mnuLineCtlDemo.Checked = True
    mnuImageDemo.Checked = False
    mnuScaleDemo.Checked = False
    mnuCircleDemo.Checked = False
End Sub
Private Sub mnuLineDemo_Click()
    Cls
    mnuCtlMoveDemo.Checked = False
    mnuLineDemo.Checked = True
    mnuShapeDemo.Checked = False
    mnuPSetDemo.Checked = False
    mnuLineCtlDemo.Checked = False
    mnuImageDemo.Checked = False
    mnuScaleDemo.Checked = False
    mnuCircleDemo.Checked = False
End Sub
Private Sub mnuPSetDemo_Click()
    Cls
    mnuCtlMoveDemo.Checked = False
    mnuLineDemo.Checked = False
    mnuShapeDemo.Checked = False
    mnuPSetDemo.Checked = True
    mnuLineCtlDemo.Checked = False
    mnuImageDemo.Checked = False
    mnuScaleDemo.Checked = False
    mnuCircleDemo.Checked = False
End Sub
Private Sub mnuScaleDemo_Click()
    Cls
    mnuCtlMoveDemo.Checked = False
    mnuLineDemo.Checked = False
    mnuShapeDemo.Checked = False
    mnuPSetDemo.Checked = False
    mnuLineCtlDemo.Checked = False
    mnuImageDemo.Checked = False
    mnuScaleDemo.Checked = True
    mnuCircleDemo.Checked = False
End Sub
Private Sub mnuShapeDemo_Click()
    Cls
    mnuCtlMoveDemo.Checked = False
    mnuLineDemo.Checked = False
    mnuShapeDemo.Checked = True
    mnuPSetDemo.Checked = False
    mnuLineCtlDemo.Checked = False
    mnuImageDemo.Checked = False
    mnuScaleDemo.Checked = False
    mnuCircleDemo.Checked = False
End Sub
Private Sub PSetDemo()
    '
 RGB
    R = 255 * Rnd
    G = 255 * Rnd
    B = 255 * Rnd
    ' XPos
    XPos = Rnd * ScaleWidth
    ' YPos
    YPos = Rnd * ScaleHeight
    '
 XPos, YPos
    PSet (XPos, YPos), RGB(R, G, B)
End Sub
Private Sub ScaleDemo()
    '
    Dim Box
    '
    For Box = 1 To ScaleWidth
        '
 RGB
        R = 255 * Rnd
        G = 255 * Rnd
        B = 255 * Rnd
        '
 Line
ScaleWidth
        '
        Line (Box, 0)-Step(1, (Int(11 * Rnd))), RGB(R, G, B), BF
    Next Box
    '
    Delay
End Sub
Private Sub ShapeDemo()
    '
    Dim CloneID
    '
 RGB
    R = 255 * Rnd
    G = 255 * Rnd
    B = 255 * Rnd
    '
    DemoForm.BackColor = RGB(R, G, B)
    '
    CloneID = Int(20 * Rnd + 1)
    '
    XPos = Int(DemoForm.Width * Rnd + 1)
    YPos = Int(DemoForm.Height * Rnd + 1)
    '
    shpClone(CloneID).Shape = Int(6 * Rnd)
    '
 500
 2500
    shpClone(CloneID).Height = Int(2501 * Rnd + 500)
    shpClone(CloneID).Width = Int(2501 * Rnd + 500)
    '
DrawMode
    shpClone(CloneID).BackColor = QBColor(Int(15 * Rnd))
    shpClone(CloneID).DrawMode = Int(16 * Rnd + 1)
    '
 XPos, YPos
    shpClone(CloneID).Move XPos, YPos
    '
    shpClone(CloneID).Visible = True
    '
    Delay
End Sub
Private Sub Timer1_Timer()
    If mnuCtlMoveDemo.Checked And DoFlag = True Then
        CtlMoveDemo
    ElseIf mnuLineDemo.Checked And DoFlag = True Then
        LineDemo
    ElseIf mnuShapeDemo.Checked And DoFlag = True Then
        ShapeDemo
    ElseIf mnuPSetDemo.Checked And DoFlag = True Then
        PSetDemo
    ElseIf mnuLineCtlDemo.Checked And DoFlag = True Then
        LineCtlDemo
    ElseIf mnuImageDemo.Checked And DoFlag = True Then
        ImageDemo
    ElseIf mnuScaleDemo.Checked And DoFlag = True Then
        ScaleDemo
    ElseIf mnuCircleDemo.Checked And DoFlag = True Then
        CircleDemo
    End If
End Sub