一个最接近原效果的带窗体的
原程序算法完全一样，只做了个仿qb中input效果的iInput函数（本想也做个仿locate和color的），为照顾楼主，把窗体的字体设为4号字，应该足够了，楼主也可以在设计时更改字体大小。
新建一工程，窗体大小为width=12300,height=6705（可更改），在窗体中放一个timer控件timer1，一个textbox控件text1，拷贝下列代码，编译运行即可。
Dim kAsc As Integer, startY As Integer
Private Sub Form_KeyPress(KeyAscii As Integer)
kAsc = KeyAscii
End Sub
Private Sub Form_Load()
Me.BackColor = 0
Me.ForeColor = &HFFFFFF
kAsc = -1
Timer1.Interval = 500
Text1.FontSize = Me.FontSize
Text1.Height = Text1.FontSize * 15
End Sub
Function abcd()
loop2: Cls
'Color 6
'LOCATE 3, 10
Print "
欢迎您,让我们来玩猜数字游戏吧!现在我有一个四位数,您可以猜8次。"
Print "
记住,这个四位数每个数位上的数字是不相同的。"
Print "
还有，您每猜测一次，我都会给出一个提示的，好好利用提示，"
Print "
您肯定会胜利的，把脑筋动起来吧！"
Print "
提示方法：Ａ和Ｂ，Ａ表示您猜的数字中有一个数位上的数字与答案的"
Print "
数位相同，数字也相同。Ｂ表示您猜的数字中有一个数字与答案中的一个"
Print "
数字相同,但数位不对。"
Print "
例子：比如答案是1234,你猜5243,我给出的提示就是1A2B,1A表示有一个数字对了(指百位上的2),"
Print "
2B表示有两个数字对了(指3和4)，但数位不对，您明白了吗？"
'Color 7
Print "
那让我们开始吧！"
loop10: Randomize Timer
a = 0
b = 0
c = 0
d = 0
k = 0
a = Int(Rnd * 10)
b = Int(Rnd * 10)
c = Int(Rnd * 10)
d = Int(Rnd * 10)
If a <> b And a <> c And a <> d And b <> c And b <> d And c <> d Then e = 1000 * a + 100 * b + 10 * c + d Else GoTo loop10
'Color 11
Print "
现在我有这个四位数了。", e
startY = Me.CurrentY
loop5: k = k + 1
If k = 9 Then GoTo loop100
loop20: Print "
这是您第"; k; "次猜数，您猜猜是多少？"
'Color 11
z = Val(iInputBox("请输入:"))
If z < 1000 Or z > 9999 Then Print "
您输入错误了，记住，您要猜的是一个4个数字都不相同的四位数。请重新输入吧！": GoTo loop20
If z = e Then Print "
您太聪明能干了，您猜对了，这个数字就是"; e; "。": GoTo loop150
a1 = 0
b1 = 0
c1 = 0
d1 = 0
a1 = Int(z / 1000)
b1 = Int((z - a1 * 1000) / 100)
c1 = Int((z - a1 * 1000 - b1 * 100) / 10)
d1 = z - a1 * 1000 - b1 * 100 - c1 * 10
If a1 = b1 Or a1 = c1 Or a1 = d1 Or b1 = c1 Or b1 = d1 Or c1 = d1 Then Print "您输入错误了，记住，您要猜的是一个4个数字都不相同的四位数。请重新输入吧！": GoTo loop20
n = 0
m = 0
q = 0
w = 0
o = 0
r = 0
t = 0
y = 0
If a1 = a Then m = 1 Else If a1 = b Then n = 1 Else If a1 = c Then n = 1 Else If a1 = d Then n = 1
If b1 = a Then q = 1 Else If b1 = b Then w = 1 Else If b1 = c Then q = 1 Else If b1 = d Then q = 1
If c1 = a Then o = 1 Else If c1 = b Then o = 1 Else If c1 = c Then r = 1 Else If c1 = d Then o = 1
If d1 = a Then t = 1 Else If d1 = b Then t = 1 Else If d1 = c Then t = 1 Else If d1 = d Then y = 1
m1 = 0
n1 = 0
m1 = m + w + r + y
n1 = n + q + o + t
Print "
这是您第"; k; "次猜数，可惜了，不对，这次的提示是"; m1; "A"; n1; "B"
GoTo loop5
loop100: Print "
不好意思，在8次机会里您都没有猜对这个数字，真遗憾！这个数字是"; e; "。"
loop150: h$ = iInputBox("
重玩一次请输入(Y/y)，不想玩了请输入(N/n)")
If h$ = "Y" Or h$ = "y" Then GoTo loop2 Else If h$ = "N" Or h$ = "n" Then GoTo loop200 Else Print "您输入错误，请重新输入!": GoTo loop150
loop200: End
End Function
Private Sub Form_Unload(Cancel As Integer)
kAsc = 1
End Sub
Private Sub Timer1_Timer()
Dim a As String
Timer1.Interval = 0
abcd
'
a = iInputBox("请输入：")
'
Print a
End Sub
Private Function iInputBox(a As String) As String
Dim b As String, i As Integer, j As Integer
If Me.CurrentY > Me.ScaleHeight - Me.FontSize * 15 Then
Me.CurrentX = 0: Me.CurrentY = startY
Line (Me.CurrentX, Me.CurrentY)-(Me.ScaleWidth, Me.ScaleHeight), 0, BF
Me.CurrentX = 0: Me.CurrentY = startY
End If
Print a;
b = "": i = Me.CurrentX: j = Me.CurrentY: Text1.Left = i: Text1.Top = j
While kAsc <> 13
While kAsc < 0
DoEvents
Wend
If kAsc >= 0 Then
If kAsc = 1 Then End
If kAsc = 8 Then
If Len(b) > 0 Then b = Left(b, Len(b) - 1)
Else
If kAsc > 40 Then b = b & Chr(kAsc)
End If
Me.Line (i, j)-(i + (Len(b) + 1) * Me.FontSize * 15, j + (Me.FontSize + 2) * 15), 0, BF
Me.CurrentX = i: Me.CurrentY = j: Print b;: Text1.Left = Me.CurrentX: Text1.Visible = True
If kAsc <> 13 Then kAsc = -2
End If
Wend
iInputBox = b
kAsc = -1
Print
End Function
2012-10-19 14:10
猜数字.rar
(9.65 KB)
