My aim with writing this code was on getting it working as soon as possible. There are certainly ways of doing things more efficiently, I acknowledge that.
The Deck Creator and other Sub Routines make use of several functions listed below. Some functions are not used any more but are listed anyway.
This Function re-orders an array passed to it. Since the Decks used are similar to a new pack of real cards opened from it’s packaging it needs to be re-ordered. Failure to do this will result in a pack of cards shuffled by your 3 year old.
For the Function Module you will need to declare these Public Variables:
Option Explicit Public HoleCards(1 To 91) As String Public c1 As Long, c2 As Long, c3 As Long, c4 As Long, c5 As Long Public AllHands() As Variant
RE-ORDER THE DECK OF CARDS
Public Function ReOrderArray(aOriginal() As Variant) As Variant()
'This Function Re-Orders The Pack of Cards to ensure randonmess
Dim a(), aSwop, aP As Variant
Dim aQ, aR As Long
ReDim a(LBound(aOriginal) To UBound(aOriginal))
For aR = LBound(aOriginal) To UBound(aOriginal)
a(aR) = aOriginal(aR)
Next aR
For aR = LBound(aOriginal) To UBound(aOriginal)
aQ = CLng(((UBound(aOriginal) - aR) * Rnd) + aR)
aSwop = a(aR)
a(aR) = a(aQ)
a(aQ) = aSwop
Next aR
ReOrderArray = a
End Function
This is a function that can also be called in the Worksheet by entering the following formula in any cell:
=Number2Card(23)
Number 23 is Card
Private Function Number2Card(Number As Integer) As String
'Copyright PotOnTheRiver © 2013 (potontheriver@gmail.com). All Rights Reserved
'This code is free for personal use ONLY. It cannot be used, adapted, copied, or published or used commercially or otherwise without my permission
'Turn the Random Decimal Value created for the Deck into a Card
Dim CardName As String
Select Case Number
Case 1
CardName = "2h"
Case 2
CardName = "2d"
Case 3
CardName = "2c"
Case 4
CardName = "2s"
Case 5
CardName = "3h"
Case 6
CardName = "3d"
Case 7
CardName = "3c"
Case 8
CardName = "3s"
Case 9
CardName = "4h"
Case 10
CardName = "4d"
Case 11
CardName = "4c"
Case 12
CardName = "4s"
Case 13
CardName = "5h"
Case 14
CardName = "5d"
Case 15
CardName = "5c"
Case 16
CardName = "5s"
Case 17
CardName = "6h"
Case 18
CardName = "6d"
Case 19
CardName = "6c"
Case 20
CardName = "6s"
Case 21
CardName = "7h"
Case 22
CardName = "7d"
Case 23
CardName = "7c"
Case 24
CardName = "7s"
Case 25
CardName = "8h"
Case 26
CardName = "8d"
Case 27
CardName = "8c"
Case 28
CardName = "8s"
Case 29
CardName = "9h"
Case 30
CardName = "9d"
Case 31
CardName = "9c"
Case 32
CardName = "9s"
Case 33
CardName = "Th"
Case 34
CardName = "Td"
Case 35
CardName = "Tc"
Case 36
CardName = "Ts"
Case 37
CardName = "Jh"
Case 38
CardName = "Jd"
Case 39
CardName = "Jc"
Case 40
CardName = "Js"
Case 41
CardName = "Qh"
Case 42
CardName = "Qd"
Case 43
CardName = "Qc"
Case 44
CardName = "Qs"
Case 45
CardName = "Kh"
Case 46
CardName = "Kd"
Case 47
CardName = "Kc"
Case 48
CardName = "Ks"
Case 49
CardName = "Ah"
Case 50
CardName = "Ad"
Case 51
CardName = "Ac"
Case 52
CardName = "As"
Case Else
CardName = "ERR"
End Select
Number2Card = CardName
End Function
This is a function that can also be called in the Worksheet by entering the following formula in any cell:
=GUID()
Public Function GUID()
'Copyright PotOnTheRiver © 2013 (potontheriver@gmail.com). All Rights Reserved
'This code is free for personal use ONLY. It cannot be used, adapted, copied, or published or used commercially or otherwise without my permission
'Create a random 128bit GUID (Globally Unique IDentifier) to ensure that each deck used is unique
'Once the Decks are created all duplicate decks can be identified and removed
'Using GUID ensures uniqueness by choosing one random GUID from 2^128 GUIDs or 1.000000000e38 numbers
'Why use a GUID? If you want to index each object in the Universe, i.e give it a numberplate, you will use a GUID and you won't run out
Dim v, GUIDID As String
Dim i As Integer
For i = 1 To 36
'Create a Random number between and including 1 and 16 and convert it to HexaDecimal
v = WorksheetFunction.Dec2Hex(Int((16 * Rnd) + 1) - 1)
'Create the GUID's 5 Chunks 8-4-4-4-12
If i = 9 Or i = 14 Or i = 19 Or i = 24 Then
v = "-"
End If
'Append the current GUIDID with V
GUIDID = GUIDID + v
Next i
GUID = GUIDID
End Function
I use this function to colour the background of cards so that I can spot patterns with TRNG and PRNG decks.
Public Function ColourBack(DealtCard As String) As String
'Copyright PotOnTheRiver © 2013 (potontheriver@gmail.com). All Rights Reserved
'This code is free for personal use ONLY. It cannot be used, adapted, copied, or published or used commercially or otherwise without my permission
'Colours the back of the card so that pattern can be detected
Dim NewColour As Double
Select Case DealtCard
Case "2h"
NewColour = RGB(255, 0, 0)
Case "2d"
NewColour = RGB(245, 0, 0)
Case "2c"
NewColour = RGB(235, 0, 0)
Case "2s"
NewColour = RGB(225, 0, 0)
Case "3h"
NewColour = RGB(215, 0, 0)
Case "3d"
NewColour = RGB(205, 0, 0)
Case "3c"
NewColour = RGB(195, 0, 0)
Case "3s"
NewColour = RGB(185, 0, 0)
Case "4h"
NewColour = RGB(175, 0, 0)
Case "4d"
NewColour = RGB(165, 0, 0)
Case "4c"
NewColour = RGB(155, 0, 0)
Case "4s"
NewColour = RGB(145, 0, 0)
Case "5h"
NewColour = RGB(135, 0, 0)
Case "5d"
NewColour = RGB(125, 0, 0)
Case "5c"
NewColour = RGB(115, 0, 0)
Case "5s"
NewColour = RGB(105, 0, 0)
Case "6h"
NewColour = RGB(95, 0, 0)
Case "6d"
NewColour = RGB(85, 0, 0)
Case "6c"
NewColour = RGB(75, 0, 0)
Case "6s"
NewColour = RGB(65, 0, 0)
Case "7h"
NewColour = RGB(55, 0, 0)
Case "7d"
NewColour = RGB(45, 0, 0)
Case "7c"
NewColour = RGB(35, 0, 0)
Case "7s"
NewColour = RGB(25, 0, 0)
Case "8h"
NewColour = RGB(0, 255, 0)
Case "8d"
NewColour = RGB(0, 245, 0)
Case "8c"
NewColour = RGB(0, 235, 0)
Case "8s"
NewColour = RGB(0, 225, 0)
Case "9h"
NewColour = RGB(0, 215, 0)
Case "9d"
NewColour = RGB(0, 205, 0)
Case "9c"
NewColour = RGB(0, 195, 0)
Case "9s"
NewColour = RGB(0, 185, 0)
Case "Th"
NewColour = RGB(0, 175, 0)
Case "Td"
NewColour = RGB(0, 165, 0)
Case "Tc"
NewColour = RGB(0, 155, 0)
Case "Ts"
NewColour = RGB(0, 145, 0)
Case "Jh"
NewColour = RGB(0, 135, 0)
Case "Jd"
NewColour = RGB(0, 125, 0)
Case "Jc"
NewColour = RGB(0, 115, 0)
Case "Js"
NewColour = RGB(0, 105, 0)
Case "Qh"
NewColour = RGB(0, 95, 0)
Case "Qd"
NewColour = RGB(0, 85, 0)
Case "Qc"
NewColour = RGB(0, 75, 0)
Case "Qs"
NewColour = RGB(0, 65, 0)
Case "Kh"
NewColour = RGB(0, 55, 0)
Case "Kd"
NewColour = RGB(0, 45, 0)
Case "Kc"
NewColour = RGB(0, 35, 0)
Case "Ks"
NewColour = RGB(0, 25, 0)
Case "Ah"
NewColour = RGB(0, 0, 255)
Case "Ad"
NewColour = RGB(0, 0, 245)
Case "Ac"
NewColour = RGB(0, 0, 235)
Case "As"
NewColour = RGB(0, 0, 225)
Case Else
NewColour = RGB(255, 255, 255)
End Select
ColourBack = NewColour
End Function
DealDeck is a function that you can use in an worksheet by entering: =DealDeck() in any cell. What will be returned is a fully shuffled card deck like 9d3h5s9h4c3dQs4h4sTd7s2dJhQc2cJd2sJsJc5hTh9cTc8d8h6h7cAh6c8c4d9s8s5d2h6sAdQhKs3c5cQdTsKd3sKh7dAs7hKcAc6d all in one cell. You can use the left, mid and right Excel functions to extract the cards you require. You can also use the Dealer Functions for this purpose.
Public Function DealDeck() As String
'Copyright PotOnTheRiver © 2013 (potontheriver@gmail.com). All Rights Reserved
'This code is free for personal use ONLY. It cannot be used, adapted, copied, or published or used commercially or otherwise without my permission
'Create 1 Randomly Shuffled Deck at the current cell location
Randomize 'Initializes the random-number generator giving it a new seed value.
'If Randomize is not used, the Rnd function (with no arguments) uses the same number as a seed the first time it is called,
'and thereafter uses the last generated number as a seed value.
Dim Deck(1 To 52), Card0 As String
Dim Suits(), Cards()
Dim s, crd As Variant
Dim CardNum, ds, Shuffle, counter, DeckSize As Integer
Dim Deck0 As Collection
'Assign Value to Variables
Set Deck0 = New Collection
DeckSize = 52
Suits = Array("h", "d", "s", "c")
Cards = Array("2", "3", "4", "5", "6", "7", "8", "9", "T", "J", "Q", "K", "A")
Suits = ReOrderArray(Suits) 'ReOrder the Suit Order to enhance randomness
Cards = ReOrderArray(Cards) 'ReOrder the Card Order to enhance randomness
'Create pack of cards
For Each s In Suits
For Each crd In Cards
Deck0.Add crd & s
Next crd
Next s
'Shuffle the Deck of Cards
For ds = 1 To DeckSize
Shuffle = Int(Rnd() * Deck0.Count + 1)
Card0 = Deck0(Shuffle)
Deck(ds) = Card0
Deck0.Remove (Shuffle)
Next ds
'Write out the Deck to the Active Worksheet
counter = 0
For crd = 1 To 52
counter = counter + 1
DealDeck = DealDeck & Deck(counter) 'Append the new dealed card to the deck being dealt
Next crd
'All Requested Decks are now created and displayed
Set Deck0 = Nothing
End Function
DEALING HOLECARDS
Below is a Function that receives a complete deck (52 Cards) as a string, The Player (1 to 10) whose Holecards must be dealt and the amount of players at the table.
In Excel it can be called as follows:
=DealHoleCards(“Qh3hTs8dTh2hAs4cQd4dTc9d9hQc9sTdJs4s5d3s7cJh2dJcKd5s8c9c6d5hKsAdKh6s2c7h8s8hJd4h6hKc6c2s3c7dAhQsAc3d7s5c”,5,10)
This will deal Player 5 with Holecards, Th9s.
Public Function DealHoleCards(PackOfCards As String, Player As Integer, TableSize As Integer) As String
If Player > TableSize Or Player < 1 Or TableSize > 10 Or TableSize < 2 Then
DealHoleCards = ""
Exit Function
End If
'This Function will deal Player x his/hers holecards
'Player 1 is the first to receive cards and sits to the left of the Big Blind (BB)
'Burn Cards has no influence since you only burn before the Flop
DealHoleCards = Mid(PackOfCards, (Player - 1 + Player), 2) & Mid(PackOfCards, ((Player - 1 + Player) + (TableSize * 2)), 2)
End Function
DEAL THE FLOP
This function will burn a card if required and deal the flop for a specific table size.
In Excel it can be called as follows:
=DealTheFlop(“Qh3hTs8dTh2hAs4cQd4dTc9d9hQc9sTdJs4s5d3s7cJh2dJcKd5s8c9c6d5hKsAdKh6s2c7h8s8hJd4h6hKc6c2s3c7dAhQsAc3d7s5c”,10,1)
will deal Jh2dJc as the flop for a 10 handed table having burned 7c.
Public Function DealTheFlop(PackOfCards As String, TableSize As Integer, BurnCard As Integer) As String
'Copyright PotOnTheRiver © 2013 (potontheriver@gmail.com). All Rights Reserved
'This code is free for personal use ONLY. It cannot be used, adapted, copied, or published or used commercially or otherwise without my permission
DealTheFlop = Mid(PackOfCards, (TableSize * 4) + (BurnCard * 2) + 1, 6)
End Function
DEAL THE TURN
This function will burn a card if required and deal the turn for a specific table size.
In Excel it can be called as follows:
=DealTheTurn(“Qh3hTs8dTh2hAs4cQd4dTc9d9hQc9sTdJs4s5d3s7cJh2dJcKd5s8c9c6d5hKsAdKh6s2c7h8s8hJd4h6hKc6c2s3c7dAhQsAc3d7s5c”,10,1)
will deal 5s as the turn for a 10 handed table having burned Kd.
Public Function DealTheTurn(PackOfCards As String, TableSize As Integer, BurnCard As Integer) As String
'Copyright PotOnTheRiver © 2013 (potontheriver@gmail.com). All Rights Reserved
'This code is free for personal use ONLY. It cannot be used, adapted, copied, or published or used commercially or otherwise without my permission
DealTheTurn = Mid(PackOfCards, (TableSize * 4) + (BurnCard * 4) + 7, 2)
End Function
DEAL THE RIVER
This function will burn a card if required and deal the river for a specific table size.
In Excel it can be called as follows:
=DealTheRiver(“Qh3hTs8dTh2hAs4cQd4dTc9d9hQc9sTdJs4s5d3s7cJh2dJcKd5s8c9c6d5hKsAdKh6s2c7h8s8hJd4h6hKc6c2s3c7dAhQsAc3d7s5c”,10,1)
will deal 9c as the riverfor a 10 handed table having burned 8c.
Public Function DealTheRiver(PackOfCards As String, TableSize As Integer, BurnCard As Integer) As String
'Copyright PotOnTheRiver © 2013 (potontheriver@gmail.com). All Rights Reserved
'This code is free for personal use ONLY. It cannot be used, adapted, copied, or published or used commercially or otherwise without my permission
DealTheRiver = Mid(PackOfCards, (TableSize * 4) + (BurnCard * 6) + 9, 2)
End Function
Other Functions
Public Function CommunityCards(PackOfCards As String, TableSize As Integer, BurnCard As Integer) As String
'Copyright PotOnTheRiver © 2013 (potontheriver@gmail.com). All Rights Reserved
'This code is free for personal use ONLY. It cannot be used, adapted, copied, or published or used commercially or otherwise without my permission
CommunityCards = DealTheFlop(PackOfCards, TableSize, BurnCard) & DealTheTurn(PackOfCards, TableSize, BurnCard) & DealTheRiver(PackOfCards, TableSize, BurnCard)
End Function
Function BestHandFlop(PackOfCards As String, Player As Integer, TableSize As Integer, BurnCard As Integer) As String
'Copyright PotOnTheRiver © 2013 (potontheriver@gmail.com). All Rights Reserved
'This code is free for personal use ONLY. It cannot be used, adapted, copied, or published or used commercially or otherwise without my permission
BestHandFlop = SortHoleCards(DealHoleCards(PackOfCards, Player, TableSize)) & DealTheFlop(PackOfCards, TableSize, BurnCard)
End Function
Public Function BestHandTurn(PackOfCards As String, Player As Integer, TableSize As Integer, BurnCard As Integer) As String
'Copyright PotOnTheRiver © 2013 (potontheriver@gmail.com). All Rights Reserved
'This code is free for personal use ONLY. It cannot be used, adapted, copied, or published or used commercially or otherwise without my permission
BestHandTurn = BestHand(BestHandFlop(PackOfCards, Player, TableSize, BurnCard) & DealTheTurn(PackOfCards, TableSize, BurnCard))
End Function
Public Function BestHandRiver()
'Copyright PotOnTheRiver © 2013 (potontheriver@gmail.com). All Rights Reserved
'This code is free for personal use ONLY. It cannot be used, adapted, copied, or published or used commercially or otherwise without my permission
End Function
Public Function HoleCardRanking(HoleCard As String) As Integer
'Copyright PotOnTheRiver © 2013 (potontheriver@gmail.com). All Rights Reserved
'This code is free for personal use ONLY. It cannot be used, adapted, copied, or published or used commercially or otherwise without my permission
Dim HC As String
Dim c As Integer
If HoleCards(1) = "" Then
Call EnumerateHoleCards
End If
HC = Mid(HoleCard, 1, 1) & Mid(HoleCard, 3, 1)
For c = 1 To 91
If HC = HoleCards(c) Then
HoleCardRanking = c
Exit Function
End If
Next c
End Function
Public Function CardBits(Card As String) As Long
'Copyright PotOnTheRiver © 2013 (potontheriver@gmail.com). All Rights Reserved
'This code is free for personal use ONLY. It cannot be used, adapted, copied, or published or used commercially or otherwise without my permission
'This Assign each card a decimal value which is actually it's Binary Bit Code used to determine hand strengths & flushes
Select Case Card
Case "2c"
CardBits = 98306
Case "2d"
CardBits = 81922
Case "2h"
CardBits = 73730
Case "2s"
CardBits = 69634
Case "3c"
CardBits = 164099
Case "3d"
CardBits = 147715
Case "3h"
CardBits = 139523
Case "3s"
CardBits = 135427
Case "4c"
CardBits = 295429
Case "4d"
CardBits = 279045
Case "4h"
CardBits = 270853
Case "4s"
CardBits = 266757
Case "5c"
CardBits = 557831
Case "5d"
CardBits = 541447
Case "5h"
CardBits = 533255
Case "5s"
CardBits = 529159
Case "6c"
CardBits = 1082379
Case "6d"
CardBits = 1065995
Case "6h"
CardBits = 1057803
Case "6s"
CardBits = 1053707
Case "7c"
CardBits = 2131213
Case "7d"
CardBits = 2114829
Case "7h"
CardBits = 2106637
Case "7s"
CardBits = 2102541
Case "8c"
CardBits = 4228625
Case "8d"
CardBits = 4212241
Case "8h"
CardBits = 4204049
Case "8s"
CardBits = 4199953
Case "9c"
CardBits = 8423187
Case "9d"
CardBits = 8406803
Case "9h"
CardBits = 8398611
Case "9s"
CardBits = 8394515
Case "Tc"
CardBits = 16812055
Case "Td"
CardBits = 16795671
Case "Th"
CardBits = 16787479
Case "Ts"
CardBits = 16783383
Case "Jc"
CardBits = 33589533
Case "Jd"
CardBits = 33573149
Case "Jh"
CardBits = 33564957
Case "Js"
CardBits = 33560861
Case "Qc"
CardBits = 67144223
Case "Qd"
CardBits = 67127839
Case "Qh"
CardBits = 67119647
Case "Qs"
CardBits = 67115551
Case "Kc"
CardBits = 134253349
Case "Kd"
CardBits = 134236965
Case "Kh"
CardBits = 134228773
Case "Ks"
CardBits = 134224677
Case "Ac"
CardBits = 268471337
Case "Ad"
CardBits = 268454953
Case "Ah"
CardBits = 268446761
Case "As"
CardBits = 268442665
End Select
End Function
Public Function Flush(Handf As String) As Boolean
Dim c1f, c2f, c3f, c4f, c5f As String
'Copyright PotOnTheRiver © 2013 (potontheriver@gmail.com). All Rights Reserved
'This code is free for personal use ONLY. It cannot be used, adapted, copied, or published or used commercially or otherwise without my permission
'This Function Receives a 5 card hand and determines if it is a Flush but not what type of Flush
c1f = Mid(Handf, 2, 1)
c2f = Mid(Handf, 4, 1)
c3f = Mid(Handf, 6, 1)
c4f = Mid(Handf, 8, 1)
c5f = Mid(Handf, 10, 1)
If c1f = c2f And c1f = c3f And c1f = c4f And c1f = c5f Then
Flush = True
End If
End Function
Public Function HandValue(Handh As String)
Dim c1h, c2h, c3h, c4h, c5h As Long
'Copyright PotOnTheRiver © 2013 (potontheriver@gmail.com). All Rights Reserved
'This code is free for personal use ONLY. It cannot be used, adapted, copied, or published or used commercially or otherwise without my permission
'This Function Receives a 5 card hand and determines the Handvalue.
Dim FL As Boolean
FL = Flush(Handh)
c1h = CardBits(Mid(Handh, 1, 2))
c2h = CardBits(Mid(Handh, 3, 2))
c3h = CardBits(Mid(Handh, 5, 2))
c4h = CardBits(Mid(Handh, 7, 2))
c5h = CardBits(Mid(Handh, 9, 2))
If FL = True Then
HandValue = shr(c1h Or c2h Or c3h Or c4h Or c5h, 16)
End If
If FL = False Then
HandValue = (c1h And &HFF) * (c2h And &HFF) * (c3h And &HFF) * (c4h And &HFF) * (c5h And &HFF)
End If
End Function
Public Function shr(ByVal Value As Long, ByVal Shift As Byte) As Long
Dim i As Byte
shr = Value
If Shift > 0 Then
shr = Int(shr / (2 ^ Shift))
End If
End Function
Public Function HandRank(Handv As String) As Integer
'Copyright PotOnTheRiver © 2013 (potontheriver@gmail.com). All Rights Reserved
'This code is free for personal use ONLY. It cannot be used, adapted, copied, or published or used commercially or otherwise without my permission
'This Function ranks the player's hand from best (1) to worst(7462)
Dim FL As Boolean, HV As Long
HV = HandValue(Handv)
FL = Flush(Handv)
If FL = True Then
HandRank = WorksheetFunction.VLookup(HV, Range("HandNameLookupF"), 2, False)
End If
If FL = False Then
HandRank = WorksheetFunction.VLookup(HV, Range("HandNameLookup"), 2, False)
End If
End Function
Public Function HandName(Handn As String) As String
'Copyright PotOnTheRiver © 2013 (potontheriver@gmail.com). All Rights Reserved
'This code is free for personal use ONLY. It cannot be used, adapted, copied, or published or used commercially or otherwise without my permission
Dim HR As Integer
HR = HandRank(Handn)
HandName = WorksheetFunction.VLookup(HR, Range("HandTypeLookup"), 9, False)
End Function
Public Function HandType(Handt As String) As String
'Copyright PotOnTheRiver © 2013 (potontheriver@gmail.com). All Rights Reserved
'This code is free for personal use ONLY. It cannot be used, adapted, copied, or published or used commercially or otherwise without my permission
Dim HR As Integer
HR = HandRank(Handt)
HandType = WorksheetFunction.VLookup(HR, Range("HandTypeLookup"), 8, False)
End Function
Public Function BestHand(Handb As String) As String
'Copyright PotOnTheRiver © 2013 (potontheriver@gmail.com). All Rights Reserved
'This code is free for personal use ONLY. It cannot be used, adapted, copied, or published or used commercially or otherwise without my permission
Dim r1, r2, n1, n2, n3, n4, n5, bestval As Integer
Dim Cardsb As Long
Dim HandToTest As String
Cardsb = Len(Handb) / 2
bestval = 10000
ReDim CardsBase(1 To Cardsb)
ReDim AllHands(WorksheetFunction.Combin(Cardsb, 5))
n2 = 0
For n1 = 1 To Cardsb
CardsBase(n1) = Mid(Handb, n1 + n2, 2)
n2 = n2 + 1
Next n1
Call BuiltDesign(Cardsb)
For r1 = 1 To WorksheetFunction.Combin(Cardsb, 5)
For r2 = 1 To 5
HandToTest = HandToTest & CardsBase(Mid(AllHands(r1), r2, 1))
Next r2
If HandRank(HandToTest) < bestval Then
bestval = HandRank(HandToTest)
BestHand = HandToTest
End If
HandToTest = ""
Next r1
BestHand = SortHand(BestHand)
End Function
Public Function LongBinary(lngNumber As Long) As String
'Copyright PotOnTheRiver © 2013 (potontheriver@gmail.com). All Rights Reserved
'This code is free for personal use ONLY. It cannot be used, adapted, copied, or published or used commercially or otherwise without my permission
Dim lngExp As Long
Dim strBinary
If lngNumber < 0 Then Exit Function
Do While 2 ^ lngExp <= lngNumber
strBinary = -((lngNumber And (2 ^ lngExp)) <> 0) & strBinary
lngExp = lngExp + 1
Loop
LongBinary = strBinary
End Function
Public Function SortHand(HandToSort As String) As String ' Must be 5 cards
'Copyright PotOnTheRiver © 2013 (potontheriver@gmail.com). All Rights Reserved
'This code is free for personal use ONLY. It cannot be used, adapted, copied, or published or used commercially or otherwise without my permission
'This Function sort the players 5 card hand in the correct order.
If (Len(HandToSort) / 2) > 5 Then
SortHand = "!Only5Cards!"
Exit Function
End If
Dim BestHandCollection As Collection
Dim CardsToSort(1 To 5, 3)
Dim s, r, cr, HV0 As Integer
Set BestHandCollection = New Collection
cr = 1
HV0 = HandRank(HandToSort)
If IsNumeric(WorksheetFunction.VLookup(HV0, Range("HandTypeLookup"), 3, False)) Then
BestHandCollection.Add CStr(WorksheetFunction.VLookup(HV0, Range("HandTypeLookup"), 3, False))
Else
BestHandCollection.Add WorksheetFunction.VLookup(HV0, Range("HandTypeLookup"), 3, False)
End If
If IsNumeric(WorksheetFunction.VLookup(HV0, Range("HandTypeLookup"), 4, False)) Then
BestHandCollection.Add CStr(WorksheetFunction.VLookup(HV0, Range("HandTypeLookup"), 4, False))
Else
BestHandCollection.Add WorksheetFunction.VLookup(HV0, Range("HandTypeLookup"), 4, False)
End If
If IsNumeric(WorksheetFunction.VLookup(HV0, Range("HandTypeLookup"), 5, False)) Then
BestHandCollection.Add CStr(WorksheetFunction.VLookup(HV0, Range("HandTypeLookup"), 5, False))
Else
BestHandCollection.Add WorksheetFunction.VLookup(HV0, Range("HandTypeLookup"), 5, False)
End If
If IsNumeric(WorksheetFunction.VLookup(HV0, Range("HandTypeLookup"), 6, False)) Then
BestHandCollection.Add CStr(WorksheetFunction.VLookup(HV0, Range("HandTypeLookup"), 6, False))
Else
BestHandCollection.Add WorksheetFunction.VLookup(HV0, Range("HandTypeLookup"), 6, False)
End If
If IsNumeric(WorksheetFunction.VLookup(HV0, Range("HandTypeLookup"), 7, False)) Then
BestHandCollection.Add CStr(WorksheetFunction.VLookup(HV0, Range("HandTypeLookup"), 7, False))
Else
BestHandCollection.Add WorksheetFunction.VLookup(HV0, Range("HandTypeLookup"), 7, False)
End If
For r = 1 To 5
CardsToSort(r, 2) = Mid(HandToSort, cr, 1)
CardsToSort(r, 3) = Mid(HandToSort, cr + 1, 1)
cr = cr + 2
Next r
For r = 1 To 5
For s = 1 To 5
If IsEmpty(CardsToSort(s, 1)) Then
If CardsToSort(s, 2) = BestHandCollection.Item(r) Then
CardsToSort(s, 1) = r
s = 5
' Exit For
End If
End If
Next s
Next r
For r = 1 To 5
For s = 1 To 5
If CardsToSort(s, 1) = r Then
SortHand = SortHand & CardsToSort(s, 2) & CardsToSort(s, 3)
s = 5
End If
Next s
Next r
End Function
Public Function PlayerHand(PackOfCards As String, Player As Integer, TableSize As Integer, BurnCard As Integer) As String
'Copyright PotOnTheRiver © 2013 (potontheriver@gmail.com). All Rights Reserved
'This code is free for personal use ONLY. It cannot be used, adapted, copied, or published or used commercially or otherwise without my permission
PlayerHand = DealHoleCards(PackOfCards, Player, TableSize) & CommunityCards(PackOfCards, TableSize, BurnCard)
End Function
Public Function SortHoleCards(HoleCardsToSort As String) As String
'Copyright PotOnTheRiver © 2013 (potontheriver@gmail.com). All Rights Reserved
'This code is free for personal use ONLY. It cannot be used, adapted, copied, or published or used commercially or otherwise without my permission
Dim HCS1, HCS2 As String
Dim HS1, HS2 As Integer
HCS1 = Mid(HoleCardsToSort, 1, 1) & Mid(HoleCardsToSort, 1, 1)
HCS2 = Mid(HoleCardsToSort, 3, 1) & Mid(HoleCardsToSort, 3, 1)
'EnumerateHoleCards
For HS1 = 1 To 13
If HCS1 = HoleCards(HS1) Then
Exit For
End If
Next HS1
For HS2 = 1 To 13
If HCS2 = HoleCards(HS2) Then
Exit For
End If
Next HS2
If HS1 > HS2 Then
SortHoleCards = Mid(HoleCardsToSort, 3, 2) & Mid(HoleCardsToSort, 1, 2)
Else
SortHoleCards = Mid(HoleCardsToSort, 1, 2) & Mid(HoleCardsToSort, 3, 2)
End If
End Function
The content of this blog is free for personal use ONLY. It cannot be used, adapted, copied, or published or used commercially without my permission.
Rabbit Hunting - Hold'em or not 