Option Explicit ''N皇后互不攻击问题的回溯算法
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
'*算法实现 '设i-1个皇后已经放好,判断第i个皇后的位置,如果和前面i-1个中的任意一个有攻击,则该皇后向前走一步. '直到放好为止,如果该行没有位置可放,则表示前i-1个皇后的位置有问题,先将该第i个皇后回到第一列, '再回溯到第i-1个皇后,将该皇后向前走一步,直到放好为止,如果不行,先将该皇后回一列,再回溯到第i-2个皇后. '如此,直到所有皇后放好为止. '--------------------------------------------------------------------------------------------- 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

|