[修正版]成语接龙

Trynew

游客，如果您要查看本帖隐藏内容请回复

欢迎喜欢算法的人士发表一下意见进行探讨：

========================================

stack类模块代码：

Option Compare Database

Option Explicit

Dim StackColl As New Collection

ublic Property Get Count() As Variant

    Count = StackColl.Count

End Property

ublic Sub Push(Var As Variant)

    StackColl.Add (Var)

End Sub

ublic Function fetch() As Variant

    fetch = StackColl.Item(StackColl.Count)

    StackColl.Remove (StackColl.Count)

End Function

;Public Property Get AllString() As Variant

    Dim strItem As Variant

    For Each strItem In StackColl

        AllString = AllString & "'" & strItem & "',"

    Next

End Property

=============================================

Form_接龙模块代码：

Option Compare Database

Option Explicit

;Private Sub 命令0_Click()

    Me.显示接龙 = GetLink(Me.选择成语, Me.接龙长度)

End Sub

;Public Function GetLink(StartWord As String, Lenth As Integer) As String

Dim MaxLen As Integer, i As Integer

Dim objStackA As New stack

Dim objStackB As New stack

Dim EndWord As String

Dim rst As Recordset

Randomize

objStackB.Push StartWord

Do While MaxLen < Lenth And objStackB.Count > 0

    StartWord = objStackB.fetch

    Set rst = CurrentDb().OpenRecordset("Select CM from cy where Head='" & Right(StartWord, 1) & "' AND CM Not In (''," & objStackA.AllString & ")" & IIf(Int(2 * Rnd) = 0, "", " Order by CM Desc"))

    If Not rst.EOF Then

        Do While objStackA.Count > 0

            EndWord = objStackA.fetch

            If Right(EndWord, 1) = Left(StartWord, 1) Then

                objStackA.Push EndWord

                Exit Do

            End If

        Loop

        objStackA.Push StartWord

        If objStackA.Count > MaxLen Then

            GetLink = objStackA.AllString

            MaxLen = objStackA.Count

        End If

        Do While Not rst.EOF

            objStackB.Push rst![CM]

            rst.MoveNext

        Loop

    End If

Loop

End Function



===============================================

这是生成的成语接龙：

'开天辟地','地崩山摧','摧刚为柔','柔心弱骨','骨鲠之臣','臣心如水','水中捞月','月章星句','句斟字酌','酌盈剂虚','虚左以待','待价而沽','沽名钓誉','誉不绝口','口诛笔伐','伐功矜能','能不称官','官止神行','行不胜衣','衣绣昼行','行动坐卧','卧不安席','席卷天下','下气怡声','声东击西','西窗剪烛','烛照数计','计无所出','出以公心','心安理得','得薄能鲜','鲜车怒马','马到成功','功高震主','主客颠倒','倒悬之急','急转直下','下阪走丸','丸泥封关','关门大吉','吉凶未卜','卜昼卜夜','夜不闭户','户限为穿','穿壁引光','光阴似箭','箭在弦上','上智下愚','愚昧无知','知止不殆','殆无虚日','日坐愁城','城狐社鼠','鼠窜狼奔','奔走呼号','号啕大哭','哭笑不得','得意之作','作壁上观','观过知仁','仁至义尽','尽欢而散','散兵游勇','勇往直前','前因后果','果于自信','信以为真','真赃实犯','犯颜极谏','谏争如流','流芳百世','世外桃源','源远流长','长安道上','上烝下报','报本反始','始终如一','一把死拿','拿云握雾','雾里看花','花好月圆','圆孔方木','木已成舟','舟中敌国','国步艰难','难分难解','解兵释甲','甲第连天','天作之合','合从连衡','衡阳雁断','断织劝学','学而不厌','厌难折冲','冲口而出','出尘不染','染苍染黄','黄钟瓦釜','釜底抽薪','薪尽火传',[em09]

xinbao

Good,用了堆栈算法

ui

好代码, 很熟悉VB, 高手

test2000

能不创一个最长的,且不断首尾循环的,无穷无尽接龙

tmtony

好代码，很有启发

chaojianan

谢谢分享，收藏了。

付谦

参考

zhafs

   来看看！