VERSION 5.00 Object = "{27395F88-0C0C-101B-A3C9-08002B2F49FB}#1.1#0"; "PICCLP32.OCX" Begin VB.Form Form1 BorderStyle = 1 'Fixed Single Caption = "Black Jack" ClientHeight = 5670 ClientLeft = 6015 ClientTop = 4170 ClientWidth = 7950 BeginProperty Font Name = "MS Sans Serif" Size = 8.25 Charset = 0 Weight = 700 Underline = 0 'False Italic = 0 'False Strikethrough = 0 'False EndProperty Icon = "Form1.frx":0000 LinkTopic = "Form1" MaxButton = 0 'False ScaleHeight = 5670 ScaleWidth = 7950 Begin VB.CommandButton cmdPlay Cancel = -1 'True Caption = "&Stand" Enabled = 0 'False BeginProperty Font Name = "MS Sans Serif" Size = 8.25 Charset = 0 Weight = 400 Underline = 0 'False Italic = 0 'False Strikethrough = 0 'False EndProperty Height = 1335 Index = 1 Left = 7080 TabIndex = 2 Top = 4200 Width = 735 End Begin VB.CommandButton cmdDeal Caption = "D&eal" BeginProperty Font Name = "MS Sans Serif" Size = 8.25 Charset = 0 Weight = 400 Underline = 0 'False Italic = 0 'False Strikethrough = 0 'False EndProperty Height = 375 Left = 6480 TabIndex = 25 Top = 1920 Width = 855 End Begin VB.Frame frmOptions Caption = "Playing Options" Height = 2175 Left = 6120 TabIndex = 21 Top = 240 Width = 1695 Begin VB.ComboBox cboSpeed Height = 315 ItemData = "Form1.frx":B3AA Left = 240 List = "Form1.frx":B3B7 TabIndex = 24 Text = "Speed" Top = 840 Width = 1095 End Begin VB.ComboBox cboDecks Height = 315 ItemData = "Form1.frx":B3CF Left = 240 List = "Form1.frx":B3EB TabIndex = 22 Text = "Decks" Top = 360 Width = 1095 End Begin VB.Label Label4 Alignment = 2 'Center Caption = "Stand on Soft 17" BeginProperty Font Name = "MS Sans Serif" Size = 8.25 Charset = 0 Weight = 400 Underline = 0 'False Italic = 0 'False Strikethrough = 0 'False EndProperty Height = 255 Left = 120 TabIndex = 23 Top = 1320 Width = 1335 End End Begin VB.TextBox txtWager BeginProperty Font Name = "MS Sans Serif" Size = 8.25 Charset = 0 Weight = 400 Underline = 0 'False Italic = 0 'False Strikethrough = 0 'False EndProperty Height = 285 Left = 2640 TabIndex = 9 Text = "2" Top = 5280 Width = 735 End Begin PicClip.PictureClip pctCards Left = 7800 Top = 5400 _ExtentX = 27173 _ExtentY = 16272 _Version = 393216 Rows = 5 Cols = 13 Picture = "Form1.frx":B407 End Begin VB.CommandButton cmdBet Caption = "&Bet" Enabled = 0 'False BeginProperty Font Name = "MS Sans Serif" Size = 8.25 Charset = 0 Weight = 400 Underline = 0 'False Italic = 0 'False Strikethrough = 0 'False EndProperty Height = 375 Left = 3600 TabIndex = 10 Top = 5160 Width = 855 End Begin VB.CheckBox chkSuggPlay Caption = "Suggested Play" BeginProperty Font Name = "MS Sans Serif" Size = 8.25 Charset = 0 Weight = 400 Underline = 0 'False Italic = 0 'False Strikethrough = 0 'False EndProperty Height = 255 Left = 6360 TabIndex = 7 Top = 3360 Value = 1 'Checked Width = 1455 End Begin VB.CheckBox chkCardCount Caption = "Card Count" BeginProperty Font Name = "MS Sans Serif" Size = 8.25 Charset = 0 Weight = 400 Underline = 0 'False Italic = 0 'False Strikethrough = 0 'False EndProperty Height = 255 Left = 6360 TabIndex = 8 Top = 3720 Width = 1455 End Begin VB.CheckBox chkDeckCount Caption = "Deck Count" BeginProperty Font Name = "MS Sans Serif" Size = 8.25 Charset = 0 Weight = 400 Underline = 0 'False Italic = 0 'False Strikethrough = 0 'False EndProperty Height = 255 Left = 6360 TabIndex = 6 Top = 2640 Value = 1 'Checked Width = 1455 End Begin VB.CommandButton cmdPlay Caption = "S&plit" Enabled = 0 'False BeginProperty Font Name = "MS Sans Serif" Size = 8.25 Charset = 0 Weight = 400 Underline = 0 'False Italic = 0 'False Strikethrough = 0 'False EndProperty Height = 375 Index = 3 Left = 6000 TabIndex = 4 Top = 4680 Width = 855 End Begin VB.CommandButton cmdPlay Caption = "&Hit" Default = -1 'True Enabled = 0 'False BeginProperty Font Name = "MS Sans Serif" Size = 8.25 Charset = 0 Weight = 400 Underline = 0 'False Italic = 0 'False Strikethrough = 0 'False EndProperty Height = 1335 Index = 0 Left = 5040 TabIndex = 1 Top = 4200 Width = 735 End Begin VB.CommandButton cmdPlay Caption = "&Double" Enabled = 0 'False BeginProperty Font Name = "MS Sans Serif" Size = 8.25 Charset = 0 Weight = 400 Underline = 0 'False Italic = 0 'False Strikethrough = 0 'False EndProperty Height = 375 Index = 2 Left = 6000 TabIndex = 3 Top = 4200 Width = 855 End Begin VB.CommandButton cmdPlay Caption = "Su&rrender" Enabled = 0 'False BeginProperty Font Name = "MS Sans Serif" Size = 8.25 Charset = 0 Weight = 400 Underline = 0 'False Italic = 0 'False Strikethrough = 0 'False EndProperty Height = 375 Index = 4 Left = 6000 TabIndex = 5 Top = 5160 Width = 855 End Begin VB.Label Label6 Caption = "Cards Left in Deck:" BeginProperty Font Name = "MS Sans Serif" Size = 8.25 Charset = 0 Weight = 400 Underline = 0 'False Italic = 0 'False Strikethrough = 0 'False EndProperty Height = 375 Left = 4440 TabIndex = 29 Top = 240 Width = 735 End Begin VB.Label lblCardsLeft Caption = "0" BeginProperty Font Name = "MS Sans Serif" Size = 8.25 Charset = 0 Weight = 400 Underline = 0 'False Italic = 0 'False Strikethrough = 0 'False EndProperty Height = 255 Left = 5280 TabIndex = 28 Top = 360 Visible = 0 'False Width = 375 End Begin VB.Label lblRunningCount Caption = "True Count" BeginProperty Font Name = "MS Sans Serif" Size = 8.25 Charset = 0 Weight = 400 Underline = 0 'False Italic = 0 'False Strikethrough = 0 'False EndProperty Height = 255 Left = 6720 TabIndex = 27 Top = 3000 Width = 975 End Begin VB.Label RunningCount Alignment = 1 'Right Justify Caption = "0" BeginProperty Font Name = "MS Sans Serif" Size = 8.25 Charset = 0 Weight = 400 Underline = 0 'False Italic = 0 'False Strikethrough = 0 'False EndProperty Height = 255 Left = 5640 TabIndex = 26 Top = 2640 Width = 495 End Begin VB.Label lblHandResult Alignment = 2 'Center BackColor = &H00000000& Caption = "BlackJack" BeginProperty Font Name = "MS Sans Serif" Size = 9.75 Charset = 0 Weight = 700 Underline = -1 'True Italic = 0 'False Strikethrough = 0 'False EndProperty ForeColor = &H000000FF& Height = 315 Index = 0 Left = 240 TabIndex = 20 Top = 3480 Visible = 0 'False Width = 1155 End Begin VB.Label lblHandResult Alignment = 2 'Center BackColor = &H00000000& Caption = "BlackJack" BeginProperty Font Name = "MS Sans Serif" Size = 9.75 Charset = 0 Weight = 700 Underline = -1 'True Italic = 0 'False Strikethrough = 0 'False EndProperty ForeColor = &H000000FF& Height = 315 Index = 1 Left = 240 TabIndex = 19 Top = 840 Visible = 0 'False Width = 1140 End Begin VB.Image imgPlayer Height = 1440 Index = 6 Left = 3120 Top = 3000 Width = 495 End Begin VB.Image imgPlayer Height = 1440 Index = 5 Left = 2640 Top = 3000 Width = 495 End Begin VB.Image imgPlayer Height = 1440 Index = 4 Left = 2160 Top = 3000 Width = 495 End Begin VB.Image imgPlayer Height = 1440 Index = 3 Left = 1680 Top = 3000 Width = 495 End Begin VB.Image imgPlayer Height = 1440 Index = 2 Left = 1200 Top = 3000 Width = 495 End Begin VB.Image imgPlayer Height = 1440 Index = 1 Left = 720 Top = 3000 Width = 495 End Begin VB.Image imgDealer Height = 1440 Index = 6 Left = 3120 Top = 360 Width = 495 End Begin VB.Image imgDealer Height = 1440 Index = 5 Left = 2640 Top = 360 Width = 495 End Begin VB.Image imgDealer Height = 1440 Index = 4 Left = 2160 Top = 360 Width = 495 End Begin VB.Image imgDealer Height = 1440 Index = 3 Left = 1680 Top = 360 Width = 495 End Begin VB.Image imgDealer Height = 1455 Index = 2 Left = 1200 Top = 360 Width = 495 End Begin VB.Image imgDealer Height = 1455 Index = 1 Left = 720 Top = 360 Width = 495 End Begin VB.Image imgDealer Height = 1455 Index = 0 Left = 240 Top = 360 Width = 495 End Begin VB.Label lblBank BeginProperty Font Name = "MS Sans Serif" Size = 8.25 Charset = 0 Weight = 400 Underline = 0 'False Italic = 0 'False Strikethrough = 0 'False EndProperty Height = 255 Left = 960 TabIndex = 18 Top = 5280 Width = 615 End Begin VB.Label Label3 Caption = "Bank:" BeginProperty Font Name = "MS Sans Serif" Size = 8.25 Charset = 0 Weight = 400 Underline = 0 'False Italic = 0 'False Strikethrough = 0 'False EndProperty Height = 255 Left = 240 TabIndex = 17 Top = 5280 Width = 495 End Begin VB.Label Label2 Caption = "Wager:" BeginProperty Font Name = "MS Sans Serif" Size = 8.25 Charset = 0 Weight = 400 Underline = 0 'False Italic = 0 'False Strikethrough = 0 'False EndProperty Height = 255 Left = 2640 TabIndex = 16 Top = 4920 Width = 615 End Begin VB.Label lblSuggPlay Alignment = 1 'Right Justify BeginProperty Font Name = "MS Sans Serif" Size = 8.25 Charset = 0 Weight = 400 Underline = 0 'False Italic = 0 'False Strikethrough = 0 'False EndProperty Height = 255 Left = 5640 TabIndex = 15 Top = 3360 Width = 495 End Begin VB.Label lblDeckCount Alignment = 1 'Right Justify Caption = "0" BeginProperty Font Name = "MS Sans Serif" Size = 8.25 Charset = 0 Weight = 400 Underline = 0 'False Italic = 0 'False Strikethrough = 0 'False EndProperty Height = 255 Left = 5640 TabIndex = 14 Top = 3000 Width = 495 End Begin VB.Label lblCount Caption = "0" BeginProperty Font Name = "MS Sans Serif" Size = 8.25 Charset = 0 Weight = 400 Underline = 0 'False Italic = 0 'False Strikethrough = 0 'False EndProperty Height = 255 Index = 1 Left = 960 TabIndex = 13 Top = 120 Visible = 0 'False Width = 255 End Begin VB.Label lblCount Caption = "0" BeginProperty Font Name = "MS Sans Serif" Size = 8.25 Charset = 0 Weight = 400 Underline = 0 'False Italic = 0 'False Strikethrough = 0 'False EndProperty Height = 255 Index = 0 Left = 960 TabIndex = 12 Top = 4920 Visible = 0 'False Width = 255 End Begin VB.Label Label5 Caption = "Player" BeginProperty Font Name = "MS Sans Serif" Size = 8.25 Charset = 0 Weight = 400 Underline = 0 'False Italic = 0 'False Strikethrough = 0 'False EndProperty Height = 255 Left = 240 TabIndex = 11 Top = 4920 Width = 495 End Begin VB.Label Label1 Caption = "Dealer" BeginProperty Font Name = "MS Sans Serif" Size = 8.25 Charset = 0 Weight = 400 Underline = 0 'False Italic = 0 'False Strikethrough = 0 'False EndProperty Height = 255 Left = 240 TabIndex = 0 Top = 120 Width = 495 End Begin VB.Image imgPlayer Height = 1440 Index = 0 Left = 240 Top = 3000 Width = 495 End End Attribute VB_Name = "Form1" Attribute VB_GlobalNameSpace = False Attribute VB_Creatable = False Attribute VB_PredeclaredId = True Attribute VB_Exposed = False Dim DealerAces As Byte '//records the number of aces worth 11 in the Dealer's hand Dim DealtHand As Byte '//records which hand is currently being dealt to the Player Dim Decks As Byte '//Decks holds the number of decks currently being played Dim DeckRand() As Integer '//DeckRand is an array of the random deck's card numbers and values Dim DownCard(1) As Byte '//Downcard is used as a holder for the Dealer's down card (cardnumber, cardvalue) Private Type Hand '//Hand holds the following values for the Player's hands CardNumber(6) As Byte CardValue(6) As Byte HandCount As Integer Aces As Byte '//records the number of aces worth 11 in the player's hand Cardposition As Byte '//records the cardposition to be dealt for this hand End Type Dim OrigWager As Currency '//OrigWager holds the original wager of the player -- the wager text box will show changes in the current wager (double, etc) Dim PlayerHands(1) As Hand '//the Player can have (2) hands from splitting Dim Pointer As Integer '//Pointer is used to determine the current(next) card in the Random Deck Dim RC As Integer '//holds the deck's running count Dim SecondCard As Integer '//This variable holds information about the second card dealt to the Player -- used for splitting*** Dim sngBank As Single '//sngBank is used to store the amount of money in the bank into the excel spreadsheet as the program is being closed Dim Speed As Byte '//Speed holds the speed at which the Player is playing Dim Split As Byte '//Split records the number of times the Player has split Dim Xcel As Excel.Application '//Xcel is used to open the excel spreadsheet Option Explicit Private Sub Bust() Dim NoBust As Byte Dim k As Byte NoBust = 0 lblHandResult(0).Left = imgPlayer(PlayerHands(0).Cardposition - 1).Left lblHandResult(0).Top = 3480 - 500 * DealtHand lblHandResult(0).Caption = "Bust" lblHandResult(0).Visible = True If DealtHand > 0 Then '//the Player has another hand to play DealtHand = DealtHand - 1 PlayerHands(DealtHand).Cardposition = 1 Call IncrDeck(0, PlayerHands(DealtHand).Cardposition) Exit Sub End If For k = 0 To Split If PlayerHands(k).HandCount <= 21 Then '//there is a hand that has not busted NoBust = NoBust + 1 End If Next k If NoBust > 0 Then Call DealerPlay Else Call DealerShowCard Call Pause(0.25 * Speed) Call ClearTable End If End Sub Private Sub chkCardCount_Click() If chkCardCount.Value = 1 Then lblCount(0).Visible = True lblCount(1).Visible = True lblCardsLeft.Visible = True Else lblCount(0).Visible = False '//turn off the Player's Card Counter lblCount(1).Visible = False '//turn off the Dealer's Card Counter lblCardsLeft.Visible = False End If End Sub Private Sub chkDeckCount_Click() If chkDeckCount = 1 Then lblDeckCount.Visible = True RunningCount.Visible = True lblRunningCount.Visible = True Else lblDeckCount.Visible = False RunningCount.Visible = False lblRunningCount.Visible = False End If End Sub Private Sub chkSuggPlay_Click() If chkSuggPlay = 1 Then lblSuggPlay.Visible = True Else lblSuggPlay.Visible = False End If End Sub Public Sub ClearTable() Dim k As Byte For k = 0 To 6 imgDealer(k).Picture = LoadPicture("") imgPlayer(k).Picture = LoadPicture("") Next k lblCount(0).Caption = 0 lblCount(1).Caption = 0 lblHandResult(0).Visible = False lblHandResult(1).Visible = False lblSuggPlay.Caption = "" txtWager.Text = OrigWager txtWager.Enabled = True cmdBet.Enabled = True cmdBet.Default = True cboSpeed.Enabled = True For k = 0 To 4 cmdPlay(k).Enabled = False Next k If Split > 0 Then '//the Player has split and the extra image box need to be deleted For k = 0 To 6 Unload imgPlayer(CByte(7 + k * Split)) Next k End If If Pointer > 52 * Decks - 14 Then '//there are less than 14 cards in the deck, therefore re-shuffle cboDecks.Enabled = True cmdDeal.Enabled = True End If cboSpeed.Enabled = True End Sub Private Sub cmdBet_Click() cmdBet.Enabled = False cboSpeed.Enabled = False Select Case cboSpeed.Text '// set speed Case "Slow" Speed = 3 Case "Medium" Speed = 2 Case "Fast" Speed = 1 Case "Speed" cboSpeed.Text = "Medium" Speed = 2 End Select If cmdDeal.Enabled = True Then '//the deck needs to be re-shuffled Call ShuffleDeck cboDecks.Enabled = False cmdDeal.Enabled = False End If If txtWager < 0 Then MsgBox ("Your wager must not be negative.") Exit Sub End If OrigWager = txtWager.Text Call UpkeepBank(-1) txtWager.Enabled = False '// reset a couple variables Split = 0 DealtHand = 0 Call Pause(0.125 * Speed) Call Deal End Sub Private Sub cmdDeal_Click() '//set the playing option variables If cboDecks.Text = "Decks" Then cboDecks.Text = "6" Decks = 6 '//if they don't choose anything then set it to 6 decks Else Decks = CByte(cboDecks.Text) End If cboDecks.Enabled = False cmdDeal.Enabled = False Call ShuffleDeck Call cmdBet_Click End Sub Private Sub cmdPlay_Click(Index As Integer) Dim k As Byte Dim Name As String Select Case Index Case 0 '//Hit Call IncrDeck(0, 7 * DealtHand + PlayerHands(DealtHand).Cardposition) If PlayerHands(DealtHand).HandCount > 21 Then '// the Player has busted the current hand Call Bust ElseIf PlayerHands(DealtHand).HandCount = 21 Then '// the Player has 21 If DealtHand > 0 Then '//the Player has another hand to play DealtHand = DealtHand - 1 PlayerHands(DealtHand).Cardposition = 1 Call IncrDeck(0, PlayerHands(DealtHand).Cardposition) Exit Sub End If Call DealerPlay End If Case 1 '//Stand If DealtHand > 0 Then '//the Player has another hand to play DealtHand = DealtHand - 1 PlayerHands(DealtHand).Cardposition = 1 Call IncrDeck(0, PlayerHands(DealtHand).Cardposition) Exit Sub End If Call DealerPlay Case 2 '//Double Call UpkeepBank(-1) txtWager.Text = txtWager.Text * 2 Call IncrDeck(0, 7 * DealtHand + PlayerHands(DealtHand).Cardposition) If PlayerHands(DealtHand).HandCount > 21 Then '// the player has busted the current hand Call Bust Exit Sub End If If DealtHand > 0 Then '//the Player has another hand to play DealtHand = DealtHand - 1 PlayerHands(DealtHand).Cardposition = 1 Call IncrDeck(0, PlayerHands(DealtHand).Cardposition) Exit Sub End If Call DealerPlay Case 3 '//Split Split = Split + 1 DealtHand = DealtHand + 1 If Split = 1 Then cmdPlay(3).Enabled = False '//the Player may only split once Call UpkeepBank(-1) For k = 0 To 6 '//create the new image boxes Load imgPlayer(CByte(7 + k)) With imgPlayer(CByte(7 + k)) .Picture = LoadPicture("") .Stretch = False .Left = 240 + 495 * k .Top = 3000 - 500 * DealtHand .Visible = True End With Next k '//move the second card of the split hand to the next hand imgPlayer(7).Picture = pctCards.GraphicCell(PlayerHands(0).CardNumber(1)) PlayerHands(DealtHand).CardNumber(0) = PlayerHands(DealtHand - 1).CardNumber(1) PlayerHands(DealtHand).CardValue(0) = PlayerHands(DealtHand - 1).CardValue(1) PlayerHands(DealtHand).HandCount = PlayerHands(DealtHand - 1).HandCount / 2 PlayerHands(DealtHand).Cardposition = 1 '//clear the second card of the split hand imgPlayer(1).Picture = LoadPicture("") PlayerHands(DealtHand - 1).CardNumber(1) = 0 PlayerHands(DealtHand - 1).CardValue(1) = 0 PlayerHands(DealtHand - 1).HandCount = PlayerHands(DealtHand).HandCount PlayerHands(DealtHand - 1).Cardposition = 1 Call IncrDeck(0, 8) '//deal a card to the new hand Case 4 '//Surrender '//disable the Play command buttons For k = 0 To 4 cmdPlay(k).Enabled = False Next k '//add half of the wager back into the bank Call UpkeepBank(0.5) If DealtHand > 0 Then '//the Player has another hand to play DealtHand = DealtHand - 1 PlayerHands(DealtHand).Cardposition = 1 Call IncrDeck(0, PlayerHands(DealtHand).Cardposition) Exit Sub End If Call DealerShowCard Call Pause(0.25 * Speed) Call ClearTable End Select End Sub Public Sub Deal() Dim Insurance As Integer Dim i As Byte '//re-initialize a couple variables DealerAces = 0 For i = 0 To 1 PlayerHands(i).Aces = 0 PlayerHands(i).HandCount = 0 Next i '//Deal the dealer a face down card. record that card's number and value. input it into the dealer's Hand array imgDealer(0).Picture = pctCards.GraphicCell(54) DownCard(0) = DeckRand(Pointer, 0) '//the downcard card # DownCard(1) = DeckRand(Pointer, 1) '//the downcard cardvalue Pointer = Pointer + 1 lblCardsLeft.Caption = lblCardsLeft.Caption - 1 Call Pause(0.25 * Speed) Call IncrDeck(0, 0) '//deal the Player, in card position 0 Call IncrDeck(1, 1) '//deal the Dealer, in card position 1 Call IncrDeck(0, 1) '//deal the Player, in card position 1 '//change the command buttons so that the Play buttons can be used. cmdPlay(0).Enabled = True cmdPlay(0).Default = True cmdPlay(1).Enabled = True cmdPlay(2).Enabled = True cmdPlay(4).Enabled = True If PlayerHands(DealtHand).CardValue(0) = PlayerHands(DealtHand).CardValue(1) Then '//the player has the ability to split cmdPlay(3).Enabled = True End If PlayerHands(DealtHand).Cardposition = 2 '//re-set the current card-to-be-displayed's position at 2 '//if the Player has Blackjack then take the appropriate actions If PlayerHands(DealtHand).HandCount = 21 Then lblHandResult(0).Left = 720 lblHandResult(0).Caption = "Blackjack Win $" + CStr(txtWager.Text * 2.5) lblHandResult(0).Height = 585 lblHandResult(0).Visible = True Call UpkeepBank(2.5) Call DealerShowCard Call Pause(0.5 * Speed) Call ClearTable lblHandResult(0).Height = 315 Exit Sub End If '//if the dealer has an ace up-card then take the appropriate actions (insurance) If lblCount(1).Caption = 11 Then Insurance = MsgBox("Do you want insurance? The cost is $" + CStr(txtWager.Text / 2) + ".", vbYesNo, "The dealer has an Ace.") If Insurance = 6 Then '//the Player has bought insurance Call UpkeepBank(-0.5) End If If DownCard(1) = 10 Then imgDealer(0).Picture = pctCards.GraphicCell(DownCard(0)) lblHandResult(1).Left = 720 lblHandResult(1).Caption = "Blackjack" lblHandResult(1).Visible = True Call UpkeepDeckCount(10) If Insurance = 6 Then '//if the Dealer has blackjack (downcard = 10) & the Player has insurance, then return the original wager and the insurance to the Player lblHandResult(0).Left = 720 lblHandResult(0).Caption = "Push" lblHandResult(0).Visible = True Call UpkeepBank(1.5) End If Call Pause(0.75 * Speed) Call ClearTable Exit Sub End If End If '//if the Dealer has pocket Blackjack then take the appropriate actions If DownCard(1) = 11 And lblCount(1).Caption = 10 Then If PlayerHands(DealtHand).HandCount = 21 Then '// the player has blackjack too lblHandResult(0).Left = 720 lblHandResult(0).Caption = "Push" lblHandResult(0).Visible = True Call UpkeepBank(1) imgDealer(0).Picture = pctCards.GraphicCell(DownCard(0)) Call UpkeepDeckCount(11) lblHandResult(1).Left = 720 lblHandResult(1).Caption = "Push" lblHandResult(1).Visible = True Call Pause(0.75 * Speed) Call ClearTable Exit Sub End If imgDealer(0).Picture = pctCards.GraphicCell(DownCard(0)) Call UpkeepDeckCount(11) lblHandResult(1).Left = 720 lblHandResult(1).Caption = "Blackjack" lblHandResult(1).Visible = True lblHandResult(0).Left = 720 lblHandResult(0).Caption = "Lose" lblHandResult(0).Visible = True Call Pause(0.75 * Speed) Call ClearTable Exit Sub End If End Sub Public Sub DealerPlay() Dim DealerCount As Integer Dim PlayerCount As Integer Dim Cardposition As Byte '//the Dealer's cardposition Dim k As Byte Dim j As Byte Cardposition = 2 '//disable the Play command buttons For k = 0 To 4 cmdPlay(k).Enabled = False Next k '//flip over the down card. add that card's value to the dealer's count. Call DealerShowCard '//make the dealer hit until he reaches 17. **stand on soft 17** Do While lblCount(1).Caption < 17 Call IncrDeck(1, Cardposition) Cardposition = Cardposition + 1 Loop DealerCount = lblCount(1).Caption '//store the Dealer's count If lblCount(1).Caption > 21 Then '//if the Dealer goes over 21 then re-set Dealer's count, display bust label. DealerCount = 0 lblHandResult(1).Caption = "Bust" lblHandResult(1).Left = imgDealer(Cardposition - 1).Left lblHandResult(1).Visible = True End If For j = 0 To Split '//evaluate each of Player's hands. If the Player hasn't split, then it loops only once. 'j' corresponds to each of the Player's hands. Call EvaluateHand(CInt(PlayerHands(j).HandCount), CInt(DealerCount), j) Next j Call ClearTable End Sub Public Sub DealerShowCard() '//flip over the down card. add that card's value to the dealer's count. imgDealer(0).Picture = pctCards.GraphicCell(DownCard(0)) If DownCard(1) = 11 And lblCount(1).Caption = 11 Then '//the Dealer has (2) aces DealerAces = 1 lblCount(1).Caption = 12 Else lblCount(1).Caption = lblCount(1).Caption + DownCard(1) End If '//Adjust the rolling deck count depending on the dealer's downcard Call UpkeepDeckCount(DownCard(1)) Call Pause(0.25 * Speed) End Sub Public Sub EvaluateHand(PlayerCount As Integer, DealerCount As Byte, Counter As Byte) '// Counter corresponds to the DealtHand '//re-set each Player's count if over 21. If PlayerCount > 21 Then PlayerCount = -1 '//Compare the Player hands If PlayerCount > DealerCount Then '//the Player has won the hand With lblHandResult(0) .Caption = "Win $" + CStr(txtWager.Text) .Left = imgPlayer(PlayerHands(DealtHand).Cardposition - 1).Left .Top = 3480 - 500 * Counter .Visible = True End With Call UpkeepBank(2) ElseIf PlayerCount < DealerCount Then '//the dealer has won the hand With lblHandResult(0) .Caption = "Lose" .Left = imgPlayer(PlayerHands(DealtHand).Cardposition - 1).Left .Top = 3480 - 500 * Counter .Visible = True End With ElseIf PlayerCount = DealerCount Then '//the Player has pushed With lblHandResult(0) .Caption = "Push" .Left = imgPlayer(PlayerHands(DealtHand).Cardposition - 1).Left .Top = 3480 - 500 * Counter .Visible = True End With Call UpkeepBank(1) End If Call Pause(0.5 * Speed) End Sub Public Sub IncrDeck(Playing As Byte, lclCardposition As Byte) '//Playing specifies who is being dealt: 0=Player, 1=Dealer '//lclCardPosition is used to display the card in the correct image box. the 'local' prefix distiguishes it from the global Cardposition(1) Dim k As Byte Dim CardNumber As Byte Dim CardValue As Byte CardNumber = DeckRand(Pointer, 0) CardValue = DeckRand(Pointer, 1) '//Display the card to the person being dealt If Playing = 0 Then '//Player is the current person being dealt imgPlayer(lclCardposition).Picture = pctCards.GraphicCell(CardNumber) Else '//Dealer is current person being dealt imgDealer(lclCardposition).Picture = pctCards.GraphicCell(CardNumber) End If If Playing = 0 Then If CardValue = 11 Then PlayerHands(DealtHand).Aces = 1 '//the Player is being dealt an ace. Only one ace can be worth 11. If CardValue + PlayerHands(DealtHand).HandCount > 21 And PlayerHands(DealtHand).Aces = 1 Then PlayerHands(DealtHand).HandCount = PlayerHands(DealtHand).HandCount + CardValue - 10 PlayerHands(DealtHand).Aces = 0 Else PlayerHands(DealtHand).HandCount = PlayerHands(DealtHand).HandCount + CardValue End If PlayerHands(DealtHand).Cardposition = PlayerHands(DealtHand).Cardposition + 1 '//add one to Player's Cardposition, no matter the card value lblCount(0).Caption = PlayerHands(DealtHand).HandCount ElseIf Playing = 1 Then '//the Dealer is playing If CardValue = 11 Then DealerAces = 1 '//the Dealer is being dealt an ace. Only one ace can be worth 11. If CardValue + lblCount(1).Caption > 21 And DealerAces = 1 Then lblCount(1).Caption = lblCount(1).Caption + CardValue - 10 DealerAces = 0 Else lblCount(1).Caption = lblCount(1).Caption + CardValue End If End If '//record the Cardvalue and CardNumber into Player's hand If Playing = 0 Then '//the player is playing PlayerHands(DealtHand).CardValue(lclCardposition - 7 * DealtHand) = CardValue PlayerHands(DealtHand).CardNumber(lclCardposition - 7 * DealtHand) = CardNumber End If Call UpkeepDeckCount(CardValue) If Playing = 0 And (lclCardposition - 7 * DealtHand) > 0 Then '//only call Suggested Play upkeep if it's the player's turn, and they have been dealt the initial 2 cards Call UpkeepSuggPlay Else lblSuggPlay.Caption = "" End If '//increment the pointer in the random deck Pointer = Pointer + 1 lblCardsLeft.Caption = lblCardsLeft.Caption - 1 Call Pause(0.25 * Speed) End Sub Private Sub Form_Load() Set Xcel = CreateObject("Excel.Application") Xcel.Workbooks.Open FileName:="I:\Chuck\My Programs\BlackJack\BlackJack.xls" Xcel.Worksheets("Sheet1").Activate lblBank.Caption = Xcel.Range("P1").Value End Sub Private Sub Form_Terminate() Xcel.Range("P1").Value = sngBank Xcel.ActiveWorkbook.Save Xcel.Application.Quit End Sub Private Sub Form_Unload(Cancel As Integer) sngBank = lblBank.Caption End Sub Public Sub Pause(ByVal nSecond As Single) Dim t0 As Single Dim dummy As Integer t0 = Timer Do While Timer - t0 < nSecond dummy = DoEvents() ' If we cross midnight, back up one day If Timer < t0 Then t0 = t0 - 24 * 60 * 60 ' or t0 = t0 - 86400 End If Loop End Sub Private Sub ShuffleDeck() Dim CardValue As Byte Dim Counter As Integer Dim DeckStack() As Integer Dim i As Integer Dim j As Integer Dim k As Integer ReDim DeckRand(51 * Decks + Decks - 1, 1) '//re-dimension the random deck ReDim DeckStack(51 * Decks + Decks - 1, 1) '//re-dimension the stacked deck Randomize Pointer = 0 '//re-initializes the current(next) card in the new deck RC = 0 '//re-initializes the deck's running count '//create stacked (ordered) deck. the second column contains the blackjack card value. For i = 0 To Decks - 1 '//a loop for each deck For j = 1 To 4 '//a loop for each suit For k = 1 To 13 '//A thru K If k = 1 Then CardValue = 11 ElseIf k > 10 Then CardValue = 10 Else CardValue = k End If DeckStack(52 * i + 13 * j + k - 14, 0) = 13 * j + k - 14 '//the card's number -- to be used in accessing the correct image cell DeckStack(52 * i + 13 * j + k - 14, 1) = CardValue '//the card's value -- a little matrix analysis helped me with the algorithms :) Next k Next j Next i '//fill randomized deck with -1, to know if it has an open slot (-1 = open slot). For k = 0 To 51 * Decks + Decks - 1 DeckRand(k, 0) = -1 Next k '//fill randomized deck (currently all -1) with stacked deck at random points k = 0 Do While k < 52 * Decks Counter = Int(52 * Rnd * Decks) If DeckRand(Counter, 0) = -1 Then DeckRand(Counter, 0) = DeckStack(k, 0) DeckRand(Counter, 1) = DeckStack(k, 1) k = k + 1 End If Loop lblCardsLeft.Caption = 52 * Decks cmdBet.Enabled = True End Sub Public Sub UpkeepBank(Factor As Single) lblBank.Caption = lblBank.Caption + CSng(txtWager.Text) * Factor End Sub Public Sub UpkeepDeckCount(CardValue As Byte) '//Adjust the running deck count depending on the dealt card. **Hi-Lo Counting system** If CardValue < 7 Then RC = RC + 1 '//adjust the running count appropriately lblDeckCount.Caption = Round(RC / ((52 * Decks - Pointer) / 52), 1) '//convert the running count the true count: TC = RC / (# of unplayed decks) RunningCount.Caption = RC ElseIf CardValue > 9 Then RC = RC - 1 lblDeckCount.Caption = Round(RC / ((52 * Decks - Pointer) / 52), 1) RunningCount.Caption = RC End If End Sub Public Sub UpkeepSuggPlay() Dim k As Byte Dim row As Byte Dim col As Byte row = 1 col = 1 '//find the dealer's upcard For k = 2 To 11 If Xcel.Cells(2, k) = lblCount(1).Caption Then col = k Next k '//find the player's hand If PlayerHands(DealtHand).CardValue(0) = PlayerHands(DealtHand).CardValue(1) And PlayerHands(DealtHand).Cardposition < 2 Then '//the player holds cards of the same value (has the ability to split) & less than 3 cards have been dealt For k = 23 To 32 '//cycle thru the split rows & compare the cell value with one of the player's cards If Xcel.Cells(k, 1) = PlayerHands(DealtHand).CardValue(0) Then row = k '//cycle thru the split rows & compare the cell value with one of the player's cards. Note that aces will produce a CardValue equal to 11. Next k End If If PlayerHands(DealtHand).Aces = 1 Then '// the player has a soft hand For k = 16 To 21 '//cycle thru the soft hand rows & compare the cell value with the player's hand count If PlayerHands(DealtHand).HandCount = Xcel.Cells(k, 1) Then row = k Next k If PlayerHands(DealtHand).HandCount >= 19 Then row = 15 End If If PlayerHands(DealtHand).Aces = 0 Then '// the player has a hard hand For k = 5 To 12 If PlayerHands(DealtHand).HandCount = Xcel.Cells(k, 1) Then row = k Next k If PlayerHands(DealtHand).HandCount >= 17 Then row = 4 If PlayerHands(DealtHand).HandCount <= 8 Then row = 13 End If lblSuggPlay.Caption = Xcel.Cells(row, col).Value End Sub