解數獨

解數獨程式：
下載程式表單檔

Dim orig(81) As String
Dim gameOver As Boolean, Repe As Boolean
Const g1 = "410709600286035097007000200000501040030007528900000100740203069168000050300008014"
Const g2 = "000500010008603000090070308000000200005016804034200001040008000000100795760952000"
Const g3 = "601580000000000020000030000400000900980400050305002014700000100000620049204070580"

Private Sub Command1_Click()
 gameOver = False
 For i = 1 To 81
  a = Mid(g1, i, 1)
  orig(i) = a
  If a = 0 Then
    T1(i).Text = ""
  Else
    T1(i).Text = a
    T1(i).ForeColor = RGB(200, 0, 0)
  End If
 Next
End Sub

Private Sub Command2_Click()
For i = 1 To 81
 If T1(i).Text = "" Then
All = "123456789"
 a = (i - 1) \ 9 + 1
 b = (i - 1) Mod 9 + 1

 For x = 1 + (a - 1) * 9 To a * 9
  'T1(i).BackColor = vbRed
  If i <> x Then
   All = Replace(All, T1(x), "")
  End If
 Next x

 For x = b To 81 Step 9
   If i <> x Then
    All = Replace(All, T1(x), "")
   End If
 Next x
 '九個小區的檢查是否重複(n,m)=(1,1)~(3,3) 共九區
'(1,1),(1,2),(1,3)
'(2,1),(2,2),(2,3)
'(3,1),(3,2),(3,3)
n = (a - 1) \ 3 + 1
m = (b - 1) \ 3 + 1

'Print "("; n; ","; m; ")"
For z = 1 + (n - 1) * 27 To 19 + (n - 1) * 27 Step 9
 For x = z + (m - 1) * 3 To z + 2 + (m - 1) * 3
  If i <> x Then
   All = Replace(All, T1(x), "")
  End If
 Next x
Next z
 'MsgBox All
 If Len(All) = 1 Then T1(i).Text = All
End If
Next i
End Sub

Private Sub Command3_Click()
 gameOver = False

 For i = 1 To 81
  a = Mid(g2, i, 1)
  orig(i) = a
  If a = 0 Then
    T1(i).Text = ""
  Else
    T1(i).Text = a
    T1(i).ForeColor = RGB(200, 0, 0)
  End If
 Next

End Sub

Private Sub Command4_Click()
 gameOver = False

For i = 1 To 81
  a = Mid(g3, i, 1)
  orig(i) = a
  If a = 0 Then
    T1(i).Text = ""
  Else
    T1(i).Text = a
    T1(i).ForeColor = RGB(200, 0, 0)
  End If
 Next
End Sub

Private Sub Command5_Click()
Dim kk(81) As Integer
Dim kkdata(81) As Integer
For i = 1 To 81
 If T1(i).Text <> "" Then
  kk(i) = 1
 Else
  kk(i) = 2  '等於2時，才是需要猜的格子
  kkdata(i) = 0
 End If
Next i
i = 1
Do
'If i Mod 20 = 0 Then MsgBox i
If kk(i) = 1 Then
 i = i + 1
Else
 Do
  kkdata(i) = kkdata(i) + 1
  T1(i).Text = kkdata(i)
  'MsgBox i & "," & kkdata(i)
 Loop Until Repe = False Or kkdata(i) >= 9
 If Repe = False Then
 i = i + 1
 Else
  Do
   kkdata(i) = 0
   i = i - 1
  
  Loop Until kk(i) = 2
 End If
End If
Loop Until gameOver = True
End Sub
Private Sub mygues()
ag:
achang = False
For i = 1 To 81
 If T1(i).Text = "" Then
All = "123456789"
 a = (i - 1) \ 9 + 1
 b = (i - 1) Mod 9 + 1

 For x = 1 + (a - 1) * 9 To a * 9
  'T1(i).BackColor = vbRed
  If i <> x Then
   All = Replace(All, T1(x), "")
  End If
 Next x

 For x = b To 81 Step 9
   If i <> x Then
    All = Replace(All, T1(x), "")
   End If
 Next x
 '九個小區的檢查是否重複(n,m)=(1,1)~(3,3) 共九區
'(1,1),(1,2),(1,3)
'(2,1),(2,2),(2,3)
'(3,1),(3,2),(3,3)
n = (a - 1) \ 3 + 1
m = (b - 1) \ 3 + 1

'Print "("; n; ","; m; ")"
For z = 1 + (n - 1) * 27 To 19 + (n - 1) * 27 Step 9
 For x = z + (m - 1) * 3 To z + 2 + (m - 1) * 3
  If i <> x Then
   All = Replace(All, T1(x), "")
  End If
 Next x
Next z
 'MsgBox All
 If Len(All) = 1 Then T1(i).Text = All: achang = True
 If Len(All) = 2 Then
    T1(i).Text = Mid(All, 2, 1)
    achang = True
 End If
End If
Next i
If achang Then GoTo ag
End Sub
Private Sub Command6_Click()
ag:
achang = False
For i = 1 To 81
 If T1(i).Text = "" Then
All = "123456789"
 a = (i - 1) \ 9 + 1
 b = (i - 1) Mod 9 + 1

 For x = 1 + (a - 1) * 9 To a * 9
  'T1(i).BackColor = vbRed
  If i <> x Then
   All = Replace(All, T1(x), "")
  End If
 Next x

 For x = b To 81 Step 9
   If i <> x Then
    All = Replace(All, T1(x), "")
   End If
 Next x
 '九個小區的檢查是否重複(n,m)=(1,1)~(3,3) 共九區
'(1,1),(1,2),(1,3)
'(2,1),(2,2),(2,3)
'(3,1),(3,2),(3,3)
n = (a - 1) \ 3 + 1
m = (b - 1) \ 3 + 1

'Print "("; n; ","; m; ")"
For z = 1 + (n - 1) * 27 To 19 + (n - 1) * 27 Step 9
 For x = z + (m - 1) * 3 To z + 2 + (m - 1) * 3
  If i <> x Then
   All = Replace(All, T1(x), "")
  End If
 Next x
Next z
 'MsgBox All
 If Len(All) = 1 Then T1(i).Text = All: achang = True
End If
Next i
If achang Then GoTo ag
End Sub

Private Sub Form_Load()
For i = 0 To 81: T1(i).Text = "": orig(i) = 0: Next
End Sub

Private Sub T1_Change(Index As Integer)
i = Index
Repe = False
If T1(i).Text >= "1" And T1(i).Text <= "9" _
 And Len(T1(i).Text) = 1 And orig(i) = "0" Then
 '第a橫排 第b直排
 a = (i - 1) \ 9 + 1
 b = (i - 1) Mod 9 + 1

 For x = 1 + (a - 1) * 9 To a * 9
  'T1(i).BackColor = vbRed
  If i <> x And T1(i).Text = T1(x).Text Then
   T1(i).Text = "": Beep: Repe = True
  End If
 Next x

 For x = b To 81 Step 9
   If i <> x And T1(i).Text = T1(x).Text Then
   T1(i).Text = "": Beep: Repe = True
  End If
 Next x

'九個小區的檢查是否重複(n,m)=(1,1)~(3,3) 共九區
'(1,1),(1,2),(1,3)
'(2,1),(2,2),(2,3)
'(3,1),(3,2),(3,3)
n = (a - 1) \ 3 + 1
m = (b - 1) \ 3 + 1

'Print "("; n; ","; m; ")"
For z = 1 + (n - 1) * 27 To 19 + (n - 1) * 27 Step 9
 For x = z + (m - 1) * 3 To z + 2 + (m - 1) * 3
  If i <> x And T1(i).Text = T1(x).Text Then
   T1(i).Text = "": Beep: Repe = True
  End If
 Next x
Next z

'判斷是否結束了
ok = True
For x = 1 To 81
 If T1(x) = "" Then ok = False
Next x
If ok = True Then MsgBox "恭喜您完成了": gameOver = True

Else
 If orig(i) = "0" Then T1(i).Text = "": Repe = True Else T1(i).Text = orig(i)
End If
End Sub

Private Sub T1_GotFocus(Index As Integer)
'輔助顯示相同數字
i = Index
If T1(i) <> "" Then
For x = 1 To 81
 If T1(i).Text = T1(x).Text And T1(x).Text <> "" Then
   T1(x).BackColor = vbYellow
 Else
   T1(x).BackColor = vbWhite
 End If
Next

Else
'這格是空的，顯示可能的數字
All = "123456789"
 a = (i - 1) \ 9 + 1
 b = (i - 1) Mod 9 + 1

 For x = 1 + (a - 1) * 9 To a * 9
  'T1(i).BackColor = vbRed
  If i <> x Then
   All = Replace(All, T1(x), "")
  End If
 Next x

 For x = b To 81 Step 9
   If i <> x Then
    All = Replace(All, T1(x), "")
   End If
 Next x
 '九個小區的檢查是否重複(n,m)=(1,1)~(3,3) 共九區
'(1,1),(1,2),(1,3)
'(2,1),(2,2),(2,3)
'(3,1),(3,2),(3,3)
n = (a - 1) \ 3 + 1
m = (b - 1) \ 3 + 1

'Print "("; n; ","; m; ")"
For z = 1 + (n - 1) * 27 To 19 + (n - 1) * 27 Step 9
 For x = z + (m - 1) * 3 To z + 2 + (m - 1) * 3
  If i <> x Then
   All = Replace(All, T1(x), "")
  End If
 Next x
Next z
 MsgBox All
End If
End Sub