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

Visual Basic Form | 1997-01-08 | 24.4 KB | 803 lines

VERSION 4.00
Begin VB.Form SceneForm
   Caption         =   "Scenes"
   ClientHeight    =   3840
   ClientLeft      =   1635
   ClientTop       =   1230
   ClientWidth     =   5400
   Height          =   4530
   Left            =   1575
   LinkTopic       =   "Form1"
   ScaleHeight     =   256
   ScaleMode       =   3  'Pixel
   ScaleWidth      =   360
   Top             =   600
   Width           =   5520
   Begin VB.CommandButton CmdCenterWipe
      Caption         =   "Center Wipe"
      Height          =   495
      Left            =   0
      TabIndex        =   8
      Top             =   1320
      Width           =   1455
   End
   Begin VB.CommandButton CmdHWipe
      Caption         =   "Horizontal Wipe"
      Height          =   495
      Left            =   0
      TabIndex        =   7
      Top             =   720
      Width           =   1455
   End
   Begin VB.CommandButton CmdSpiralWipe
      Caption         =   "Spiral Wipe"
      Height          =   495
      Left            =   0
      TabIndex        =   6
      Top             =   1920
      Width           =   1455
   End
   Begin VB.CommandButton CmdVWipe
      Caption         =   "Vertical Wipe"
      Height          =   495
      Left            =   0
      TabIndex        =   5
      Top             =   120
      Width           =   1455
   End
   Begin VB.CommandButton CmdTileOver
      Caption         =   "Tile Over"
      Height          =   495
      Left            =   0
      TabIndex        =   4
      Top             =   2520
      Width           =   1455
   End
   Begin VB.CommandButton CmdFade
      Caption         =   "Fade"
      Height          =   495
      Left            =   0
      TabIndex        =   3
      Top             =   3120
      Width           =   1455
   End
   Begin VB.PictureBox Canvas
      AutoRedraw      =   -1  'True
      Height          =   3810
      Left            =   1560
      Picture         =   "SCENES.frx":0000
      ScaleHeight     =   250
      ScaleMode       =   3  'Pixel
      ScaleWidth      =   250
      TabIndex        =   2
      Top             =   0
      Width           =   3810
   End
   Begin VB.PictureBox Pict
      AutoRedraw      =   -1  'True
      AutoSize        =   -1  'True
      Height          =   3810
      Index           =   1
      Left            =   120
      Picture         =   "SCENES.frx":FA5A
      ScaleHeight     =   250
      ScaleMode       =   3  'Pixel
      ScaleWidth      =   250
      TabIndex        =   1
      Top             =   3840
      Visible         =   0   'False
      Width           =   3810
   End
   Begin VB.PictureBox Pict
      AutoRedraw      =   -1  'True
      AutoSize        =   -1  'True
      Height          =   3810
      Index           =   0
      Left            =   0
      Picture         =   "SCENES.frx":1F4B4
      ScaleHeight     =   250
      ScaleMode       =   3  'Pixel
      ScaleWidth      =   250
      TabIndex        =   0
      Top             =   3720
      Visible         =   0   'False
      Width           =   3810
   End
   Begin VB.Menu mnuFile
      Caption         =   "&File"
      Begin VB.Menu mnuFileExit
         Caption         =   "E&xit"
      End
   End
Attribute VB_Name = "SceneForm"
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 ActiveImage As Integer
' ***********************************************
' Give the form and all the picture boxes an
' hourglass cursor.
' ***********************************************
Sub WaitStart()
    MousePointer = vbHourglass
    Canvas.MousePointer = vbHourglass
    DoEvents
End Sub
' ***********************************************
' Restore the mouse pointers for the form and all
' the picture boxes.
' ***********************************************
Sub WaitEnd()
    MousePointer = vbDefault
    Canvas.MousePointer = vbDefault
End Sub
' ************************************************
' Wipe tpic over fpic from the inside out.
' ************************************************
Sub CenterWipe(fpic As Control, tpic As Control)
Dim bm As BITMAP
Dim hbm As Integer
Dim wid As Long
Dim hgt As Long
Dim fbytes() As Byte
Dim tbytes() As Byte
Dim status As Long
Dim dx As Integer
Dim dy As Integer
Dim xmin As Integer
Dim ymin As Integer
Dim xmid As Integer
Dim ymid As Integer
Dim xmax As Integer
Dim ymax As Integer
Dim next_time As Long
Dim dt As Long
Dim i As Integer
Dim j As Integer
Dim piece As Integer
    ' Get the new image's pixels.
    hbm = tpic.Image
    status = GetObject(hbm, BITMAP_SIZE, bm)
    wid = bm.bmWidthBytes
    hgt = bm.bmHeight
    ReDim tbytes(1 To wid, 1 To hgt)
    status = GetBitmapBits(hbm, wid * hgt, tbytes(1, 1))
    ' Get the old image's pixels.
    hbm = fpic.Image
    status = GetObject(hbm, BITMAP_SIZE, bm)
    wid = bm.bmWidthBytes
    hgt = bm.bmHeight
    ReDim fbytes(1 To wid, 1 To hgt)
    status = GetBitmapBits(hbm, wid * hgt, fbytes(1, 1))
    ' Display the new image in 20 increments.
    xmid = (wid + 1) / 2
    ymid = (hgt + 1) / 2
    dx = CInt(wid / 40 + 1)
    dy = CInt(hgt / 40 + 1)
    dt = 1000 \ 20
    next_time = GetTickCount()
    For piece = 1 To 20
        xmin = xmid - piece * dx
        If xmin < 1 Then xmin = 1
        xmax = xmid + piece * dx
        If xmax > wid Then xmax = wid

        ymin = ymid - piece * dy
        If ymin < 1 Then ymin = 1
        ymax = ymid + piece * dy
        If ymax > hgt Then ymax = hgt

        For i = xmin To xmax
            For j = ymin To ymin + dy
                fbytes(i, j) = tbytes(i, j)
            Next j
            For j = ymax - dy To ymax
                fbytes(i, j) = tbytes(i, j)
            Next j
        Next i
        For j = ymin + dx To ymax - dx
            For i = xmin To xmin + dx
                fbytes(i, j) = tbytes(i, j)
            Next i
            For i = xmax - dx To xmax
                fbytes(i, j) = tbytes(i, j)
            Next i
        Next j
        status = SetBitmapBits(hbm, wid * hgt, fbytes(1, 1))
        fpic.Refresh

        next_time = next_time + dt
        WaitTill next_time
    Next piece
End Sub
' ************************************************
' Copy tpic over fpic in a spiral pattern.
' ************************************************
Sub SpiralWipe(fpic As Control, tpic As Control)
Const PER_SIDE = 7      ' # pieces per side.
Const CHUNKS = PER_SIDE * PER_SIDE
Dim bm As BITMAP
Dim hbm As Integer
Dim wid As Long
Dim hgt As Long
Dim fbytes() As Byte
Dim tbytes() As Byte
Dim status As Long
Dim i As Integer
Dim j As Integer
Dim row As Integer
Dim col As Integer
Dim dx As Integer
Dim dy As Integer
Dim xmin As Integer
Dim ymin As Integer
Dim xmax As Integer
Dim ymax As Integer
Dim rmin As Integer
Dim cmin As Integer
Dim rmax As Integer
Dim cmax As Integer
Dim next_time As Long
Dim dt As Long
    ' Get the new image's pixels.
    hbm = tpic.Image
    status = GetObject(hbm, BITMAP_SIZE, bm)
    wid = bm.bmWidthBytes
    hgt = bm.bmHeight
    ReDim tbytes(1 To wid, 1 To hgt)
    status = GetBitmapBits(hbm, wid * hgt, tbytes(1, 1))
    ' Get the old image's pixels.
    hbm = fpic.Image
    status = GetObject(hbm, BITMAP_SIZE, bm)
    wid = bm.bmWidthBytes
    hgt = bm.bmHeight
    ReDim fbytes(1 To wid, 1 To hgt)
    status = GetBitmapBits(hbm, wid * hgt, fbytes(1, 1))
    ' Display the pieces of tpic.
    dx = CInt(wid / PER_SIDE + 1)
    dy = CInt(hgt / PER_SIDE + 1)
    dt = 1000 \ CHUNKS
    next_time = GetTickCount()
    rmin = 0
    cmin = 0
    rmax = PER_SIDE - 1
    cmax = PER_SIDE - 1
    Do
        ' Display the top row.
        For col = cmin To cmax
            xmin = col * dx + 1
            ymin = rmin * dy + 1
            xmax = xmin + dx - 1
            If xmax > wid Then xmax = wid
            ymax = ymin + dy - 1
            If ymax > hgt Then ymax = hgt
            For i = xmin To xmax
                For j = ymin To ymax
                    fbytes(i, j) = tbytes(i, j)
                Next j
            Next i
            status = SetBitmapBits(hbm, wid * hgt, fbytes(1, 1))
            fpic.Refresh
            next_time = next_time + dt
            WaitTill next_time
        Next col
        rmin = rmin + 1
        If rmin > rmax Then Exit Do

        ' Display the right column.
        For row = rmin To rmax
            xmin = cmax * dx + 1
            ymin = row * dy + 1
            xmax = xmin + dx - 1
            If xmax > wid Then xmax = wid
            ymax = ymin + dy - 1
            If ymax > hgt Then ymax = hgt
            For i = xmin To xmax
                For j = ymin To ymax
                    fbytes(i, j) = tbytes(i, j)
                Next j
            Next i
            status = SetBitmapBits(hbm, wid * hgt, fbytes(1, 1))
            fpic.Refresh
            next_time = next_time + dt
            WaitTill next_time
        Next row
        cmax = cmax - 1
        If cmax < cmin Then Exit Do

        ' Display the bottom row.
        For col = cmax To cmin Step -1
            xmin = col * dx + 1
            ymin = rmax * dy + 1
            xmax = xmin + dx - 1
            If xmax > wid Then xmax = wid
            ymax = ymin + dy - 1
            If ymax > hgt Then ymax = hgt
            For i = xmin To xmax
                For j = ymin To ymax
                    fbytes(i, j) = tbytes(i, j)
                Next j
            Next i
            status = SetBitmapBits(hbm, wid * hgt, fbytes(1, 1))
            fpic.Refresh
            next_time = next_time + dt
            WaitTill next_time
        Next col
        rmax = rmax - 1
        If rmin > rmax Then Exit Do

        ' Display the left column.
        For row = rmax To rmin Step -1
            xmin = cmin * dx + 1
            ymin = row * dy + 1
            xmax = xmin + dx - 1
            If xmax > wid Then xmax = wid
            ymax = ymin + dy - 1
            If ymax > hgt Then ymax = hgt
            For i = xmin To xmax
                For j = ymin To ymax
                    fbytes(i, j) = tbytes(i, j)
                Next j
            Next i
            status = SetBitmapBits(hbm, wid * hgt, fbytes(1, 1))
            fpic.Refresh
            next_time = next_time + dt
            WaitTill next_time
        Next row
        cmin = cmin + 1
        If cmax < cmin Then Exit Do
    Loop
End Sub
' ************************************************
' Fade fpic out and then fade tpic in.
' ************************************************
Sub Fade(fpic As Control, tpic As Control)
Dim bm As BITMAP
Dim hbm As Integer
Dim wid As Long
Dim hgt As Long
Dim bytes() As Byte
Dim status As Long
Dim hpal As Integer
Dim pal(0 To 255) As PALETTEENTRY
Dim newpal(0 To 255) As PALETTEENTRY
Dim level As Single
Dim next_time As Long
Dim num_entries As Integer
Dim i As Integer
    ' Flag all palette entries NOCOLLAPSE.
    For i = 0 To 255
        newpal(i).peFlags = PC_NOCOLLAPSE
    Next i
    ' Get fpic's logical palette.
    fpic.ZOrder
    DoEvents
    hpal = fpic.Picture.hpal
    num_entries = GetPaletteEntries(hpal, 0, 256, pal(0))
    ' Fade out using 20 intensity levels in about
    ' 1 second.
    For level = 0.95 To 0# Step -0.05
        For i = StaticColor1 + 1 To StaticColor2 - 1
            With newpal(i)
                .peRed = pal(i).peRed * level
                .peGreen = pal(i).peGreen * level
                .peBlue = pal(i).peBlue * level
            End With
        Next i
        status = SetPaletteEntries(hpal, StaticColor1 + 1, StaticColor2 - StaticColor1 + 1, newpal(StaticColor1 + 1))
        status = RealizePalette(fpic.hdc)
        fpic.Refresh
        next_time = next_time + 50
        WaitTill next_time
    Next level
    ' Get the new image's pixels.
    hbm = tpic.Image
    status = GetObject(hbm, BITMAP_SIZE, bm)
    wid = bm.bmWidthBytes
    hgt = bm.bmHeight
    ReDim bytes(1 To wid, 1 To hgt)
    status = GetBitmapBits(hbm, wid * hgt, bytes(1, 1))
    ' Assign the new pixels to fpic.
    status = SetBitmapBits(fpic.Image, wid * hgt, bytes(1, 1))
    fpic.Refresh
    ' Get tpic's logical palette.
    num_entries = GetPaletteEntries(tpic.Picture.hpal, 0, 256, pal(0))
    ' Fade in using 20 intensity levels in about
    ' 1 second.
    For level = 0.05 To 1# Step 0.05
        For i = 0 To num_entries - 1
            With newpal(i)
                .peRed = pal(i).peRed * level
                .peGreen = pal(i).peGreen * level
                .peBlue = pal(i).peBlue * level
            End With
        Next i
        status = SetPaletteEntries(hpal, StaticColor1 + 1, StaticColor2 - StaticColor1 + 1, newpal(StaticColor1 + 1))
        status = RealizePalette(fpic.hdc)
        fpic.Refresh
        next_time = next_time + 50
        WaitTill next_time
    Next level
End Sub
' ************************************************
' Wipe tpic onto fpic vertically.
' ************************************************
Sub VWipe(fpic As Control, tpic As Control)
Dim bm As BITMAP
Dim hbm As Integer
Dim wid As Long
Dim hgt As Long
Dim fbytes() As Byte
Dim tbytes() As Byte
Dim status As Long
Dim i As Integer
Dim j As Integer
Dim x As Integer
Dim y As Integer
Dim dy As Integer
Dim lasty As Integer
Dim next_time As Long
    ' Get the new image's pixels.
    hbm = tpic.Image
    status = GetObject(hbm, BITMAP_SIZE, bm)
    wid = bm.bmWidthBytes
    hgt = bm.bmHeight
    ReDim tbytes(1 To wid, 1 To hgt)
    status = GetBitmapBits(hbm, wid * hgt, tbytes(1, 1))
    ' Get the old image's pixels.
    hbm = fpic.Image
    status = GetObject(hbm, BITMAP_SIZE, bm)
    wid = bm.bmWidthBytes
    hgt = bm.bmHeight
    ReDim fbytes(1 To wid, 1 To hgt)
    status = GetBitmapBits(hbm, wid * hgt, fbytes(1, 1))
    ' Use 20 images in about 1 second.
    dy = CInt(hgt / 20 + 1)
    next_time = GetTickCount()
    For y = 1 To hgt Step dy
        lasty = y + dy - 1
        If lasty > hgt Then lasty = hgt
        For j = y To lasty
            For i = 1 To wid
                fbytes(i, j) = tbytes(i, j)
            Next i
        Next j

        status = SetBitmapBits(hbm, wid * hgt, fbytes(1, 1))
        fpic.Refresh

        next_time = next_time + 50
        WaitTill next_time
    Next y
End Sub
' ************************************************
' Wipe tpic onto fpic horizontally.
' ************************************************
Sub HWipe(fpic As Control, tpic As Control)
Dim bm As BITMAP
Dim hbm As Integer
Dim wid As Long
Dim hgt As Long
Dim fbytes() As Byte
Dim tbytes() As Byte
Dim status As Long
Dim i As Integer
Dim j As Integer
Dim x As Integer
Dim y As Integer
Dim dx As Integer
Dim lastx As Integer
Dim next_time As Long
    ' Get the new image's pixels.
    hbm = tpic.Image
    status = GetObject(hbm, BITMAP_SIZE, bm)
    wid = bm.bmWidthBytes
    hgt = bm.bmHeight
    ReDim tbytes(1 To wid, 1 To hgt)
    status = GetBitmapBits(hbm, wid * hgt, tbytes(1, 1))
    ' Get the old image's pixels.
    hbm = fpic.Image
    status = GetObject(hbm, BITMAP_SIZE, bm)
    wid = bm.bmWidthBytes
    hgt = bm.bmHeight
    ReDim fbytes(1 To wid, 1 To hgt)
    status = GetBitmapBits(hbm, wid * hgt, fbytes(1, 1))
    ' Use 20 images in about 1 second.
    dx = CInt(wid / 20 + 1)
    next_time = GetTickCount()
    For x = 1 To wid Step dx
        lastx = x + dx - 1
        If lastx > wid Then lastx = wid
        For i = x To lastx
            For j = 1 To hgt
                fbytes(i, j) = tbytes(i, j)
            Next j
        Next i

        status = SetBitmapBits(hbm, wid * hgt, fbytes(1, 1))
        fpic.Refresh

        next_time = next_time + 50
        WaitTill next_time
    Next x
End Sub
' ************************************************
' Dissolve tpic over fpic in random chunks.
' ************************************************
Private Sub CmdTileOver_Click()
    ActiveImage = 1 - ActiveImage
    WaitStart
    TileOver Canvas, Pict(ActiveImage)
    WaitEnd
End Sub
' ************************************************
' Perform a vertical wipe.
' ************************************************
Private Sub CmdVWipe_Click()
    ActiveImage = 1 - ActiveImage
    WaitStart
    VWipe Canvas, Pict(ActiveImage)
    WaitEnd
End Sub
' ************************************************
' Expand the new image from the center out.
' ************************************************
Private Sub CmdCenterWipe_Click()
    ActiveImage = 1 - ActiveImage
    WaitStart
    CenterWipe Canvas, Pict(ActiveImage)
    WaitEnd
End Sub
' ************************************************
' Drop the new picture over the old in a spiral
' chunk pattern.
' ************************************************
Private Sub CmdSpiralWipe_Click()
    ActiveImage = 1 - ActiveImage
    WaitStart
    SpiralWipe Canvas, Pict(ActiveImage)
    WaitEnd
End Sub
' ************************************************
' Fade one image out and the other in.
' ************************************************
Private Sub CmdFade_Click()
    ActiveImage = 1 - ActiveImage
    WaitStart
    Fade Canvas, Pict(ActiveImage)
    WaitEnd
End Sub
' ************************************************
' Tile tpic over fpic in random chunks.
' ************************************************
Sub TileOver(fpic As Control, tpic As Control)
Const PER_SIDE = 7      ' # chunks per side.
Const CHUNKS = PER_SIDE * PER_SIDE
Dim bm As BITMAP
Dim hbm As Integer
Dim wid As Long
Dim hgt As Long
Dim fbytes() As Byte
Dim tbytes() As Byte
Dim status As Long
Dim i As Integer
Dim j As Integer
Dim row As Integer
Dim col As Integer
Dim piece As Integer
Dim next_piece(0 To CHUNKS - 1) As Integer
Dim remaining As Integer
Dim dx As Integer
Dim dy As Integer
Dim xmin As Integer
Dim ymin As Integer
Dim xmax As Integer
Dim ymax As Integer
Dim next_time As Long
Dim dt As Long
    ' Get the new image's pixels.
    hbm = tpic.Image
    status = GetObject(hbm, BITMAP_SIZE, bm)
    wid = bm.bmWidthBytes
    hgt = bm.bmHeight
    ReDim tbytes(1 To wid, 1 To hgt)
    status = GetBitmapBits(hbm, wid * hgt, tbytes(1, 1))
    ' Get the old image's pixels.
    hbm = fpic.Image
    status = GetObject(hbm, BITMAP_SIZE, bm)
    wid = bm.bmWidthBytes
    hgt = bm.bmHeight
    ReDim fbytes(1 To wid, 1 To hgt)
    status = GetBitmapBits(hbm, wid * hgt, fbytes(1, 1))
    ' Initialize the list of pieces.
    For piece = 0 To CHUNKS - 1
        next_piece(piece) = piece
    Next piece
    ' Display randomly selected pieces of tpic.
    dx = CInt(wid / PER_SIDE + 1)
    dy = CInt(hgt / PER_SIDE + 1)
    dt = 1000 \ CHUNKS
    next_time = GetTickCount()
    For remaining = CHUNKS To 1 Step -1
        ' Select a random piece to display.
        piece = Int((remaining - 1) * Rnd)

        ' Display the piece.
        row = next_piece(piece) \ PER_SIDE
        col = next_piece(piece) Mod PER_SIDE
        xmin = col * dx + 1
        ymin = row * dy + 1
        xmax = xmin + dx - 1
        If xmax > wid Then xmax = wid
        ymax = ymin + dy - 1
        If ymax > hgt Then ymax = hgt
        For i = xmin To xmax
            For j = ymin To ymax
                fbytes(i, j) = tbytes(i, j)
            Next j
        Next i
        status = SetBitmapBits(hbm, wid * hgt, fbytes(1, 1))
        fpic.Refresh

        ' Remove the piece from the piece list.
        For i = piece + 1 To remaining - 1
            next_piece(i - 1) = next_piece(i)
        Next i

        next_time = next_time + dt
        WaitTill next_time
    Next remaining
End Sub
' ************************************************
' Perform a horizontal wipe.
' ************************************************
Private Sub CmdHWipe_Click()
    ActiveImage = 1 - ActiveImage
    WaitStart
    HWipe Canvas, Pict(ActiveImage)
    WaitEnd
End Sub
Private Sub Form_Load()
    Randomize
    ' 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 bitmaps' bits.
    Me.Show
    WaitStart
    MatchGrayPalette Canvas
    MatchGrayPalette Pict(0)
    MatchGrayPalette Pict(1)
    Canvas.ZOrder
    DoEvents
    Pict(0).ZOrder
    DoEvents
    Pict(1).ZOrder
    DoEvents
    WaitEnd
End Sub
' ************************************************
' Return the index of the nonstatic gray closest
' to the given value (assuming the non-static
' colors are a gray scale created by
' MatchGrayPalette).
' ************************************************
Function NearestNonstaticGray(c As Integer) As Integer
Dim dgray As Single
    If c < 0 Then
        c = 0
    ElseIf c > 255 Then
        c = 255
    End If
    dgray = 255 / (StaticColor2 - StaticColor1 - 2)
    NearestNonstaticGray = c / dgray + StaticColor1 + 1
End Function
' ***********************************************
' Load the control's palette so the non-static
' colors are grays. Map the logical palette to
' match the system palette. Convert the image to
' use the non-static grays.
' ***********************************************
Sub MatchGrayPalette(pic As Control)
Dim logpal As Integer
Dim sys(0 To 255) As PALETTEENTRY
Dim palentry(0 To 255) As PALETTEENTRY
Dim i As Integer
Dim bm As BITMAP
Dim hbm As Integer
Dim status As Long
Dim x As Integer
Dim y As Integer
Dim gray As Single
Dim dgray As Single
Dim c As Integer
Dim clr As Integer
Dim wid As Long
Dim hgt As Long
Dim bytes() As Byte
    ' Make sure pic has the foreground palette.
    pic.ZOrder
    i = RealizePalette(pic.hdc)
    DoEvents
    ' Get the system palette entries.
    i = GetSystemPaletteEntries(pic.hdc, 0, SysPalSize, sys(0))

    ' Get the image pixels.
    hbm = pic.Image
    status = GetObject(hbm, BITMAP_SIZE, bm)
    wid = bm.bmWidthBytes
    hgt = bm.bmHeight
    ReDim bytes(1 To wid, 1 To hgt)
    status = GetBitmapBits(hbm, wid * hgt, bytes(1, 1))
    ' Make the logical palette as big as possible.
    logpal = pic.Picture.hpal
    If ResizePalette(logpal, SysPalSize) = 0 Then
        Beep
        MsgBox "Error resizing logical palette.", _
            vbExclamation
        Exit Sub
    End If
    ' Blank the non-static colors.
    For i = 0 To StaticColor1
        palentry(i) = sys(i)
    Next i
    For i = StaticColor1 + 1 To StaticColor2 - 1
        With palentry(i)
            .peRed = 0
            .peGreen = 0
            .peBlue = 0
            .peFlags = PC_NOCOLLAPSE
        End With
    Next i
    For i = StaticColor2 To 255
        palentry(i) = sys(i)
    Next i
    i = SetPaletteEntries(logpal, 0, SysPalSize, palentry(0))
    ' Insert the non-static grays.
    gray = 0
    dgray = 255 / (StaticColor2 - StaticColor1 - 2)
    For i = StaticColor1 + 1 To StaticColor2 - 1
        c = gray
        gray = gray + dgray
        With palentry(i)
            .peRed = c
            .peGreen = c
            .peBlue = c
        End With
    Next i
    i = SetPaletteEntries(logpal, StaticColor1 + 1, StaticColor2 - StaticColor1 - 1, palentry(StaticColor1 + 1))
    ' Recreate the image using the new colors.
    For y = 1 To hgt
        For x = 1 To wid
            clr = bytes(x, y)
            With sys(clr)
                c = (CInt(.peRed) + .peGreen + .peBlue) / 3
            End With
            bytes(x, y) = NearestNonstaticGray(c)
        Next x
    Next y
    status = SetBitmapBits(hbm, wid * hgt, bytes(1, 1))
    ' Realize the gray palette.
    i = RealizePalette(pic.hdc)
    pic.Refresh
End Sub
Private Sub Form_Unload(Cancel As Integer)
    End
End Sub
Private Sub mnuFileExit_Click()
    Unload Me
End Sub