[第15期]斗地主（已结题）

northwolves

本期题目比较简单：

三个玩家斗地主，每人17张牌，留3张底。

试设置一个按钮，每点击一次，在A2:C18(甲乙丙），D2:D4（底）随机生成一副斗地主牌局，如上图所示。

要求一定是花色和点数准确，随机排列。（花色符号可在字体 Arial Unicode MS中寻找）

1. 完成以上功能得2分

2 如果能动态演示发牌过程（间隔0.2秒），加1分

3 优秀代码还可获1分奖励

附:

符号字体  Arial Unicode MS

UNICODE 编码:

王的符号:  265B

黑桃:         2660

红桃:         2665

草花:         2663

方块:         2666

总结：

本期题目确实比较简单。

动态发牌过程，统计了一下，大致有WAIT方法，API SLEEP方法，API SETTIMER，KILLTIMER方法，TIMER方法。WAIT方法精度不够。

花色设置有的网友先予存后复制的方法，这不是题目的初衷，怪我没说清楚。

最近比较忙，今天才总结评分，请大家谅解。

附我的代码：

Sub doudizhu()
Dim i As Byte, N As Byte, K As Byte, CARD As New Collection, t As Single
[A2:D18].Clear
[A2:D18].Font.Name = "Arial Unicode MS"
[A2:D18].Font.Size = 16
CARD.Add "3[&王"
CARD.Add "0U&王"
For i = 0 To 51
CARD.Add 3 * (i \ 26) & Mid("`cef", i \ 13 + 1, 1) & "&" & Replace(Mid("0A23456789JQK", 1 + i Mod 13, 1), "0", "10")
Next
Randomize
For i = 0 To 50
        t = Timer
        Do While Timer - t < 0.2
        Loop
K = Int(CARD.Count * Rnd) + 1
[a2].Offset(i \ 3, i Mod 3) = StrConv(Mid(CARD(K), 2, 2), vbFromUnicode) & Mid(CARD(K), 4)
[a2].Offset(i \ 3, i Mod 3).Font.ColorIndex = Left(CARD(K), 1)
CARD.Remove K
Next
For i = 1 To 3
[D1].Offset(i, 0) = StrConv(Mid(CARD(i), 2, 2), vbFromUnicode) & Mid(CARD(i), 4)
[D1].Offset(i, 0).Font.ColorIndex = Left(CARD(i), 1)
Next
End Sub

[此贴子已经被作者于2006-10-11 14:44:02编辑过]

清风_ll

fjlhgs

我先发一个。

Timer 用的巧妙。下面的部分用赋值语句就可以了，不必专门设一个函数

Function F2(n As Integer) As Integer
    Randomize
    F2 = Int(Rnd() * n) + 1
End Function

[此贴子已经被northwolves于2006-10-10 22:40:43编辑过]

Long_III

凑个热闹，简化处理了一下，做了一个列表，然后复制过去。我不是很清楚动态发牌是一个什么效果，所以也没往下做了，不过我给随机数在每组里排了一下序，这样牌看起来才舒服一点。

Private Sub CommandButton1_Click()
    Dim i%, m%, n%
    Dim h As New Collection
    Const iMax% = 54
    Dim rng As Range

    On Error Resume Next
    Do
        i = Int(Rnd() * iMax) + 1
        h.Add CStr(i), CStr(i)
    Loop Until h.Count = iMax    '产生1～54的不重复的随机值的集合
    Err.Clear
    On Error GoTo 0

    n = 1: m = 1
    For i = 1 To iMax    ' 在集合里循环，取17、17、17、3这四个区域，然后复制对应的内容过去
        If rng Is Nothing Then
            Set rng = Cells(h(i), "h")
        Else
            Set rng = Union(rng, Cells(h(i), "h"))
        End If

        m = m + 1
        If m > 17 Or i = iMax Then
            rng.Copy Cells(2, n)
            '如果要逐个发过去的话，在这里可以对rng进行循环，一个一个××过去
            n = n + 1: m = 1
            Set rng = Nothing
        End If
    Next
End Sub
说句题外话，最近酷爱斗地主，在联众里混了一个小“佃户”，呵呵

同一张牌发给了两个人，龙三兄检查一下代码：

甲	乙	丙	底
♀王	♂王	♣2	♥9
♥2	♣2	♣1	◆9
◆2	♣1	◆1	♥8
♥1	♣K	♥K
◆K	♣K	♣Q

[sorry,在设置54张牌时出错，没有设置黑桃（都成梅花了），代码没有问题]

[此贴子已经被作者于2006-10-12 16:03:10编辑过]

山菊花

花兄代码很简练

Private Sub Fapai_Click()
    Dim h%, l%, r%, i%
    Range("a2:d18").ClearContents
    Sheet2.Range("a1:a54").Copy Sheet2.Range("b1:b54")
    Randomize
    For i = 0 To 53
        h = IIf(i < 51, i \ 3 + 2, i - 49)
        l = IIf(i < 51, (i Mod 3) + 1, 4)
        r = Int(Rnd * (54 - i) + 1)
        With Sheet2.Range("b" & r)
            .Copy Cells(h, l)
            .Delete Shift:=xlUp
        End With
        t = Timer
        Do While Timer - t < 0.2
        Loop
    Next
End Sub

[此贴子已经被northwolves于2006-10-10 22:55:27编辑过]

byyourside

先做个函数版本,有时间再做VBA版本^^

数组函数+条件格式，思路清晰，鼓励一下

=IF(DATA>0,IF(DATA>52,IF(DATA=53,"小王","大王"),INDEX({"红桃","黑桃","方块","草花"},0,ROUNDUP(DATA/13,0)) & INDEX({"A","2","3","4","5","6","7","8","9","10","J","Q","K"},0,MOD(DATA,13)+1)),"")

[此贴子已经被northwolves于2006-10-10 23:01:22编辑过]

chrisfang

题目既然如狼版主说的比较简单，就想着变点花样出来，做了两种发牌效果(其实第二种是第一种的进一步发挥)，本人VBA菜鸟，现学现做的，献丑了：

说点题外话，这个题目让我回忆起了高一时候学Basic时的一些事情。那时学校里有一丁点电脑课程，其中Basic大约有个7、8个课时。初学了一点编程的入门，最想做的项目就是牌类游戏。当时就自己编了一个21点(BlackJack)的游戏程序，由于上机条件在当时几乎为零，所以所有的编程工作都是在纸上完成的，整个程序大约有3、400行语句(记不清了)，所有的修改调试就是在脑子里和纸上完成的。最后，有个休息天借了邻居的中华学习机来，里面有QBasic(跟Basic差不多)的编程环境，把纸上的代码全部输入，结果几乎没有再修改调试就基本测试成功了。当时真的挺开心的。

所以感觉学编程，做游戏，总还是牌类游戏比较容易上手。可惜的是，到现在年纪奔三了却还没真正的学过一门完整的编程语言。[em04]

 

chrisfang兄弟对于任何问题都分析透彻，奇思妙想，这种态度很令人钦佩。发牌过程做得很不错。

[此贴子已经被northwolves于2006-10-11 9:17:56编辑过]

lg_cai

没找到符号，用中文代替了

lg_cai兄的代码组织得很好，学习。

[此贴子已经被northwolves于2006-10-11 9:23:55编辑过]

sdtower

excel带的抽奖器模板刚好可以做这个。

有兴趣的不妨试一下。

fanjy

不知道这么快就公布答案了,刚做完的,发上来,未实现大小王颜色区分,请指教!

[此贴子已经被作者于2006-9-21 8:19:49编辑过]