Option Explicit
''Ｎ皇后互不攻击问题的回溯算法
Private Sub Command1_Click()
Dim n As Long
Dim i As Long, j As Long
Dim a() As Long
n = CLng(Text1.Text)
ReDim a(1 To n)
For i = 1 To n
a(i) = 1
Next
'*算法实现
'设ｉ－１个皇后已经放好，判断第ｉ个皇后的位置，如果和前面ｉ－１个中的任意一个有攻击，则该皇后向前走一步．
'直到放好为止，如果该行没有位置可放，则表示前ｉ－１个皇后的位置有问题，先将该第ｉ个皇后回到第一列，
'再回溯到第ｉ－１个皇后，将该皇后向前走一步，直到放好为止，如果不行，先将该皇后回一列，再回溯到第ｉ－２个皇后．
'如此，直到所有皇后放好为止．
'---------------------------------------------------------------------------------------------
For i = 2 To n
10:
If a(i) <= n Then
For j = 1 To i - 1
If a(j) = a(i) Or Abs(a(i) - a(j)) = i - j Then a(i) = a(i) + 1: GoTo 10
Next
If i = n Then MsgBox "有解" ''要求多解的话，可以再继续
Else
a(i) = 1
i = i - 1
a(i) = a(i) + 1
If i = 1 Then
If a(i) > n Then MsgBox "无解": Exit Sub
i = 2
End If
GoTo 10
End If
Next
'---------------------------------------------------------------------------------------------
grd.Rows = 0
grd.Cols = 0
grd.Rows = n + 1
grd.Cols = n + 1
For i = 0 To n
grd.TextMatrix(0, i) = i
grd.TextMatrix(i, 0) = i
grd.ColWidth(i) = 225
Next
For i = 1 To n
grd.TextMatrix(i, a(i)) = "*"
Next
End Sub