100分求解决vb排列问题，有源码。

chinabun 2009-01-12 09:53:19

我有2个程序的计算33选6的方法（大家都知道是双色球吧）。
1）是用随机抽取方法，但问题是需要定出排列数后计算。如果不知道全排列的总数怎么办呢？比如在22选6呢？代码如下：
Dim i As Long, j As Long, k As Long
Dim intTmpNum As Long '临时保存生成的随机数
Dim intNumArray(6) As Long '临时保存1注号码
Dim blnIsExist As Boolean '生成的随机数是否已存在
Dim strNum As String

Randomize Timer '初始化随机种子

intBasicNum = CInt(txtBasicNum.Text) '33
intSelNum = CInt(txtSelNum.Text) '7
lngNumber = CLng(txtNumber.Text) '机选注数

ReDim LotteryNum(lngNumber, intSelNum)

For i = 1 To lngNumber '机选注数
For j = 1 To intSelNum '每注选的号码个数
Do
intTmpNum = Int(Rnd * intBasicNum) + 1 '生成随机数
blnIsExist = False
For k = 1 To j
'判断每注生成的随机号码是否重复了,重复就重新生成随机数
'If intTmpNum = LotteryNum(i, k) Then
If intTmpNum = intNumArray(k) Then
blnIsExist = True
Exit For
End If
Next

Loop While blnIsExist

intNumArray(j) = intTmpNum '保存生成的号码

Next
'可以在这里对数组进行排序,然后再放进List中
BubbleSort1 intNumArray(), 0 '递增

'排序后，再放进全部号码数组中
For j = 1 To intSelNum
LotteryNum(i, j) = intNumArray(j) '保存生成的号码
Next

ListPro1.Bind LotteryNum()

2)递归全排列，生成的数在输出显示时，速度慢。我想让这个递归生成的数加入到上面的“ListPro1.Bind LotteryNum()”。怎样才能做到呢？
Dim I, J As Integer, num As String
Dim nums(33) As String
For I = 0 To 32
If Check1(I).Value = Checked Then
J = J + 1
nums(J) = Check1(I).Caption
End If
Next
If J > 5 Then
Dim a As Integer
Dim b As Integer
Dim c As Integer
Dim d As Integer
Dim e As Integer
Dim f As Integer
Dim txt1 As String

DoEvents
txt1 = ""
For a = 1 To J - 5
For b = a + 1 To J - 4
For c = b + 1 To J - 3
For d = c + 1 To J - 2
For e = d + 1 To J - 1
For f = e + 1 To J

txt1 = nums(a) & " " & nums(b) & " " & nums(c) & " " & nums(d) & " " & nums(e) & " " & nums(f) & vbCrLf
List1.AddItem txt1

DoEvents
End If
Next
Next
Next
Next
Next
Next

总结一下我的求助吧。
1）如何使用第一种方法实现由n选6的结果；
2）或者使用第二种方法输出到第一种的“ListPro1”呢？
分数不多，希望大家能帮帮忙。
谢谢

...全文

216 10 打赏收藏转发到动态举报

写回复

用AI写文章

10 条回复

切换为时间正序

请发表友善的回复…

发表回复

Dlsongzhi1984 2010-07-22

打赏
举报

我可以告诉你

DengXingJie 2009-01-12

打赏
举报

最初始的方法是在33個紅球與16個藍球選擇

如果隻想在10個紅球3個藍球中選，則可以手工輸入

做著玩而已

DengXingJie 2009-01-12

打赏
举报

另存為一個Form文件即



VERSION 5.00

Object = "{3B7C8863-D78F-101B-B9B5-04021C009402}#1.2#0"; "RICHTX32.OCX"

Begin VB.Form frmDoubleBall 

   BorderStyle     =   1  '單線固定

   Caption         =   "雙色球"

   ClientHeight    =   3900

   ClientLeft      =   45

   ClientTop       =   435

   ClientWidth     =   4680

   LinkTopic       =   "Form1"

   LockControls    =   -1  'True

   MaxButton       =   0   'False

   MinButton       =   0   'False

   ScaleHeight     =   3900

   ScaleWidth      =   4680

   StartUpPosition =   2  '螢幕中央

   Begin VB.CommandButton btnInitValue 

      Caption         =   "原始值"

      BeginProperty Font 

         Name            =   "新細明體"

         Size            =   9

         Charset         =   136

         Weight          =   400

         Underline       =   0   'False

         Italic          =   0   'False

         Strikethrough   =   0   'False

      EndProperty

      Height          =   495

      Left            =   600

      TabIndex        =   7

      Top             =   1080

      Width           =   1095

   End

   Begin VB.CommandButton btnStart 

      Caption         =   "開始"

      Height          =   495

      Left            =   1980

      TabIndex        =   6

      Top             =   1080

      Width           =   1095

   End

   Begin VB.CommandButton btnOK 

      Caption         =   "確定"

      Height          =   495

      Left            =   3360

      TabIndex        =   5

      Top             =   1080

      Width           =   1095

   End

   Begin RichTextLib.RichTextBox rtxtResult 

      Height          =   1935

      Left            =   240

      TabIndex        =   4

      TabStop         =   0   'False

      Top             =   1800

      Width           =   4215

      _ExtentX        =   7435

      _ExtentY        =   3413

      _Version        =   393217

      Enabled         =   -1  'True

      ReadOnly        =   -1  'True

      ScrollBars      =   2

      TextRTF         =   $"frmDoubleBall.frx":0000

   End

   Begin VB.TextBox txtBlue 

      Height          =   285

      Left            =   600

      TabIndex        =   2

      Top             =   720

      Width           =   3855

   End

   Begin VB.TextBox txtRed 

      Height          =   285

      Left            =   600

      TabIndex        =   0

      Top             =   360

      Width           =   3855

   End

   Begin VB.Timer Timer1 

      Enabled         =   0   'False

      Interval        =   10

      Left            =   4080

      Top             =   1200

   End

   Begin VB.Label Label2 

      AutoSize        =   -1  'True

      Caption         =   "藍"

      BeginProperty Font 

         Name            =   "新細明體"

         Size            =   12

         Charset         =   0

         Weight          =   700

         Underline       =   0   'False

         Italic          =   0   'False

         Strikethrough   =   0   'False

      EndProperty

      ForeColor       =   &H00FF0000&

      Height          =   240

      Left            =   240

      TabIndex        =   3

      Top             =   720

      Width           =   255

   End

   Begin VB.Label Label1 

      AutoSize        =   -1  'True

      Caption         =   "紅"

      BeginProperty Font 

         Name            =   "新細明體"

         Size            =   12

         Charset         =   0

         Weight          =   700

         Underline       =   0   'False

         Italic          =   0   'False

         Strikethrough   =   0   'False

      EndProperty

      ForeColor       =   &H000000FF&

      Height          =   240

      Left            =   240

      TabIndex        =   1

      Top             =   360

      Width           =   255

   End

End

Attribute VB_Name = "frmDoubleBall"

Attribute VB_GlobalNameSpace = False

Attribute VB_Creatable = False

Attribute VB_PredeclaredId = True

Attribute VB_Exposed = False

Option Explicit

Dim RedArr, BlueArr

Dim nRedArr As Integer, nBlueArr As Integer, nCurRed As Integer, nCurBlue As Integer

Dim nCount As Integer, strResultRed As String, strResultBlue As String

Dim bOK As Boolean, CurRedBall As String, nLine As Integer



Private Sub btnInitValue_Click()

   txtRed.Text = "01 02 03 04 05 06 07 08 09 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33"

   txtBlue.Text = "01 02 03 04 05 06 07 08 09 10 11 12 13 14 15 16"

End Sub



Private Sub btnOK_Click()

   bOK = True

End Sub



Private Sub btnStart_Click()

   If Trim(txtRed.Text) = "" Then

      MsgBox "請輸入待選紅球"

      txtRed.SetFocus

      Exit Sub

   End If

   If Trim(txtBlue.Text) = "" Then

      MsgBox "請輸入待選藍球"

      txtBlue.SetFocus

      Exit Sub

   End If

   

   RedArr = Split(Trim(txtRed.Text), " ")

   nRedArr = UBound(RedArr)

   If nRedArr < 6 Then

      MsgBox "最少需要6個紅球數"

      txtRed.SetFocus

      Exit Sub

   End If

   

   BlueArr = Split(Trim(txtBlue.Text), " ")

   nBlueArr = UBound(BlueArr)

   

   Timer1.Enabled = True

   bOK = False

   nCount = 0

   strResultRed = " "

   Randomize

End Sub





Private Sub Timer1_Timer()

   If bOK = False Then

      nCurRed = Int(Rnd * (nRedArr + 1))

      nCurBlue = Int(Rnd * (nBlueArr + 1))

   Else

      Do Until nCount >= 6

         nCurRed = Int(Rnd * (nRedArr + 1))

         CurRedBall = RedArr(nCurRed)

         

         nCurBlue = Int(Rnd * (nBlueArr + 1))

         

         If InStr(strResultRed, " " & CurRedBall & " ") = 0 Then

            strResultRed = strResultRed & CurRedBall & " "

            nCount = nCount + 1

         End If

      Loop

      

      If nCount >= 6 Then

         nCurBlue = Int(Rnd * (nBlueArr + 1))

         strResultBlue = BlueArr(nCurBlue)

      End If

            

      rtxtResult.Text = rtxtResult.Text & "紅：" & StrOrder(strResultRed, " ") & "  藍：" & strResultBlue & vbCrLf

      nLine = nLine + 1

      Timer1.Enabled = False

      

      Dim i As Integer

      For i = 0 To nLine - 1

          '紅

          rtxtResult.SelStart = i * 29

          rtxtResult.SelLength = 21

          rtxtResult.SelColor = vbRed

          DoEvents

          

          '藍

          rtxtResult.SelStart = i * 29 + 23

          rtxtResult.SelLength = 4

          rtxtResult.SelColor = vbBlue

      Next



   End If

End Sub





Private Sub txtBlue_GotFocus()

   txtBlue.SelStart = 0

   txtBlue.SelLength = Len(txtBlue.Text)

End Sub



Private Sub txtRed_GotFocus()

   txtRed.SelStart = 0

   txtRed.SelLength = Len(txtRed.Text)

End Sub



'字符串排序

Private Function StrOrder(Str As String, Separator As String) As String

   Dim S

   Dim nS As Integer, i As Integer, j As Integer

   Dim SS As String

   

   S = Split(Str, Separator)

   nS = UBound(S)

   ReDim P(nS) As String

   

   For i = nS To 1 Step -1

       For j = 0 To i - 1

           If S(j) > S(j + 1) Then

              SS = S(j)

              S(j) = S(j + 1)

              S(j + 1) = SS

           End If

       Next

   Next



   StrOrder = Join(S, Separator)



End Function

vbman2003 2009-01-12

打赏
举报

我有一个算法,参考:http://blog.csdn.net/vbman2003/archive/2008/04/16/2296394.aspx

chinabun 2009-01-12

打赏
举报

结算，谢谢大家热情的帮助！

zhangchaokun 2009-01-12

打赏
举报

你做这个其实就是出现一种随机效果,没什么实质用途啊

DengXingJie 2009-01-12

打赏
举报

[Quote=引用 4 楼 chinabun 的回复:]
谢谢楼上的，不过您的是每按一次出来一组号码。能进行全排列吗？
[/Quote]

不是很明白你所指的全排列是何意，你是要把33选6的所以情况全部排列出来吗?

vbman2003 2009-01-12

打赏
举报



Option Explicit



Private Const MaxValue As Long = 35

Private Const MaxIndex As Long = 5

Private Const V = MaxValue - MaxIndex



'获得组合总数

Private Function Total(ByVal M As Long, ByVal N As Long) As Long

    Dim i As Long

    Dim Result As Double

    Result = 1

    For i = N To 1 Step -1

        Result = Result * M / i

        M = M - 1

    Next

    Total = Result

End Function



'进位

Private Sub Carry(arr(), Optional Idx = MaxIndex)

    Do

        arr(Idx) = arr(Idx) + 1

        If arr(Idx) > V + Idx Then

            Idx = Idx - 1

        Else

            Exit Do

        End If

    Loop

    Do While Idx < MaxIndex

        Idx = Idx + 1

        arr(Idx) = arr(Idx - 1) + 1

    Loop

End Sub



'RT是RichTextBox

Private Sub Command1_Click()

    Dim a(1 To MaxIndex)

    Dim s() As String

    Dim i As Long

    Dim N As Long

    Dim t As Double

    

    t = Timer

    N = Total(MaxValue, MaxIndex)

    ReDim s(1 To N)

    RT.Text = ""

    For i = 1 To MaxIndex - 1

        a(i) = i

    Next

    a(MaxIndex) = MaxIndex - 1

    For i = 1 To N

        Carry a

        s(i) = Join(a)

    Next

    RT.Text = Join(s, vbCrLf)

    MsgBox Timer - t & vbCrLf & N

End Sub

chinabun 2009-01-12

打赏
举报

我按照2楼提供的介绍，第二种方法为什么会“下标越界”呢？

Private Const MaxValue As Long = 35
Private Const MaxIndex As Long = 5
Private Const V = MaxValue - MaxIndex

'获得组合总数
Private Function Total(ByVal M As Long, ByVal N As Long) As Long
Dim i As Long
Dim Result As Long
Result = 1
For i = N To 1 Step -1
Result = Result * M / i
M = M - 1
Next
Total = Result
End Function

'进位
Private Sub Carry(arr(), Optional Idx = MaxIndex)
Do
arr(Idx) = arr(Idx) + 1
If arr(Idx) > V + Idx Then
Idx = Idx - 1
Else
Exit Do
End If
Loop
Do While Idx < MaxIndex
Idx = Idx + 1
arr(Idx) = arr(Idx - 1) + 1
Loop
End Sub

Private Sub Command2_Click()
Dim a(1 To MaxIndex)
Dim s() As String
Dim i As Long
Dim N As Long
Dim t As Double

t = Timer
N = Total(MaxValue, MaxIndex)
ReDim s(1 To N)
RT.Text = ""
For i = 1 To MaxIndex - 1
a(i) = i
Next
a(MaxIndex) = MaxIndex - 1
For i = 1 To N
Carry a
s(i) = Join(a)
Next
RT.Text = Join(s, vbCrLf)
MsgBox Timer - t & vbCrLf & N
End Sub

chinabun 2009-01-12