Visual Basic.NET 7.x (2002/03)Visual Basic 9 (2008)Visual Basic 8 (2005)Visual Basic 6设计 / 图形Windows XP中级开发Visual StudioWindowsVisual Basic
一个使用 Cards.dll 的空当接龙游戏
3.90/5 (9投票s)
使用 Cards 动态链接库的说明。包含空当接龙游戏。
引言
网上有许多关于如何使用 Cards 动态链接库的好文章，所以我想制作我最喜欢的一个单人纸牌游戏——空当接龙，这会很有趣。
背景
我真的很喜欢空当接龙。1992 年，Marc L. Allen 编写并发布了一款适用于 Windows 的优秀空当接龙游戏。它至今仍可在 32 位 Windows XP 和 Vista 上运行，但它是一个 16 位应用程序，因此无法在 Vista 或 XP 64 位系统上运行。我非常喜欢他使用的界面，所以我决定编写一个他的原始空当接龙游戏的现代版本。
Using the Code
本项目使用 _Cards.dll_ 库来绘制扑克牌。网上有许多关于如何使用 Cards 动态链接库的好文章。如果您不熟悉 Cards 库，我建议您阅读 Matt Pietrek 关于此主题的文章：http://catch22.net/tuts/cards。
_Cards.dll_ 公开了四个函数和一个子程序。它们是：
- `cdtInit`：此函数初始化卡片库，必须首先调用。
Private Declare Function cdtInit Lib "cards.dll" (ByRef width As Integer, _
ByRef height As Integer) As Boolean
此函数接受两个参数：卡的宽度和高度。这些是由调用应用程序提供的整数变量，用于记录 Cards 库使用的卡片宽度和高度的默认值。卡片宽度的默认值为 71 像素，卡片高度为 96 像素。如果您要更改默认大小，这些值很重要，因为应保持 71 比 96 的比例，以免卡片图像失真。但大多数应用程序使用默认值，这在大多数情况下都适用。如果您正在使用卡的默认值且不需要大小，则只需用零代替 `Width` 和 `Height` 变量即可。
Declare Sub cdtTerm Lib "cards.dll" ()
当您的应用程序退出时，或当您完成绘制任何卡片时，请调用此方法。
Declare Function cdtDraw Lib "cards.dll" (ByVal hDC As IntPtr, ByVal x As Integer, _
ByVal y As Integer, ByVal Card As Integer, _
ByVal Type As Integer, ByVal clr As Integer) As Integer
此函数接受以下参数：
- `hDC`：将绘制卡片图像的对象的句柄。
- `X`：卡片图像的 x 轴原点。
- `Y`：卡片图像的 y 轴原点。
- `Card`：卡片值。可以是卡片的面值，也可以是绘制卡片背面时要绘制图案的值。
- `Type`：指定绘制卡片的正面、背面或倒置正面。将此值设置为零以绘制卡片正面，设置为一以绘制卡片背面。
- `Clr`：设置 CrossHatch 卡片背面的背景颜色。所有其他卡片背面和正面都是位图，因此设置此项对任何其他卡片背面都没有影响。除非您正在绘制带有 CrossHatch 图案的卡片背面，否则请将此值保持为零。
Declare Function cdtDrawExt Lib "cards.dll" (ByVal hdc As IntPtr, ByVal x As Integer, _
ByVal y As Integer, ByVal dx As Integer, ByVal dy As Integer, _
ByVal card As Integer, ByVal type As Integer, _
ByVal color As Long) As Boolean
Declare Function cdtAnimate Lib "cards.dll" (ByVal hDC As IntPtr, _
ByVal ecbCardBack As Integer, ByVal x As Integer, _
ByVal y As Integer, ByVal iState As Integer) As Integer
牌值基于标准的 52 张牌组，不包含大小王。牌值来源于其花色和面值。
确定牌值的公式是：面值 * 4 + 花色值，或 4F + 花色。
面值和花色值枚举如下：
Public Enum Suit As Byte
CLUBS = 0
DIAMONDS = 1
HEARTS = 2
SPADES = 3
End Enum
Public Enum Face As Byte
Ace = 0
Two = 1
Three = 2
Four = 3
Five = 4
Six = 5
Seven = 6
Eight = 7
Nine = 8
Ten = 9
Jack = 10
Queen = 11
King = 12
End Enum
使用 4F + 花色 = 牌值的示例
- 黑桃 A 的牌值是 4 * 0 + 3 = 3。
- 梅花 8 的牌值是 4 * 7 + 0 = 28。
以下是所有卡片值
' Card values:
Ace| 2 | 3 | 4 | 5 | 6 | 7 | 8 | 9 | 10 |Jack|Queen|King
' CLUBS: 0 4 8 12 16 20 24 28 32 36 40 44 48
' DIAMONDS: 1 5 9 13 17 21 25 29 33 37 41 45 49
' HEARTS: 2 6 10 14 18 22 26 30 34 38 42 46 50
' SPADES: 3 7 11 15 19 23 27 31 35 39 43 47 51
在我的卡片类中，卡片用其卡片值初始化，并且此值在卡片的生命周期内永不改变。这使得绘制卡片正面变得非常容易。
Public Class Card : Inherits Control
Public CardValue As Byte
Public OldPoint As Point
Sub New(ByVal cardvalue As Byte)
Me.Size = New Size(CardWidth, CardHeight)
Me.CardValue = cardvalue
End Sub
Private Sub PaintCard(ByVal sender As Object, ByVal e As PaintEventArgs) _
Handles Me.Paint
cdtDraw(e.Graphics.GetHdc, 0, 0, DirectCast(sender, Card).CardValue, 0, 0)
End Sub
End Class
Cards 库没有任何对卡片进行排序或比较的方法。您必须根据纸牌游戏编写自己的方法。下面显示的方法适用于空当接龙
' Method for returning face value based on raw card value.
' The formula for card value is (card = face * 4 + Suit)
Private Function CardFaceValue(ByVal CardValue As Byte, ByVal suite As Suit) As Face
Return CType((CardValue - suite) / 4, Face)
End Function
Public ReadOnly Property FaceValue(ByVal CardValue As Byte) As Face
Get
Return CType(CardFaceValue(CardValue, SuitValue(CardValue)), Face)
End Get
End Property
' This property returns the "raw" Card Value for next higher card
' in sequence in the same suit. If card is a king, the ace in
' same suit is returned. If card is an ace, the two in same suit
' is returned.
Public ReadOnly Property NextFaceValue(ByVal CardValue As Byte) As Byte
Get
' Determine face and suit for current card value.
Dim f As Face = FaceValue(CardValue)
Dim s As Suit = SuitValue(CardValue)
If f < Face.King Then
' return next higher card value by adding 1 to face value.
Return CByte(s + (f + 1) * 4)
Else
' return ace in same suit as the next logical higher
' card than the king.
Return CByte(s + Face.Ace * 4)
End If
End Get
End Property
' This property returns the "raw" Card Value for the next lower card
' in sequence in the same suit. If card is an ace, then the King card
' will be returned. If card is a 2, the ace is returned.
Public ReadOnly Property PrevCardValue(ByVal CardValue As Byte) As Byte
Get
' Determine face and suit for current card value.
Dim f As Face = FaceValue(CardValue)
Dim s As Suit = SuitValue(CardValue)
' return next lower card value in same suit by subtracting 1 from face value.
' If the math is done right, it should properly convert to byte value.
If CardValue > 3 Then
Return CByte(s + (f - 1) * 4)
Else
' Current card is an ace, so return the king in same suit.
Return CByte(s + Face.King * 4)
End If
End Get
End Property
' Returns the opposite color for CardValue argument.
Public ReadOnly Property OppositeSuit(ByVal CardValue As Byte) As SuitColor
Get
Select Case SuitValue(CardValue)
Case Suit.CLUBS, Suit.SPADES
' Return opposite color.
Return SuitColor.Red
Case Suit.DIAMONDS, Suit.HEARTS
' Return opposite color.
Return SuitColor.Black
End Select
End Get
End Property
' Returns two bytes that equal the card values for next 2 lower
' cards in opposite suit, like in FreeCell, when sorting cards
' in columns.
Public Function PrevOppositeSuite(ByVal CardValue As Byte) As Byte()
Dim s As Suit = SuitValue(CardValue)
Dim OppCards(1) As Byte
Dim f As Face = Me.CardFaceValue(CardValue, s)
If f = Face.Ace Then
' Set to King.
f = Face.King
Else
' Set to next lower face value.
f = CType(f - 1, Face)
End If
Select Case s
Case Suit.CLUBS, Suit.SPADES
OppCards(0) = CByte(f * 4 + Suit.DIAMONDS)
OppCards(1) = CByte(f * 4 + Suit.HEARTS)
Case Suit.DIAMONDS, Suit.HEARTS
OppCards(0) = CByte(f * 4 + Suit.SPADES)
OppCards(1) = CByte(f * 4 + Suit.CLUBS)
End Select
Return OppCards
End Function
' Returns two bytes that equal the card values for next 2 higer
' cards in opposite suit, like in FreeCell, when sorting cards
' in columns.
Public Function NextOppositeSuite(ByVal CardValue As Byte) As Byte()
Dim s As Suit = SuitValue(CardValue)
Dim OppCards(1) As Byte
Dim f As Face = Me.CardFaceValue(CardValue, s)
If f = Face.King Then
' Set to Ace.
f = Face.Ace
Else
' Set to next higher face value.
f = CType(f + 1, Face)
End If
Select Case s
Case Suit.CLUBS, Suit.SPADES
OppCards(0) = CByte(f * 4 + Suit.DIAMONDS)
OppCards(1) = CByte(f * 4 + Suit.HEARTS)
Case Suit.DIAMONDS, Suit.HEARTS
OppCards(0) = CByte(f * 4 + Suit.SPADES)
OppCards(1) = CByte(f * 4 + Suit.CLUBS)
End Select
Return OppCards
End Function
' method for returning suit value.
Public Function SuitValue(ByVal CardValue As Byte) As Suit
Select Case CardValue
Case 0, 4, 8, 12, 16, 20, 24, 28, 32, 36, 40, 44, 48
Return Suit.CLUBS
Case 1, 5, 9, 13, 17, 21, 25, 29, 33, 37, 41, 45, 49
Return Suit.DIAMONDS
Case 2, 6, 10, 14, 18, 22, 26, 30, 34, 38, 42, 46, 50
Return Suit.HEARTS
Case Else
Return Suit.SPADES
End Select
End Function
空当接龙游戏使用 `MouseDown`、`MouseMove` 和 `MouseUp` 事件来移动纸牌。我还使用双击功能，当纸牌可以清除到 A 牌区时。
检测鼠标按下、鼠标抬起以及双击的一个问题是，当用户双击时，您必须能够忽略鼠标按下和鼠标抬起事件。我的做法是，我创建了一个布尔变量 `doubleclick`，在鼠标按下事件中将其设置为 true，在鼠标移动过程中将其设置为 false。在我的鼠标抬起事件中，如果 `doubleclick` 为 true，代码将退出。这样，当用户双击但卡片没有移动时，鼠标抬起中的代码会忽略该调用。
Sub Card_MouseDown(ByVal sender As Object, ByVal e As MouseEventArgs)
If e.Clicks = 1 AndAlso e.Button = Windows.Forms.MouseButtons.Left Then
' MouseMove will fire first time user clicks card.
' Only fire mouse move if mouse location changes.
OldMousept = e.Location
' double-click flag is always set to true.
' It is set false if card is moved.
' This is so mouseUp event only
' fires if card was moved.
DblClick = True
Dim c As Card = DirectCast(sender, Card)
c.BringToFront()
Xpos = Control.MousePosition.X - c.Left
Ypos = Control.MousePosition.Y - c.Top
End If
End Sub
Sub Card_MouseMove(ByVal sender As Object, ByVal e As MouseEventArgs)
If e.Clicks = 0 AndAlso e.Button = Windows.Forms.MouseButtons.Left AndAlso _
e.Location <> OldMousept Then
DblClick = False
DirectCast(sender, Card).Location = _
New Point(Control.MousePosition.X - Xpos, _
Control.MousePosition.Y - Ypos)
End If
End Sub
Sub Card_MouseUp(ByVal sender As Object, _
ByVal e As System.Windows.Forms.MouseEventArgs)
' The DblClick flag is always set to true at mouse-down event,
' to prevent this sub from firing when the user is double-clicking
' the card. If not double-clicking, then when the card is moved
' the mouse move event of the card resets DblClick to
' false. If we remove the DblClick flag, this sub will fire
' multiple times when the user double-clicks the card.
If Not DblClick AndAlso e.Button = Windows.Forms.MouseButtons.Left Then
Dim c As Card = DirectCast(sender, Card)
Dim idx As Integer
' Determine if card is being dropped over another card,
' and if it is, try to dock the card.
' First the Location.X/Left position is checked against
' possible Left-Right docking ranges. If a match is
' found then the Location.Y/Top position is checked against
' possible Top-Bottom docking ranges. There are only 16
' possible docking areas: 8 columns, 4 free cells, and 4
' Ace Docking areas.
' For the 8 columns, the location of the top card in the
' column is used. If the column card count is zero, then
' the Row(0) location is used.
' The numbers were determined using card locations and card
' sizes. In most cases, only 40 % of the destination card
' needs to be covered for dragged card to be dropped there.
Select Case c.Left
Case 77 To 150 ' Aces
Select Case c.Top
' Determine if card is partly covering one of the Aces spots.
Case 138 To 238 ' 0 Ace of Clubs.
TryDockAce(c, 0, True)
Case 247 To 347 ' 1 Ace of Diamonds.
TryDockAce(c, 1, True)
Case 356 To 456 ' 2 Ace of Hearts.
TryDockAce(c, 2, True)
Case 469 To 565 ' 3 Ace of spades.
TryDockAce(c, 3, True)
Case Else
' Card not playable at location it was dropped to.
' Move card back to old position.
c.Location = c.OldPoint
End Select
' Values for rows and column positions:
' Rows (Y Pos) {135, 160, 185, 210, 235, 260, 285}
' Columns (X Pos) {195, 278, 361, 444, 527, 610, 693, 776}
Case 157 To 233 ' Column 0
idx = Columns(0).Count - 1
Select Case True
Case idx > -1
' First verify that this is not the same top card in
' the column. If it is, return it to its old location.
If Columns(0)(idx) Is c Then
c.Location = c.OldPoint
' Check if Top of card is being dropped
' in range of column 0's Y position. All Cards
' should auto-dock/auto-drop when released, if
' 40-50% covering area of the destination card.
ElseIf c.Top >= Columns(0)(idx).Top - 50 AndAlso _
c.Top <= Columns(0)(idx).Top + 70 Then
TryMoveToColumn(c, idx, 0, False)
Else
' Card not playable at location it was dropped to.
c.Location = c.OldPoint
End If
' If column has no cards in it, check if card is being
' dropped over row zero in the empty column.
Case c.Top >= Rows(0) - 50 AndAlso c.Top <= Rows(0) + 70
' Move the card into the empty row and handle where
' the card came from.
MoveToEmptyCol(c, 0, False)
Case Else
' Card not playable at location it was dropped to.
c.Location = c.OldPoint
End Select
Case 240 To 316 ' Column 1
idx = Columns(1).Count - 1
Select Case True
Case idx > -1
If Columns(1)(idx) Is c Then
c.Location = c.OldPoint
ElseIf c.Top >= Columns(1)(idx).Top - 50 AndAlso _
c.Top <= Columns(1)(idx).Top + 70 Then
TryMoveToColumn(c, idx, 1, False)
Else
c.Location = c.OldPoint
End If
Case c.Top >= Rows(0) - 50 AndAlso c.Top <= Rows(0) + 70
MoveToEmptyCol(c, 1, False)
Case Else
c.Location = c.OldPoint
End Select
Case 323 To 399 'Either Column 2 or FreeCell 0.
Select Case True
Case c.Top >= 570 AndAlso c.Top <= 681
' Card is over Free Cell 0.
' Try to dock to Free Cell 0.
TryDockFC(c, 0)
Case Columns(2).Count > 0
idx = Columns(2).Count - 1
If Columns(2)(idx) Is c Then
c.Location = c.OldPoint
ElseIf c.Top >= Columns(2)(idx).Top - 50 AndAlso _
c.Top <= Columns(2)(idx).Top + 70 Then
TryMoveToColumn(c, idx, 2, False)
Else
c.Location = c.OldPoint
End If
Case c.Top >= Rows(0) - 50 AndAlso c.Top <= Rows(0) + 70
' Card over first row in empty column.
MoveToEmptyCol(c, 2, False)
Case Else
c.Location = c.OldPoint
End Select
Case 406 To 482 ' Either Column 3 or FreeCell 1.
Select Case True
Case c.Top >= 570 AndAlso c.Top <= 681
' Card is over Free Cell 1.
' Try to dock to Free Cell 1.
TryDockFC(c, 1)
Case Columns(3).Count > 0
idx = Columns(3).Count - 1
If Columns(3)(idx) Is c Then
c.Location = c.OldPoint
ElseIf c.Top >= Columns(3)(idx).Top - 50 AndAlso _
c.Top <= Columns(3)(idx).Top + 70 Then
TryMoveToColumn(c, idx, 3, False)
Else
c.Location = c.OldPoint
End If
Case c.Top >= Rows(0) - 50 AndAlso c.Top <= Rows(0) + 70
' Card over first row in empty column.
MoveToEmptyCol(c, 3, False)
Case Else
c.Location = c.OldPoint
End Select
Case 489 To 565 ' Either Column 4 or FreeCell 2.
Select Case True
Case c.Top >= 570 AndAlso c.Top <= 681
' Card is over Free Cell 2.
' Try to dock to Free Cell 2.
TryDockFC(c, 2)
Case Columns(4).Count > 0
idx = Columns(4).Count - 1
If Columns(4)(idx) Is c Then
c.Location = c.OldPoint
ElseIf c.Top >= Columns(4)(idx).Top - 50 AndAlso _
c.Top <= Columns(4)(idx).Top + 70 Then
TryMoveToColumn(c, idx, 4, False)
Else
c.Location = c.OldPoint
End If
Case c.Top >= Rows(0) - 50 AndAlso c.Top <= Rows(0) + 70
' Card over first row in empty column.
MoveToEmptyCol(c, 4, False)
Case Else
c.Location = c.OldPoint
End Select
Case 572 To 648 ' Either Column 5 or FreeCell 3.
Select Case True
Case c.Top >= 570 AndAlso c.Top <= 681
' Card is over Free Cell 3.
' Try to dock to Free Cell 3.
TryDockFC(c, 3)
Case Columns(5).Count > 0
idx = Columns(5).Count - 1
If Columns(5)(idx) Is c Then
c.Location = c.OldPoint
ElseIf c.Top >= Columns(5)(idx).Top - 50 AndAlso _
c.Top <= Columns(5)(idx).Top + 70 Then
TryMoveToColumn(c, idx, 5, False)
Else
c.Location = c.OldPoint
End If
Case c.Top >= Rows(0) - 50 AndAlso c.Top <= Rows(0) + 70
' Card over first row in empty column.
MoveToEmptyCol(c, 5, False)
Case Else
c.Location = c.OldPoint
End Select
Case 649 To 731 ' Column 6
idx = Columns(6).Count - 1
Select Case True
Case idx > -1
If Columns(6)(idx) Is c Then
c.Location = c.OldPoint
ElseIf c.Top >= Columns(6)(idx).Top - 50 AndAlso _
c.Top <= Columns(6)(idx).Top + 70 Then
TryMoveToColumn(c, idx, 6, False)
Else
c.Location = c.OldPoint
End If
Case c.Top >= Rows(0) - 50 AndAlso c.Top <= Rows(0) + 70
Me.MoveToEmptyCol(c, 6, False)
Case Else
c.Location = c.OldPoint
End Select
Case 732 To 814 ' Column 7
idx = Columns(7).Count - 1
Select Case True
Case idx > -1
If Columns(7)(idx) Is c Then
c.Location = c.OldPoint
ElseIf c.Top >= Columns(7)(idx).Top - 50 AndAlso _
c.Top <= Columns(7)(idx).Top + 70 Then
TryMoveToColumn(c, idx, 7, False)
Else
c.Location = c.OldPoint
End If
Case c.Top >= Rows(0) - 50 AndAlso c.Top <= Rows(0) + 70
Me.MoveToEmptyCol(c, 7, False)
Case Else
c.Location = c.OldPoint
End Select
Case Else
' Card not playable at location it was dropped to.
' Move card back to old position.
c.Location = c.OldPoint
End Select
End If
End Sub
一旦所有牌都被清除到 A 牌区，在空当接龙中，游戏就赢了。在这个游戏中，一个线程会重新初始化牌并将其散开，使用线程安全的调用方法来移动每张牌。牌以随机距离散开。有时它们散开的距离刚好足以看到每张牌。有时它们散开的距离很远，如下图所示
大多数空当接龙游戏都有保存的游戏或保存的牌组，可以被选择和玩。Microsoft Windows XP 上的空当接龙有 100,000 个可供选择的游戏。我决定将 100,000 个游戏存储在一个嵌入式二进制文件中以供选择游戏。对于空当接龙来说，最简单的方法是按特定顺序存储 52 字节的模式，以便在游戏中发牌。字节之间没有填充，我的 100,000 个游戏占用了超过 5 MB 的空间，这就是为什么我的应用程序超过 5 MB。我尝试压缩文件，但仍然超过 3 MB。Microsoft 成功地存储了相同的 100,000 个游戏，他们的空当接龙应用程序只有 55 KB。如果有人知道他们是如何做到的，我想知道。
更新：感谢 MojoFlys 指出，在新游戏获取牌组时，无需加载一组字节，只需将选定的游戏编号作为随机类实例的种子，然后以此方式生成牌即可。这样，您就可以根据选定的游戏编号进行特定的发牌，而无需存储任何东西。
我修改了项目，以下是用户选择游戏的新方法。`GameIndex` 是选定的游戏，一个介于 1 和 100,000 之间的 Integer。比存储 100,000 个游戏容易得多！
Dim r As New Random(GameIndex)
Dim Cards(51) As Byte
Dim st As New Generic.Stack(Of Byte)
Do
For b As Byte = 0 To 51
b = CType(r.Next(0, 52), Byte)
If Not st.Contains(b) Then
st.Push(b)
End If
Next b
Loop Until st.Count = 52
已更新：我在记录哪些牌已排序并可以作为一列移动的代码中发现了一个错误。它位于 `SetSorted` 子例程中。以下是更新后的代码。项目下载和可执行文件下载都已更新。请注意，在旧的子例程中，在 For Next 循环中，如果下一个相反的牌不匹配，则缺少 Else 语句，并且它不会退出子例程。相反，它会继续循环，因此您可以在同一列中拥有两组已排序的牌，并且移动事件会添加到不应移动的牌中。
Sub SetSorted(ByVal Col As Byte)
Dim idx As Integer
' Remove sorted card events from all
' of the cards in the column.
For idx = 0 To Columns(Col).Count - 1
RemoveSortedEvents(Columns(Col)(idx))
Next idx
idx = Columns(Col).Count - 1
' For there to be a moveable group of cards, there must
' be at least 2 cards/count must be at least 2.
If idx > 0 Then
Dim Cards As Byte()
For i As Integer = idx To 1 Step -1
Cards = pc.NextOppositeSuite(Columns(Col)(i).CardValue)
If Cards(0) = Columns(Col)(i - 1).CardValue OrElse _
Cards(1) = Columns(Col)(i - 1).CardValue Then
AddSortedEvents(Columns(Col)(i - 1))
Else
Exit Sub
End If
Next i
End If
End Sub
这个项目编写起来真的很有趣，它是那种让你爱不释手的有趣项目之一。我开始在一个周末编写它，一个周末的趣味编程变成了三个周末:)
请注意，要在 Windows Vista 中运行此应用程序，您需要将 _Cards.dll_ 复制到与 exe 文件相同的文件夹中，或者您也可以运行 RegSvr32 并在 Vista 中注册 _cards.dll_。
免费软件：请随意使用或修改此项目中的任何代码，但请勿将其用于任何商业产品。
免责声明：对于使用本文中发布的任何代码可能导致的任何计算机设备损坏或任何数据丢失，我概不负责。使用此代码的风险自负。