Visual Basic Graphics Programming (2nd Edition)/Visual Basic Graphics Programming 2nd Edition.iso/OldSrc/CH5/SRC/PALANIM.FRM

Visual Basic Form | 1996-05-02 | 10.3 KB | 332 lines

VERSION 4.00
Begin VB.Form PalAnimForm
   Caption         =   "Palette Animation"
   ClientHeight    =   4500
   ClientLeft      =   2340
   ClientTop       =   1320
   ClientWidth     =   3975
   Height          =   5190
   Left            =   2280
   LinkTopic       =   "Form1"
   ScaleHeight     =   300
   ScaleMode       =   3  'Pixel
   ScaleWidth      =   265
   Top             =   690
   Width           =   4095
   Begin VB.PictureBox Canvas
      AutoRedraw      =   -1  'True
      Height          =   3975
      Left            =   0
      Picture         =   "PALANIM.frx":0000
      ScaleHeight     =   261
      ScaleMode       =   3  'Pixel
      ScaleWidth      =   261
      TabIndex        =   1
      Top             =   0
      Width           =   3975
      Begin VB.Label Label2
         Alignment       =   2  'Center
         Caption         =   "Animation"
         BeginProperty Font
            name            =   "MS Sans Serif"
            charset         =   1
            weight          =   700
            size            =   13.5
            underline       =   0   'False
            italic          =   -1  'True
            strikethrough   =   0   'False
         EndProperty
         Height          =   375
         Left            =   1200
         TabIndex        =   3
         Top             =   1800
         Width           =   1575
      End
      Begin VB.Label Label1
         Alignment       =   2  'Center
         Caption         =   "Palette"
         BeginProperty Font
            name            =   "MS Sans Serif"
            charset         =   1
            weight          =   700
            size            =   13.5
            underline       =   0   'False
            italic          =   -1  'True
            strikethrough   =   0   'False
         EndProperty
         Height          =   375
         Left            =   1440
         TabIndex        =   2
         Top             =   1440
         Width           =   1095
      End
   End
   Begin VB.CommandButton CmdGo
      Caption         =   "Go"
      Default         =   -1  'True
      Height          =   495
      Left            =   1560
      TabIndex        =   0
      Top             =   4005
      Width           =   735
   End
   Begin VB.Menu mnuFile
      Caption         =   "&File"
      Begin VB.Menu mnuFileExit
         Caption         =   "E&xit"
      End
   End
Attribute VB_Name = "PalAnimForm"
Attribute VB_Creatable = False
Attribute VB_Exposed = False
Option Explicit
Dim SysPalSize As Integer
Dim NumStaticColors As Integer
Dim StaticColor1 As Integer
Dim StaticColor2 As Integer
Dim LogPal As Integer
Dim palentry(0 To 255) As PALETTEENTRY
Dim Running As Boolean
Dim Component(0 To 29) As Byte
Dim StartColor As Integer
' ************************************************
' Change the color palette until the user presses
' the Stop button.
' ************************************************
Sub AnimateColors()
Dim next_time As Long
Dim mpf As Long
    mpf = 1000 / 20 ' Update 20 times per second.
    next_time = GetTickCount()
    Do While Running
        SetColors
        next_time = next_time + mpf
        WaitTill next_time
    Loop
End Sub
' ************************************************
' Draw the circle.
' ************************************************
Sub xDrawCircle()
Const PI = 3.14159
Const Dtheta = PI / 60
Dim r1 As Single
Dim r2 As Single
Dim xmid As Single
Dim ymid As Single
Dim status As Long
Dim i As Integer
Dim pts(1 To 4) As POINTAPI
Dim theta As Single
Dim clr As Integer
Dim new_pen As Long
Dim old_pen As Long
Dim new_brush As Long
Dim old_brush As Long
    r1 = Canvas.ScaleWidth * 0.4
    r2 = Canvas.ScaleWidth * 0.45
    xmid = Canvas.ScaleWidth / 2
    ymid = Canvas.ScaleHeight / 2
    pts(3).x = xmid + r2
    pts(3).y = ymid + 0
    pts(4).x = xmid + r1
    pts(4).y = ymid + 0
    For theta = Dtheta To 360 Step Dtheta
        pts(1).x = pts(4).x
        pts(1).y = pts(4).y
        pts(2).x = pts(3).x
        pts(2).y = pts(3).y
        pts(3).x = xmid + r2 * Cos(theta)
        pts(3).y = ymid + r2 * Sin(theta)
        pts(4).x = xmid + r1 * Cos(theta)
        pts(4).y = ymid + r1 * Sin(theta)

        ' Create the pen and brush.
        new_pen = CreatePen(PS_SOLID, 1, &H1000000 + 100 + clr)
        old_pen = SelectObject(Canvas.hDC, new_pen)
        new_brush = CreateSolidBrush(&H1000000 + 100 + clr)
        old_brush = SelectObject(Canvas.hDC, new_brush)
        status = Polygon(Canvas.hDC, pts(1), 4)

        new_pen = SelectObject(Canvas.hDC, old_pen)
        new_brush = SelectObject(Canvas.hDC, old_brush)
        status = DeleteObject(new_pen)
        status = DeleteObject(new_brush)

        clr = (clr + 1) Mod 30
    Next theta
    Canvas.Refresh
End Sub
' ************************************************
' Draw the circle.
' ************************************************
Sub DrawCircle()
Const PI = 3.14159
Const Dtheta = PI / 60
Dim r1 As Single
Dim r2 As Single
Dim r3 As Single
Dim xmid As Single
Dim ymid As Single
Dim status As Long
Dim i As Integer
Dim pts1(1 To 4) As POINTAPI
Dim pts2(1 To 4) As POINTAPI
Dim theta As Single
Dim clr As Integer
Dim new_pen As Long
Dim old_pen As Long
Dim new_brush As Long
Dim old_brush As Long
    r1 = Canvas.ScaleWidth * 0.25
    r2 = Canvas.ScaleWidth * 0.35
    r3 = Canvas.ScaleWidth * 0.45
    xmid = Canvas.ScaleWidth / 2
    ymid = Canvas.ScaleHeight / 2
    pts1(3).x = xmid + r2
    pts1(3).y = ymid + 0
    pts1(4).x = xmid + r1
    pts1(4).y = ymid + 0
    pts2(3).x = xmid + r3
    pts2(3).y = ymid + 0
    pts2(4).x = pts1(3).x
    pts2(4).y = pts1(3).y
    For theta = Dtheta To 360 Step Dtheta
        pts1(1).x = pts1(4).x
        pts1(1).y = pts1(4).y
        pts1(2).x = pts1(3).x
        pts1(2).y = pts1(3).y
        pts1(3).x = xmid + r2 * Cos(theta)
        pts1(3).y = ymid + r2 * Sin(theta)
        pts1(4).x = xmid + r1 * Cos(theta)
        pts1(4).y = ymid + r1 * Sin(theta)

        pts2(1).x = pts2(4).x
        pts2(1).y = pts2(4).y
        pts2(2).x = pts2(3).x
        pts2(2).y = pts2(3).y
        pts2(3).x = xmid + r3 * Cos(theta)
        pts2(3).y = ymid + r3 * Sin(theta)
        pts2(4).x = pts1(3).x
        pts2(4).y = pts1(3).y

        ' Create the pen and brush.
        new_pen = CreatePen(PS_SOLID, 1, &H1000000 + 100 + clr)
        old_pen = SelectObject(Canvas.hDC, new_pen)
        new_brush = CreateSolidBrush(&H1000000 + 100 + clr)
        old_brush = SelectObject(Canvas.hDC, new_brush)
        status = Polygon(Canvas.hDC, pts1(1), 4)
        new_pen = SelectObject(Canvas.hDC, old_pen)
        status = DeleteObject(new_pen)
        new_brush = SelectObject(Canvas.hDC, old_brush)
        status = DeleteObject(new_brush)

        new_pen = CreatePen(PS_SOLID, 1, &H1000000 + 100 + 29 - clr)
        old_pen = SelectObject(Canvas.hDC, new_pen)
        new_brush = CreateSolidBrush(&H1000000 + 100 + 29 - clr)
        old_brush = SelectObject(Canvas.hDC, new_brush)
        status = Polygon(Canvas.hDC, pts2(1), 4)
        new_pen = SelectObject(Canvas.hDC, old_pen)
        status = DeleteObject(new_pen)
        new_brush = SelectObject(Canvas.hDC, old_brush)
        status = DeleteObject(new_brush)

        clr = (clr + 1) Mod 30
    Next theta
    Canvas.Refresh
End Sub
' ************************************************
' Initialize the color component array.
' ************************************************
Sub InitColors()
Dim i As Integer
    For i = 1 To 16
        Component(i - 1) = i * 16 - 1
    Next i
    For i = 16 To 29
        Component(i) = Component(30 - i)
    Next i
End Sub
' ************************************************
' Set the colors values in paltte entries 100
' through 129 to saturations of blue.
' ************************************************
Sub SetColors()
Static start_color As Integer
Dim clr As Integer
Dim status As Integer
Dim i As Integer
    clr = start_color
    start_color = (start_color + 1) Mod 30
    For i = 100 To 129
        With palentry(i)
            .peRed = Component(clr)
            .peGreen = Component(clr)
            .peBlue = 255
        End With
        clr = (clr + 1) Mod 30
    Next i
    status = SetPaletteEntries(LogPal, 100, 30, palentry(100))
    status = RealizePalette(Canvas.hDC)
End Sub
Private Sub CmdGo_Click()
    If Running Then
        Running = False
        CmdGo.Caption = "Stopped"
        CmdGo.Enabled = False
    Else
        Running = True
        CmdGo.Caption = "Stop"
        AnimateColors
        Running = False
        CmdGo.Caption = "Go"
        CmdGo.Enabled = True
    End If
End Sub
Private Sub Form_Load()
Const GAP = 3
Dim status As Long
Dim i As Integer
    ' Make sure the screen supports palettes.
    If Not GetDeviceCaps(hDC, RASTERCAPS) And RC_PALETTE Then
        Beep
        MsgBox "This monitor does not support palettes.", _
            vbCritical
        End
    End If
    ' Get system palette size and # static colors.
    SysPalSize = GetDeviceCaps(hDC, SIZEPALETTE)
    NumStaticColors = GetDeviceCaps(hDC, NUMRESERVED)
    StaticColor1 = NumStaticColors \ 2 - 1
    StaticColor2 = SysPalSize - NumStaticColors \ 2
    ' Get the palette entries.
    status = GetSystemPaletteEntries(Canvas.hDC, 0, 256, palentry(0))
    For i = 0 To 255
        palentry(i).peFlags = PC_NOCOLLAPSE
    Next i
    LogPal = Canvas.Picture.hPal
    status = SetPaletteEntries(LogPal, 0, 256, palentry(0))
    ' Place the controls.
    CmdGo.Move (ScaleWidth - CmdGo.Width) / 2, _
        ScaleHeight - CmdGo.Height - GAP
    Canvas.Move 0, 0, ScaleWidth, _
        ScaleHeight - CmdGo.Height - 2 * GAP
    Label1.Move (Canvas.ScaleWidth - Label1.Width) / 2
    Label2.Move (Canvas.ScaleWidth - Label2.Width) / 2
    ' Initialize the colors.
    InitColors
    ' Define the colors.
    SetColors
    ' Set the label colors.
    Label1.ForeColor = &H1000000 + 107
    Label2.ForeColor = &H1000000 + 122
    ' Draw the circle.
    DrawCircle
End Sub
Private Sub Form_Unload(Cancel As Integer)
    End
End Sub
Private Sub mnuFileExit_Click()
    End
End Sub