这次直接发代码,感兴趣的看看吧

'**********************************************
'文曲星中猜数游戏的“逆”程序，没什么含量，穷举
' by freeforever 2007-2-14
'**********************************************

Option Explicit

Private Type DataGuess '存所有合法数的类型
strVal As String
Useful As Boolean '被淘汰标志
End Type

Dim Data(5040) As DataGuess
Dim intTop As Integer '数组的下标
Dim Times As Integer '执行次数

Private Sub cmdAnswer_Click()
txtA.SetFocus
On Error GoTo MyErr
If (Asc(txtA) + Asc(txtB) - 48 * 2 > 4) Then
MsgBox "输入不合法！", , "非智能"
ElseIf Trim(txtA) = "4" And Trim(txtB) = "0" Then
MsgBox "成功搞定！" & vbCrLf & vbCrLf & "不服再来！", , "非智能"
txtA = "": txtB = "": lstHistory.Clear
Init
txtOut.Text = Answer
Exit Sub
End If
Dim a As Integer, b As Integer
a = Val(txtA): b = Val(txtB)
lstHistory.AddItem Trim((Format(Times + 1, "00"))) & "次:" & Space(2) & _
txtOut & Space(2) & txtA & "A" & txtB & "B"
txtA = "": txtB = "": Times = Times + 1
CheckData Trim(txtOut), a, b
txtOut = Answer
MyErr:
Exit Sub
End Sub

'在得到一次输入后筛选数据函数
Private Function CheckData(strStandart As String, aa As Integer, bb As Integer)
Dim i As Integer, j As Integer
Dim k As Integer, z As Integer
z = aa * 10 + bb
j = 0
For i = 0 To intTop
'与提供的答案对比,得不到相同AB值的淘汰掉
If Compare(strStandart, Data(i).strVal) <> z Then
Data(i).Useful = False
Else
'有相同AB值的做重新存到数组中
Data(j).strVal = Data(i).strVal
Data(j).Useful = True
j = j + 1
End If
Next i
intTop = j - 1
End Function

'对比一组数,返回A*10+B的值
Private Function Compare(str1 As String, str2 As String) As Integer
Dim i As Integer, j As Integer
Dim x As Integer, y As Integer
x = 0: y = 0
For i = 1 To 4
For j = 1 To 4
If Mid(str1, i, 1) = Mid(str2, j, 1) Then
If i = j Then x = x + 1 Else y = y + 1
End If
Next j
Next i
Compare = x * 10 + y
End Function

'在合法数中随机选一个做答
Private Function Answer() As String
Dim i As Integer, cnt As Integer
cnt = 0
Do
i = Rnd * intTop
If (cnt > intTop) Then
MsgBox "看看是不是你出错了？！", , "非智能"
Exit Function
End If
cnt = cnt + 1
Loop While (Not Trim(Data(i).Useful))
Answer = Trim(Data(i).strVal)
End Function

Private Sub cmdLstClear_Click()
lstHistory.Clear
End Sub

Private Sub cmdRetry_Click()
txtA = "": txtB = "": lstHistory.Clear
Init
txtOut.Text = Answer
End Sub

Private Sub Form_Load()
Randomize Time
Me.Move Screen.Width / 3 - Me.Width / 3, Screen.Height / 2 - Me.Height / 2
Init
txtOut.Text = Answer
End Sub

'合法数的生成函数,关键数据的初始也在这个函数中
Private Sub Init()
Dim i As Integer, j As Integer
Dim k As Integer, l As Integer
Dim cnt As Integer
Times = 0
intTop = 0
cnt = 0
For i = 0 To 9
For j = 0 To 9
For k = 0 To 9
For l = 0 To 9
If NotEqul(i, j, k, l) Then
Data(cnt).strVal = Trim(Str(i)) & Trim(Str(j)) & _
Trim(Str(k)) & Trim(Str(l))
Data(cnt).Useful = True: cnt = cnt + 1
End If
Next l
Next k
Next j
Next i
intTop = cnt - 1
End Sub

'当参数中的四个数不相等时返回TRUE
Private Function NotEqul(i As Integer, j As Integer, _
k As Integer, l As Integer) As Boolean
If (i = j Or i = k Or i = l Or _
j = k Or j = l Or k = l) Then
NotEqul = False
Else
NotEqul = True
End If
End Function

Private Sub txtA_KeyPress(KeyAscii As Integer)
If Len(Trim(txtA)) > 0 And KeyAscii <> 8 Then
KeyAscii = 0
End If
If KeyAscii < 48 And KeyAscii <> 8 Or KeyAscii > 52 Then
KeyAscii = 0
ElseIf KeyAscii <> 8 Then
txtB.SetFocus
End If
End Sub

Private Sub txtB_KeyPress(KeyAscii As Integer)
If Len(Trim(txtB)) > 0 And KeyAscii <> 8 Then
KeyAscii = 0
End If
If KeyAscii < 48 And KeyAscii <> 8 Or KeyAscii > 52 Then
KeyAscii = 0
End If
End Sub

jIIB6kwf.rar (7.48 KB) [开源]暂时离开这个版块,留下我的VB程序给大家[5]

[此贴子已经被作者于2007-4-12 10:31:19编辑过]