[分享] 1A2B益智遊戲

dogtimmy

大家都玩過這個遊戲吧:)
規則說明:
A:多少個數字正確且位置正確
B:多少數字正確但是位置不正確

Ex: Ans=2048
1024: 1A2B
2048: 4A0B
8402: 0A4B

以下VBScript程式碼存成XXX.vbs開啟即可

1. Dim inp,ans
   
2. Dim record,rnt
   
3. 
   
4. inp="0000"
   
5. ans = MakeAns
   
6. record = ""
   
7. 
   
8. Do Until rnt = "4A0B"
   
9.   rnt=""
   
10.   inp = InputBox("請輸入數字","輸入","")
    
11.   If Len(inp) <> 4 And Len(inp) > 0 Then Msgbox "連4個數字都不會打嗎?":inp="0000"
    
12.   If inp = "" then exit do
    
13.   rnt = ABCheck(inp,ans)
    
14.   Msgbox rnt
    
15.   record=record & inp & " : " & rnt & chr(13)
    
16.   MSgbox record
    
17. Loop
    
18. 
    
19. Msgbox "答對了不起?"
    
20. '1234 4567
    
21. Function ABCheck(num,ans)
    
22.   Dim i,j
    
23.   Dim a,b
    
24.   Dim c
    
25. 
    
26.   a = 0
    
27.   b = 0
    
28. 
    
29.   For i = 1 to 4
    
30.     c = Mid(num,i,1)
    
31.     If InStr(1,ans,c) > 0 then
    
32.       b = b + 1
    
33.       
    
34.     end if
    
35.     If c = Mid(ans,i,1) Then
    
36.       a= a + 1
    
37.       If b > 0 then b = b - 1
    
38.     End If
    
39.   Next
    
40.   ABCheck = a & "A" & b & "B"
    
41. End Function
    
42. 
    
43. Function MakeAns()
    
44.   Dim i
    
45.   Dim code
    
46.   Dim o
    
47.   code = "0123456789"
    
48.   Randomize Timer
    
49. 
    
50.   for i = 1 to 4
    
51.     o=rnd()*10+1
    
52.     Do Until InStr(1,MakeAns,Mid(code,o,1))=0
    
53.       o=rnd()*10+1
    
54.     Loop
    
55.     MakeAns = MakeAns & Mid(code,o,1)
    
56.   next
    
57. End Function

複製代碼