form1.frm

超级纸牌游戏源代码

VERSION 5.00
Begin VB.Form Form1 
   Appearance      =   0  'Flat
   BackColor       =   &H00808000&
   Caption         =   "QCard.DLL Demo"
   ClientHeight    =   5055
   ClientLeft      =   1335
   ClientTop       =   2085
   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       =   &H00FFFFFF&
   LinkMode        =   1  'Source
   LinkTopic       =   "Form1"
   PaletteMode     =   1  'UseZOrder
   ScaleHeight     =   337
   ScaleMode       =   3  'Pixel
   ScaleWidth      =   498
   Begin VB.Timer Timer1 
      Enabled         =   0   'False
      Interval        =   200
      Left            =   120
      Top             =   120
   End
   Begin VB.Menu View 
      Caption         =   "Dra&wing"
      Begin VB.Menu MenuDrawCard 
         Caption         =   "Draw&Card"
      End
      Begin VB.Menu MenuDealCard 
         Caption         =   "&DealCard"
      End
      Begin VB.Menu MenuDrawBack 
         Caption         =   "Draw&Back"
      End
      Begin VB.Menu MenuDrawSymbol 
         Caption         =   "Draw&Symbol"
      End
      Begin VB.Menu MenuRemoveCard 
         Caption         =   "&RemoveCard"
      End
      Begin VB.Menu o 
         Caption         =   "-"
      End
      Begin VB.Menu MenuExit 
         Caption         =   "E&xit"
      End
   End
   Begin VB.Menu Information 
      Caption         =   "&Information"
      Begin VB.Menu MenuCardInformation 
         Caption         =   "&CardInformation"
      End
   End
   Begin VB.Menu Dragging 
      Caption         =   "&Dragging"
      Begin VB.Menu MenuDoDrag 
         Caption         =   "D&oDrag"
      End
   End
   Begin VB.Menu MenuHelp 
      Caption         =   "&Help"
      Begin VB.Menu MenuHowTo 
         Caption         =   "Ho&w To..."
      End
      Begin VB.Menu MenuAbout 
         Caption         =   "A&bout"
      End
   End
End
Attribute VB_Name = "Form1"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = False
' This program demonstrates some of the function calls
' of QCard32.DLL. In an effort to keep all code under
' their respective Event Procedures, I have not used
' any Sub procedures of my own. Using a few Sub procedures
' would considerably clean up the "spaghetti" nature of
' some of the dragging events.
' This demo is not complete in that it does not repaint
' it's window properly. I was more interested in demonsrating
' function calls rather than creating a usable product.

' declare a few counters
Dim i As Integer
Dim j As Integer
Dim n As Integer

' declare some test switches
Dim bDragDemo As Integer
Dim bSingleDragging As Integer
Dim bBlockDragging As Integer
Dim bMouseMoved As Integer
Dim nDrawSelection As Integer

' declare some card identifiers
Dim nSourceCard As Integer
Dim nSourceArrayID As Integer
Dim nSourceArrayPos As Integer
Dim nDestCard As Integer
Dim nDestArrayID As Integer
Dim OldX As Integer
Dim OldY As Integer
Dim Temp() As Long
Dim nItems As Integer
Dim nInformationCard

' to save mouse position for double click event
Dim DblClickX As Integer
Dim DblClickY As Integer

' set up a two dimensional array
' four arrays to hold the numbers of the
' cards in each pile
Dim CardArray(1 To 4, 1 To 26) As Integer

' set up a counter to go along with each pile
Dim Counter(1 To 4) As Integer

Private Sub MenuCardInformation_Click()
Form1.Cls
nDrawSelection = 5
Randomize Timer

' pick a random card
i = Int(52 * Rnd + 1)

' pick a random location
'Int((upperbound - lowerbound + 1) * Rnd + lowerbound)
xLoc = Int(((Form1.ScaleWidth - CARDWIDTH) - 150 + 1) * Rnd + 150)
yLoc = Int(((Form1.ScaleHeight - CARDHEIGHT) - 150 + 1) * Rnd + 150)

' set current information card for Paint event
nInformationCard = i

' deal the card
DealCard Form1.hwnd, i, xLoc, yLoc

' draw in the text information
DoText (nInformationCard)

End Sub

Private Sub MenuDealCard_Click()
nDrawSelection = 1
Form1.Cls

' deal cards in a diagonal line
Dim OffsetX As Single
Dim OffsetY As Single
OffsetX = (Form1.ScaleWidth - CARDWIDTH) / 51
OffsetY = (Form1.ScaleHeight - CARDHEIGHT) / 51
SetCurrentBack 6
For i = 1 To 52
    If i Mod 2 = 0 Then
        SetCardStatus i, FACEDOWN
    End If
    DealCard Form1.hwnd, i, (i - 1) * OffsetX, (i - 1) * OffsetY
    SetCardStatus i, FACEUP
Next i
End Sub

Private Sub DoText(i)

Text$ = "Card number is " + Str$(i)
Form1.Print Text$
Text$ = "Card color is " + Str$(GetCardColor(i))
Form1.Print Text$
Text$ = "Card value is " + Str$(GetCardValue(i))
Form1.Print Text$
Text$ = "Card suit is " + Str$(GetCardSuit(i))
Form1.Print Text$
Text$ = "Card x location is " + Str$(GetCardX(i))
Form1.Print Text$
Text$ = "Card y location is " + Str$(GetCardY(i))
Form1.Print Text$
Text$ = "Card Status value is " + Str$(GetCardStatus(i))
Form1.Print Text$
Text$ = "Form ScaleWidth is " + Str$(Form1.ScaleWidth)
Form1.Print Text$
Text$ = "Form ScaleHeight is " + Str$(Form1.ScaleHeight)
Form1.Print Text$

End Sub

Private Sub MenuDrawBack_Click()
nDrawSelection = 3
Form1.Cls

' draw six piles of cards offsetting by 2 pixels up and over
Dim xLoc As Single
xLoc = (Form1.ScaleWidth - (6 * CARDWIDTH)) / 7
For i = 1 To 6
    For j = 1 To 4
        DrawBack Form1.hwnd, i, ((i - 1) * CARDWIDTH) + i * xLoc + ((j - 1) * 2), 50 - ((j - 1) * 2)
    Next j
Next i
End Sub

Private Sub MenuDrawCard_Click()

' draw the cards using DrawCard
' this does not update any of the properties
' of the cards
nDrawSelection = 2
Form1.Cls
Dim nLoc As Integer
Dim nSpacer As Integer

nLoc = (Form1.ScaleHeight - 4 * CARDHEIGHT) / 5
nSpacer = 10

For i = 1 To 52
    DrawCard Form1.hwnd, i, 10 + ((i - 1) * nSpacer), nLoc
Next i

For i = 53 To 104
    DrawCard Form1.hwnd, i, 10 + ((i - 53) * nSpacer), nLoc * 2 + CARDHEIGHT
Next i

For i = 105 To 109
    DrawCard Form1.hwnd, i, 10 + ((i - 105) * nSpacer), nLoc * 3 + CARDHEIGHT * 2
Next i

For i = 110 To 113
    DrawCard Form1.hwnd, i, 10 + ((i - 110) * nSpacer), nLoc * 4 + CARDHEIGHT * 3
Next i

End Sub

Private Sub MenuDrawSymbol_Click()

' draw in one of each of the three symbols
nDrawSelection = 4
Form1.Cls
Dim xLoc As Single

xLoc = (Form1.ScaleWidth - (3 * CARDWIDTH)) / 4

For i = 1 To 3
    DrawSymbol Form1.hwnd, i, (i * xLoc) + ((i - 1) * CARDWIDTH), 50
Next i

End Sub

Private Sub Form_DblClick()
Dim nNewX As Integer
Dim nNewY As Integer
Dim nThisSourceCard As Integer
Dim nThisDestCard As Integer

' Only process DblClick in Drag Demo
If bDragDemo = False Then
    Exit Sub
End If


' You can process double clicks in a similar
' way to the ButtonUp event.
' The current mouse position is saved for us in the
' ButtonDown event as DblClickX and DblClickY
'
' Instead of using the Shared variables nSourceCard
' and nDestCard, we will use two local variables
' nThisSourceCard and nThisDestCard.
' We need to do this because VB processes ButtonDown
' and ButtonUp messages before it actually gets to
' the DblClick event. This will keep our current
' selections from being corrupted by one of the
' other events
'
' We can use the PointInFreeCard function to determine
' if the mouse is within any card that is not blocked

nThisSourceCard = PointInFreeCard(DblClickX, DblClickY)
If nThisSourceCard <> 0 Then
    nSourceArrayID = GetUser4(nThisSourceCard)
    ' pick a destination pile according to original pile
    Select Case nSourceArrayID
        Case 1
            nDestArrayID = 4
        Case 2
            nDestArrayID = 3
        Case 3
            nDestArrayID = 2
        Case 4
            nDestArrayID = 1
    End Select

    nSourceArrayPos = GetUser3(nThisSourceCard)
    nSourceArrayID = GetUser4(nThisSourceCard)
    ' if this is the last card in a row, and not the only card in the row
    ' then move it over to the other "same color row" and adjust arrays and blocks
    If nSourceArrayPos > 1 And nSourceArrayPos = Counter(nSourceArrayID) Then
        nThisDestCard = CardArray(nDestArrayID, Counter(nDestArrayID))
        nNewX = GetCardX(nThisDestCard)
        nNewY = GetCardY(nThisDestCard)
        RemoveCard Form1.hwnd, nThisSourceCard
        DealCard Form1.hwnd, nThisSourceCard, nNewX, nNewY + OFFSET
        Counter(nSourceArrayID) = Counter(nSourceArrayID) - 1
        AdjustCardBlocked CardArray(nSourceArrayID, Counter(nSourceArrayID)), False
        AdjustCardBlocked CardArray(nDestArrayID, Counter(nDestArrayID)), True
        Counter(nDestArrayID) = Counter(nDestArrayID) + 1
        CardArray(nDestArrayID, Counter(nDestArrayID)) = nThisSourceCard
        SetUser3 nThisSourceCard, Counter(nDestArrayID)
        SetUser4 nThisSourceCard, nDestArrayID
    End If
End If

End Sub

Private Sub Form_Load()

' try to fire up the DLL
' a FALSE return value indicates problems
Dim nReturn As Integer
nReturn = InitializeDeck(Form1.hwnd)
If nReturn = False Then
    MsgBox "Problem loading QCards32.DLL"
    End
End If

' set ScaleMode to Pixel(3) so form and DLL use the
' same coordinates
Form1.ScaleMode = 3
Form1.ScaleTop = 0
Form1.ScaleLeft = 0

' make form full screen width
Form1.Width = Screen.Width
Form1.Height = Screen.Height
Form1.Top = 0
Form1.Left = 0

' make some initial assigns
n = 13
bDragDemo = False
bSingleDragging = False
bBlockDragging = False
bMouseMoved = False
nDrawSelection = 0
nInformationCard = 0