'如果你设置出盘为81就是这个数独的解，不过这个程序每次生成的题目是不相同的，所以。。
'其他功能正待研究中
'Option Explicit
Dim ChengGong As Boolean
Dim TCJishu As Long
Dim f(1 To 9, 1 To 9, 0 To 9) As Byte
Dim tcaq(1 To 9, 1 To 9, 0 To 9) As Byte
Dim jishu As Long
Dim QingKong() As String
Dim CW(8, 8) As Byte
'网友slippermummy的源代码请参考
'http://hi.baidu.com/slippermummy/blog/item/b2b222d077b23780a1ec9c33.html
Dim r!, A(8, 8) As Byte, B(8, 8) As Byte, c(8, 8, 1 To 9) As Byte, StarNum As Byte
Dim Xmouse As Byte, Ymouse As Byte, BoxColor As Byte
'图像输出（此事件有网友slippermummy 提供，修改了检查出错误返回为红色）
Private Sub ImgOutput()
Dim m, n
'底色
Line (0, 0)-(9, 9), RGB(192, 192, 192), BF
'宫(区)的底色
For n = 0 To 6 Step 6
Line (n, 3)-Step(3, 3), RGB(255, 128, 64), BF
Line (3, n)-Step(3, 3), RGB(0, 128, 192), BF
Next
'突出显示单元格
If BoxColor = 1 Then Line (Xmouse, Ymouse)-Step(1, 1), , B
FillStyle = 6
'画网格
Me.ForeColor = vbBlack
For n = 0 To 9
Line (0, n)-(9, n)
Line (n, 0)-(n, 9)
Next
'*********************************显示示例
For m = 0 To 8
For n = 0 To 8
If B(m, n) = 1 Then Me.ForeColor = vbBlack Else Me.ForeColor = vbWhite
If CW(m, n) = 1 Then Me.ForeColor = vbRed
If A(m, n) = 0 Then GoTo A1
CurrentX = m - 0.035
CurrentY = n + 1 / 6
Print A(m, n)
A1: Next
Next
End Sub
'此事件有网友slippermummy 提供，修改了生成初盘的过程
Private Sub Form_Load()
chazhao
Dim XRnd As Byte, YRnd As Byte, WordRnd As Byte, CheckNum As Byte, StarNum As Byte, rownum As Byte, colnum As Byte, m, n, i
Dim weizhi(80) As Byte, xyTmp As Byte
Me.AutoRedraw = True
Me.ClipControls = False '**************局部重画
Me.FontSize = 30 '**********************************控制大小
r = Me.TextHeight("a") * 1.5
Me.Width = r * 9: Me.Height = r * 10
Me.Move (Screen.Width - Me.Width) / 2, (Screen.Height - Me.Height) / 2
ScaleWidth = 10: ScaleHeight = 10.5 '********************自建坐标系
ScaleTop = -1: ScaleLeft = -0.5
'如果你设置出盘为81就是这个数独的解，不过这个程序每次生成的题目是不相同的，所以....
'其他功能正待研究中
StarNum = 29 '*******************************初盘数
'生成初盘
'Randomize
For i = 1 To StarNum
'Do
xyTmp = suiji(weizhi)
weizhi(i - 1) = xyTmp
XRnd = IIf(xyTmp Mod 9 = 0, 9, xyTmp Mod 9) - 1
YRnd = -Int(-(xyTmp / 9)) - 1
WordRnd = f(XRnd + 1, YRnd + 1, 0)
'CheckNum = Check(XRnd, YRnd, WordRnd)
'Loop Until (A(XRnd, YRnd) = 0) * (CheckNum = 0)
A(XRnd, YRnd) = WordRnd
B(XRnd, YRnd) = 1
For n = 0 To 8
c(XRnd, n, WordRnd) = 1: c(n, YRnd, WordRnd) = 1
Next
rownum = Int(XRnd / 3) * 3: colnum = Int(YRnd / 3) * 3
For n = 0 To 2
For m = 0 To 2
c(rownum + n, colnum + m, WordRnd) = 1
Next
Next
Next
ImgOutput
End Sub
Private Sub Form_Paint()
ImgOutput
End Sub
'查错（此函数有网友slippermummy 提供）
Public Function Check(Xn As Byte, Yn As Byte, Wordn As Byte) As Byte
Dim rownum As Byte, colnum As Byte, Cx As Byte, Cy As Byte, Cxy As Byte, n, m, i
'行列检查
For n = 0 To 8
For i = 1 To 9
Cx = Cx + c(Xn, n, i)
Cy = Cy + c(n, Yn, i)
Next
If (A(Xn, n) = Wordn) + (A(n, Yn) = Wordn) + (Cx = 9) + (Cy = 9) Then
Check = 1
Exit Function
End If
Cx = 0: Cy = 0
Next
'宫(区)检查
rownum = Int(Xn / 3) * 3: colnum = Int(Yn / 3) * 3
For n = 0 To 2
For m = 0 To 2
For i = 1 To 9
Cxy = Cxy + c(rownum + n, colnum + m, i)
Next
If (A(rownum + n, colnum + m) = Wordn) + (Cxy = 9) Then
Check = 1
Exit Function
End If
Cxy = 0
Next
Next
Check = 0
End Function
'此事件有网友slippermummy 提供
Private Sub Form_MouseUp(Button As Integer, Shift As Integer, x As Single, y As Single)
On Error GoTo A1
If B(CByte(Int(x)), CByte(Int(y))) = 1 Then GoTo A1
Xmouse = CByte(Int(x)): Ymouse = CByte(Int(y))
BoxColor = 1
ImgOutput
A1: Exit Sub
End Sub
'此事件有网友slippermummy 提供，修改了检查出错误返回为红色
Private Sub Form_KeyPress(KeyAscii As Integer)
Dim KeyNum As Byte, m, n
Select Case KeyAscii
Case 49 To 57
KeyNum = Chr(KeyAscii)
CW(Xmouse, Ymouse) = 0
If Check(Xmouse, Ymouse, CByte(KeyNum)) = 1 Then
CW(Xmouse, Ymouse) = 1
'Exit Sub
End If
A(Xmouse, Ymouse) = KeyNum
Case Else: A(Xmouse, Ymouse) = 0
End Select
ImgOutput
'结束检查
For m = 0 To 8
For n = 0 To 8
If A(m, n) = 0 Or A(n, m) = 0 Or CW(m, n) = 1 Then Exit Sub
Next
Next
MsgBox "胜利!"
End Sub
'以下是我的函数，望指正
Sub chazhao()
Dim yy() As Byte
ReDim yy(8)
For n = 1 To 9
For nn1 = 0 To 9
For n2 = 1 To 9
f(n, n2, nn1) = 0
tcaq(n, n2, nn1) = 0
Next
Next
Next
For x = 1 To 9
aq = suiji(yy)
f(x, 1, 0) = aq
yy(x - 1) = aq
Next
ReDim QingKong(0)
ChengGong = False
TCJishu = 0
DoEvents
TianChong2_1 1, 2
DoEvents
End Sub
Sub TCBiaoji() '标记
Dim A, B, c, d
jishu = 0
For x = 1 To 9
For y = 1 To 9
If f(x, y, 0) = 0 Then
jishu = jishu + 1
For m = 1 To 9
If f(m, y, 0) <> 0 Then f(x, y, f(m, y, 0)) = 1
If f(x, m, 0) <> 0 Then f(x, y, f(x, m, 0)) = 1
Next
A = -Int(-(x / 3))
B = -Int(-(y / 3))
For c = (A - 1) * 3 + 1 To A * 3
For d = (B - 1) * 3 + 1 To B * 3
If f(c, d, 0) <> 0 Then f(x, y, f(c, d, 0)) = 1
Next
Next
End If
Next
Next
End Sub
Function TianChong() As Long
Dim tmp As Long
Dim hangjc As Boolean
TianChong = 0
Do While 1
tmp = 0
'标记
TCBiaoji
'填充
tmp = jishu
For x = 1 To 9
For y = 1 To 9
If f(x, y, 0) = 0 Then
q = 0
For m = 1 To 9
If f(x, y, m) = 1 Then
q = q + 1
Else
p = m
End If
Next
Select Case q
Case 8
f(x, y, 0) = p: jishu = jishu - 1
TCBiaoji
QingKong(UBound(QingKong)) = QingKong(UBound(QingKong)) & x & y & ","
hangjc = True
For m = 1 To 9
If f(m, y, 0) = 0 Then hangjc = False
Next
If hangjc = True Then
Select Case y
Case 2
TianChong = 63
Case 3
TianChong = 54
Case 4
TianChong = 45
Case 5
TianChong = 36
Case 6
TianChong = 27
Case 7
TianChong = 18
End Select
End If
Case 9
TianChong = 2
Exit Function
End Select
End If
Next
Next
If tmp = jishu Then
' ReDim Preserve QingKong(UBound(QingKong) + 1)
Exit Do
End If
Loop
If jishu = 0 Then TianChong = 1
End Function
Function TianChong8_1(x As Long, y As Long) As Boolean
Select Case TianChong
'Case 0
Case 2
Exit Function
Case 1
DoEvents
ChengGong = True
DoEvents
Case Else
For m = 1 To 9
If f(x, y, m) = 0 Then
If f(x, y, 0) = 0 Then f(x, y, 0) = m
TCJishu = TCJishu + 1
ReDim Preserve QingKong(TCJishu)
TianChong8_1 x + 1, y
If ChengGong = True Then Exit Function
For n = 1 To 9
For nn1 = 1 To 9
f(n, 9, nn1) = 0
f(n, 8, nn1) = 0
Next
Next
If f(x, y, 0) = m Then f(x, y, 0) = 0
QingKong_1 (TCJishu)
TCJishu = TCJishu - 1
TCBiaoji
End If
Next
End Select
End Function
Function TianChong7_1(x As Long, y As Long) As Boolean
Dim yy() As Byte
Select Case TianChong
Case 2
Exit Function
Case 18
TianChong8_1 1, 8
Exit Function
Case Else
xia:
ReDim yy(8)
i = 0
For m = 1 To 9
If f(x, y, m) = 1 Then
yy(i) = m
i = i + 1
End If
If i = 9 Then Exit Function
Next
aq = suiji(yy)
If f(x, y, 0) = 0 Then
f(x, y, 0) = aq
tcaq(x, y, aq) = 1
End If
TCJishu = TCJishu + 1
ReDim Preserve QingKong(TCJishu)
TianChong7_1 x + 1, y
If ChengGong = True Then Exit Function
For n = 1 To 9
For nn1 = 1 To 9
For n2 = 7 To 9
f(n, n2, nn1) = 0
Next
Next
Next
If f(x, y, 0) = aq Then f(x, y, 0) = 0
QingKong_1 (TCJishu)
TCJishu = TCJishu - 1
TCBiaoji
For m = 1 To 9
If tcaq(x, y, m) = 1 Then f(x, y, m) = 1
Next
GoTo xia
End Select
End Function
Function TianChong6_1(x As Long, y As Long) As Boolean
Dim yy() As Byte
Select Case TianChong
Case 2
Exit Function
Case 27
TianChong7_1 1, 7
Exit Function
Case Else
xia:
ReDim yy(8)
i = 0
For m = 1 To 9
If f(x, y, m) = 1 Then
yy(i) = m
i = i + 1
End If
If i = 9 Then Exit Function
Next
aq = suiji(yy)
If f(x, y, 0) = 0 Then
f(x, y, 0) = aq
tcaq(x, y, aq) = 1
End If
TCJishu = TCJishu + 1
ReDim Preserve QingKong(TCJishu)
TianChong6_1 x + 1, y
If ChengGong = True Then Exit Function
For n = 1 To 9
For nn1 = 1 To 9
For n2 = 6 To 9
f(n, n2, nn1) = 0
Next
Next
Next
If f(x, y, 0) = aq Then f(x, y, 0) = 0
QingKong_1 (TCJishu)
TCJishu = TCJishu - 1
TCBiaoji
For m = 1 To 9
If tcaq(x, y, m) = 1 Then f(x, y, m) = 1
Next
GoTo xia
End Select
End Function
Function TianChong5_1(x As Long, y As Long) As Boolean
Dim yy() As Byte
Select Case TianChong
Case 2
Exit Function
Case 36
TianChong6_1 1, 6
Exit Function
Case Else
xia:
ReDim yy(8)
i = 0
For m = 1 To 9
If f(x, y, m) = 1 Then
yy(i) = m
i = i + 1
End If
If i = 9 Then Exit Function
Next
aq = suiji(yy)
If f(x, y, 0) = 0 Then
f(x, y, 0) = aq
tcaq(x, y, aq) = 1
End If
TCJishu = TCJishu + 1
ReDim Preserve QingKong(TCJishu)
TianChong5_1 x + 1, y
If ChengGong = True Then Exit Function
For n = 1 To 9
For nn1 = 1 To 9
For n2 = 5 To 9
f(n, n2, nn1) = 0
Next
Next
Next
If f(x, y, 0) = aq Then f(x, y, 0) = 0
QingKong_1 (TCJishu)
TCJishu = TCJishu - 1
TCBiaoji
For m = 1 To 9
If tcaq(x, y, m) = 1 Then f(x, y, m) = 1
Next
GoTo xia
End Select
End Function
Function TianChong4_1(x As Long, y As Long) As Boolean
Dim yy() As Byte
Select Case TianChong
Case 2
Exit Function
Case 45
TianChong5_1 1, 5
Exit Function
Case Else
xia:
ReDim yy(8)
i = 0
For m = 1 To 9
If f(x, y, m) = 1 Then
yy(i) = m
i = i + 1
End If
If i = 9 Then Exit Function
Next
aq = suiji(yy)
If f(x, y, 0) = 0 Then
f(x, y, 0) = aq
tcaq(x, y, aq) = 1
End If
TCJishu = TCJishu + 1
ReDim Preserve QingKong(TCJishu)
TianChong4_1 x + 1, y
If ChengGong = True Then Exit Function
For n = 1 To 9
For nn1 = 1 To 9
For n2 = 4 To 9
f(n, n2, nn1) = 0
Next
Next
Next
If f(x, y, 0) = aq Then f(x, y, 0) = 0
QingKong_1 (TCJishu)
TCJishu = TCJishu - 1
TCBiaoji
For m = 1 To 9
If tcaq(x, y, m) = 1 Then f(x, y, m) = 1
Next
GoTo xia
End Select
End Function
Function TianChong3_1(x As Long, y As Long) As Boolean
Dim yy() As Byte
Select Case TianChong
Case 2
Exit Function
Case 54
TianChong4_1 1, 4
Exit Function
Case Else
xia:
ReDim yy(8)
i = 0
For m = 1 To 9
If f(x, y, m) = 1 Then
yy(i) = m
i = i + 1
End If
If i = 9 Then Exit Function
Next
aq = suiji(yy)
If f(x, y, 0) = 0 Then
f(x, y, 0) = aq
tcaq(x, y, aq) = 1
End If
TCJishu = TCJishu + 1
ReDim Preserve QingKong(TCJishu)
TianChong3_1 x + 1, y
If ChengGong = True Then Exit Function
For n = 1 To 9
For nn1 = 1 To 9
For n2 = 3 To 9
f(n, n2, nn1) = 0
Next
Next
Next
If f(x, y, 0) = aq Then f(x, y, 0) = 0
QingKong_1 (TCJishu)
TCJishu = TCJishu - 1
TCBiaoji
For m = 1 To 9
If tcaq(x, y, m) = 1 Then f(x, y, m) = 1
Next
GoTo xia
End Select
End Function
Function TianChong2_1(x As Long, y As Long) As Boolean
Dim yy() As Byte
Select Case TianChong
Case 2
Exit Function
Case 63
TianChong3_1 1, 3
Exit Function
Case Else
xia:
ReDim yy(8)
i = 0
For m = 1 To 9
If f(x, y, m) = 1 Then
yy(i) = m
i = i + 1
End If
If i = 9 Then Exit Function
Next
aq = suiji(yy)
If f(x, y, 0) = 0 Then
f(x, y, 0) = aq
tcaq(x, y, aq) = 1
End If
TCJishu = TCJishu + 1
ReDim Preserve QingKong(TCJishu)
TianChong2_1 x + 1, y
If ChengGong = True Then Exit Function
For n = 1 To 9
For nn1 = 1 To 9
For n2 = 2 To 9
f(n, n2, nn1) = 0
Next
Next
Next
If f(x, y, 0) = aq Then f(x, y, 0) = 0
QingKong_1 (TCJishu)
TCJishu = TCJishu - 1
TCBiaoji
For m = 1 To 9
If tcaq(x, y, m) = 1 Then f(x, y, m) = 1
Next
GoTo xia
End Select
End Function
Sub QingKong_1(Sz As Long)
Dim tmpSZ() As String
For n = Sz To UBound(QingKong)
tmpSZ = Split(QingKong(n), ",")
For n1 = 0 To UBound(tmpSZ) - 1
f(Int(Mid(tmpSZ(n1), 1, 1)), Int(Mid(tmpSZ(n1), 2, 1)), 0) = 0
Next
Next
End Sub
Function suiji(yy) As Long
Dim sj() As Long
Dim isY As Boolean
ReDim sj(0)
For n = 1 To UBound(yy) + 1
isY = False
For m = 0 To UBound(yy)
If yy(m) = n Then
isY = True
Exit For
End If
Next
If isY = False Then
sj(UBound(sj)) = n
ReDim Preserve sj(UBound(sj) + 1)
End If
Next
Randomize
suiji = sj(Int(UBound(sj) * Rnd))
End Function
联系客服
