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/vbpg32/samples4/ch09/puzzle.frm

Visual Basic Form | 1997-02-16 | 14.0 KB | 387 lines

VERSION 4.00
Begin VB.Form Puzzle
   Appearance      =   0  'Flat
   BackColor       =   &H80000005&
   Caption         =   "Puzzle"
   ClientHeight    =   3645
   ClientLeft      =   1095
   ClientTop       =   1770
   ClientWidth     =   3735
   BeginProperty Font {0BE35203-8F91-11CE-9DE3-00AA004BB851}
      Name            =   "MS Sans Serif"
      Size            =   8.25
      Charset         =   0
      Weight          =   700
      Underline       =   0   'False
      Italic          =   0   'False
      Strikethrough   =   0   'False
   EndProperty
   ForeColor       =   &H80000008&
   Height          =   4335
   Left            =   1035
   LinkMode        =   1  'Source
   LinkTopic       =   "Form1"
   ScaleHeight     =   3645
   ScaleWidth      =   3735
   Top             =   1140
   Width           =   3855
   Begin VB.PictureBox Picture2
      Appearance      =   0  'Flat
      BackColor       =   &H80000005&
      ForeColor       =   &H80000008&
      Height          =   2535
      Left            =   1680
      Picture         =   "PUZZLE.frx":0000
      ScaleHeight     =   2505
      ScaleWidth      =   1905
      TabIndex        =   1
      Top             =   360
      Visible         =   0   'False
      Width           =   1935
   End
   Begin VB.PictureBox Picture1
      Appearance      =   0  'Flat
      BackColor       =   &H80000005&
      ForeColor       =   &H80000008&
      Height          =   1215
      Left            =   240
      ScaleHeight     =   79
      ScaleMode       =   3  'Pixel
      ScaleWidth      =   79
      TabIndex        =   0
      Top             =   360
      Width           =   1215
   End
   Begin VB.Menu MenuScramble
      Caption         =   "Scramble"
   End
   Begin VB.Menu MenuLoad
      Caption         =   "Load"
   End
   Begin VB.Menu MenuEmptyCaption
      Caption         =   "Empty"
      Begin VB.Menu MenuEmpty
         Caption         =   "Black"
         Checked         =   -1  'True
         Index           =   0
      End
      Begin VB.Menu MenuEmpty
         Caption         =   "White"
         Index           =   1
      End
      Begin VB.Menu MenuEmpty
         Caption         =   "Random"
         Index           =   2
      End
   End
Attribute VB_Name = "Puzzle"
Attribute VB_Creatable = False
Attribute VB_Exposed = False
Option Explicit
' Copyright
 1997 by Desaware Inc. All Rights Reserved
'   Calculate all source and destination rectangles
'   Call this whenever the form size changes or the
'   image bitmap is changed.
Private Sub CalcRects()
    Dim x%, y%, pos%
    Dim bmsegwidth%, bmsegheight%
    Dim picsegwidth%, picsegheight%
    Dim di&
    ' Find the approx. height and width of each tile on
    ' the puzzle screen.
    picsegwidth% = (PuzzleRect.Right - PuzzleRect.Left) / 5
    picsegheight% = (PuzzleRect.Bottom - PuzzleRect.Top) / 5
    ' Get information on the bitmap in picture2
    ' This loads the BITMAP structure bmInfo with information
    ' on the bitmap.
    di = GetObjectAPI(Picture2.Picture, Len(BMinfo), BMinfo)
    bmsegwidth% = BMinfo.bmWidth / 5
    bmsegheight% = BMinfo.bmHeight / 5
    ' Fill in the rectangle description for each rectangle on
    ' the destination DC
    For y% = 0 To 4
        For x% = 0 To 4
            pos% = y% * 5 + x%
            DestRects(pos%).Top = y% * picsegheight%
            DestRects(pos%).Bottom = (y% + 1) * picsegheight%
            DestRects(pos%).Left = x% * picsegwidth%
            DestRects(pos%).Right = (x% + 1) * picsegwidth%
        Next x%
    Next y%
    ' Fill in the rectangle description for each rectangle on
    ' the source bitmap
    For y% = 0 To 4
        For x% = 0 To 4
            pos% = y% * 5 + x%
            SourceRects(pos%).Top = y% * bmsegheight%
            SourceRects(pos%).Bottom = (y% + 1) * bmsegheight%
            SourceRects(pos%).Left = x% * bmsegwidth%
            SourceRects(pos%).Right = (x% + 1) * bmsegwidth%
            ' Make sure the rectangle does not exceed the
            ' source area for the bitmap or StretchBlt will fail
            If x% = 4 Then SourceRects(pos%).Right = BMinfo.bmWidth
            If y% = 4 Then SourceRects(pos%).Bottom = BMinfo.bmHeight
        Next x%
    Next y%
End Sub
'   Creates a brush to use for the empty square
'   This function demonstrates the creation of device
'   independent bitmaps, converting DIBs to a device dependent
'   bitmap and finally converting a DDB into a brush.
Private Sub CreateEmptyBrush()
Dim compbitmap&
Dim bih As BITMAPINFOHEADER
Dim bi As BITMAPINFO
ReDim colarray&(16)
Dim x%
Dim di&
' This used to be a string
Dim da(32) As Byte  ' Each byte contains 2 x 4bit pixels
Dim buf$
Dim bufstart&, sourceaddr&
Dim oldbm&
    ' Prepare the bitmap information header
    bih.biSize = 40     ' 40 bytes in this structure
    bih.biWidth = 8     ' 8x8 -we'll be creating a brush
    bih.biHeight = 8    ' from this bimap
    bih.biPlanes = 1    ' DIB's always 1 plane
    bih.biBitCount = 4  ' 16 colors, 4 bits/color
    bih.biCompression = BI_RGB  ' no compression
    bih.biSizeImage = 0         ' Not needed on BI_RGB
    bih.biXPelsPerMeter = 0     ' Not used
    bih.biYPelsPerMeter = 0     ' Not used
    bih.biClrUsed = 16          ' All colors used
    bih.biClrImportant = 0      ' All colors important
    ' Now fill the color array
    For x% = 0 To 15
        colarray&(x%) = QBColor(x%)
    Next x%
    ' Now we need to set the data array - for now, we're
    ' just going to put in random pixel data
    For x% = 1 To 32
        ' Note how we pack two nibbles
        ' The old way
        ' Mid$(da, x%, 1) = Chr$(Int(Rnd * 16) + Int(Rnd * 16) * 16)
        ' The new way
        da(x%) = Int(Rnd * 16) + Int(Rnd * 16) * 16
    Next x%
    ' Now we load the BITMAPINFO structure bi
    LSet bi.bmiHeader = bih
    ' Now copy the color array into the BITMAPINFO
    ' bi.bmiColors string which begins 40 characters after
    ' the start of the structure.
    ' Refer to Chapter 15 for information on the subtleties
    ' of extracting addresses for strings in a structure.
    bufstart& = agGetAddressForObject(bi.bmiHeader.biSize) + 40
    ' Get the address of the start of the colarray color array
    sourceaddr& = agGetAddressForLong(colarray&(0))
    ' And copy the 64 bytes
    agCopyDataBynum sourceaddr&, bufstart&, 64
    ' Now create the bitmap
    compbitmap& = CreateDIBitmap(Puzzle.hdc, bih, CBM_INIT, da(0), bi, DIB_RGB_COLORS)
    ' Now create a brush from this bitmap
    EmptySquareBrush& = CreatePatternBrush(compbitmap)
    ' And delete the source bitmap
    di = DeleteObject&(compbitmap&)
End Sub
Private Sub DoUpdate()
'   Update the picture with rectangles based on the
'   puzzle array
    Dim x%
    For x% = 0 To 24
        UpdateOne x%
    Next x%
End Sub
' Initialization routine
Private Sub Form_Load()
    Randomize
    SetPuzzleSize   ' Set the size of the puzzle window
    CalcRects       ' Calculate the window tiles
    Scramble        ' Scramble them
    CreateEmptyBrush    ' Create a random brush for the
                        ' empty square.
End Sub
'   When the form is resized, call SetPuzzleSize to
'   adjust the size of the picture window and rescale
'   the image.
Private Sub Form_Resize()
    SetPuzzleSize   ' Set the size of the puzzle window
    CalcRects       ' And recalculate the tiles
    Picture1.Refresh    ' Update the picture control
End Sub
'   Clean up by deleting GDI objects that are no longer
'   needed.
Private Sub Form_Unload(Cancel As Integer)
    Dim di&
    If ShadowDC& Then di = DeleteDC(ShadowDC)
    If EmptySquareBrush& Then di = DeleteObject(EmptySquareBrush)
End Sub
'   Choose the color for the empty square
Private Sub MenuEmpty_Click(Index As Integer)
    Dim x%
    MenuEmpty(EmptySquareMode%).Checked = 0
    MenuEmpty(Index).Checked = -1
    EmptySquareMode% = Index
    DoUpdate
End Sub
'   Bring up the file load dialog box to load a new
'   bitmap into the puzzle.
Private Sub MenuLoad_Click()
    DoTheUpdate = 0 ' Preset the update flag to false
    Puzzle2.Show 1  ' Show the file load form modal
    If DoTheUpdate Then ' A valid bitmap was loaded
        CalcRects   ' Recalculate the tiles
        Scramble    ' And refresh the image
    End If

End Sub
'   Rescramble the bitmap image
Private Sub MenuScramble_Click()
    Scramble
    DoUpdate  ' Redraw the puzzle window
End Sub
'   Clicking on a tile next to the empty tile causes that
'   tile to slide into the empty space.
Private Sub Picture1_MouseDown(Button As Integer, Shift As Integer, x As Single, y As Single)
    Dim pt As POINTAPI
    Dim u%
    Dim xpos%, ypos%
    Dim bxpos%, bypos%
    Dim dx%, dy%, tval%, hidden%
    pt.x = x    ' Picture1 scalemode is pixels
    pt.y = y
    ' Find the location of the black square
    ' Tile 24 in the bitmap is the missing piece.
    For hidden% = 0 To 24
        If Position%(hidden%) = 24 Then Exit For
    Next hidden%
    For u% = 0 To 24
        ' Find out which rectangle in the DestRects array
        ' contains the point specified by the mouse click.
        If PtInRect(DestRects(u%), pt.x, pt.y) Then
            Exit For
        End If
    Next u%
    ' Now find the X and Y coordinates for the mouse click
    ' and for the hidden tile.
    xpos% = u% Mod 5
    ypos% = Int(u% / 5)
    bxpos% = hidden% Mod 5
    bypos% = Int(hidden% / 5)
    ' The tile can slide into the empty square if it is
    ' one away from the empty square on the horizontal
    ' or vertical axis (but not both).
    dx% = Abs(xpos% - bxpos%)
    dy% = Abs(ypos% - bypos%)
    If (dx% = 1 And dy% = 0) Or (dx% = 0 And dy% = 1) Then
        tval% = Position%(u%)
        ' So simply swap this tile with the hidden one
        Position%(u%) = Position%(hidden%)
        Position%(hidden%) = tval%
        ' And update both these tiles
        UpdateOne u%
        UpdateOne hidden%
    End If
End Sub
'   Paint picture1 by calling the full puzzle Update routine
Private Sub Picture1_Paint()
    DoUpdate
End Sub
'   Scramble the puzzle array
Private Sub Scramble()
Dim x%, newpos%, hold%
    ' Initialize the positions
    For x% = 0 To 24
        Position%(x%) = x%
    Next x%
    ' Now scramble them
    For x% = 0 To 24
        ' For each source position, choose a random
        ' location and swap the two values.
        ' This is a simple and effective technique to
        ' randomize an array of numbers.
        newpos% = Int(Rnd * 25)
        hold% = Position(x%)
        Position(x%) = Position(newpos%)
        Position(newpos%) = hold%
    Next x%
End Sub
'   Sets the picture1 control to the visible form area
'   Also creates a compatible bitmap to work with
'   Call this any time the size of the form changes
Private Sub SetPuzzleSize()
Dim rc As RECT
    Dim di&
    Picture1.BorderStyle = 0
    Picture1.Left = 0
    Picture1.Top = 0
    di = GetClientRect(Puzzle.hwnd, rc)
    ' Actually, we need not subtract off rc.left and rc.top
    ' below as these fields are always 0 after a call to
    ' GetClientRect
    ' Note the conversion to twips in order to set the
    ' picture size using the VB properties
    ' We could have used the MoveWindow API call as well- or just set it based on the ScaleWidth and ScaleHeight
    ' of the form itself
    Picture1.Width = Screen.TwipsPerPixelX * (rc.Right - rc.Left)
    Picture1.Height = Screen.TwipsPerPixelY * (rc.Bottom - rc.Top)
    ' This line is actually not necessary - we could
    ' have just used a copy of rc because we just set
    ' the client area to that specified by rc!
    GetClientRect Picture1.hwnd, PuzzleRect
    ' Create a compatible memory DC for Picture1
    If ShadowDC Then di = DeleteDC(ShadowDC)
    ShadowDC = CreateCompatibleDC(Picture1.hdc)
End Sub
'   Copies a single tile from the picture2 bitmap to the
'   appropriate space in the picture1 destination.
'   x% is the position on the puzzle to update
Private Sub UpdateOne(x%)
    Dim oldbm&, pos&, oldbrush&
    ' Temporary variables for copying
    Dim sx&, sy&, sw&, sh&, dx&, dy&, dw&, dh&
    Dim di&
    ' Select the bitmap into the ShadowDC
    oldbm& = SelectObject(ShadowDC&, Picture2.Picture)
    ' Select the random brush we created into the picture DC
    If EmptySquareBrush& <> 0 Then oldbrush& = SelectObject(Picture1.hdc, EmptySquareBrush&)
    ' Get the position in the bitmap.
    ' Position 24 is the empty square
    pos& = Position(x)
    ' Calculate the rectangle on the puzzle display being
    ' updataed
    dx& = DestRects(x).Left
    dy& = DestRects(x).Top
    dw& = DestRects(x).Right - dx&
    dh& = DestRects(x).Bottom - dy&

    ' The bitmap locations are based on x% - the source
    ' location in the bitmap
    sx& = SourceRects(pos&).Left
    sy& = SourceRects(pos&).Top
    sw& = SourceRects(pos&).Right - sx&
    sh& = SourceRects(pos&).Bottom - sy&

    ' Now do the transfer
    ' Transfer all tiles from the source except for tile
    ' number 24 which is the black one.
    If pos <> 24 Then
        di& = StretchBlt(Picture1.hdc, dx, dy, dw, dh, ShadowDC, sx, sy, sw, sh, SRCCOPY)
    Else  ' Tile #24 is empty - use EmptySquareMode% to
          ' determine what type of square to set.
        Select Case EmptySquareMode%
            Case 0
                di = PatBlt(Picture1.hdc, dx, dy, dw, dh, BLACKNESS)
            Case 1
                di = PatBlt(Picture1.hdc, dx, dy, dw, dh, WHITENESS)
            Case 2
                di = PatBlt(Picture1.hdc, dx, dy, dw, dh, PATCOPY)
         End Select
    End If
    ' Select the bitmap out of the shadow DC
    di = SelectObject(ShadowDC, oldbm)
    ' And select the brush back to the original one
    If EmptySquareBrush <> 0 Then di = SelectObject(Picture1.hdc, oldbrush)
End Sub