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

Question

我有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 Jtxt1 = 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”呢？
分数不多，希望大家能帮帮忙。
谢谢

Answer 1

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

Answer 2

另存為一個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 IntegerPrivate 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 SubPrivate Sub btnOK_Click()
   bOK = True
End SubPrivate 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 SubPrivate 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

Answer 3

我按照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 SubPrivate 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

Answer 4

Option ExplicitPrivate 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