八后棋(EightQueen)







列出組合



單組遊戲

這篇是小弟在論壇擔任版主時，
論壇上辦比賽活動，寫給會員參考用的程式。

Option Explicit  Dim xy(1 To 8, 1 To 8) As String  Dim i As Integer, j As Integer, k As Integer, cnt As Integer, rule As Integer, tot As Integer  Dim g As Integer, h As Integer  Dim tmpx As Integer, tmpy As Integer  Private Sub Check1_Click() '開關座標
    Text1.Visible = Not Text1.Visible
    Text3.Visible = Not Text3.Visible
End Sub
Private Sub Command1_MouseMove(Index As Integer, Button As Integer, Shift As Integer, X As Single, Y As Single) '座標效果
    With Command1(Index)
        Text1.Top = .Top + 220: Text1.Left = .Left - 3500
        Text3.Top = .Top - 3500: Text3.Left = .Left + 220
    End With  End Sub  Private Sub Command1_Click(Index As Integer) '單局八后棋
    judgequeen Index
    If cnt Mod 8 = 0 And rule = 0 Then
        Text2.Text = Text2.Text & "恭禧完成一組八后棋!!": cnt = 0
    ElseIf cnt Mod 8 = 4 And rule = 0 Then
        Text2.Text = Text2.Text & " 加油 ^^ 剩 " & 8 - cnt & Chr(13) & Chr(10)
    ElseIf cnt Mod 8 <> 0 And rule = 0 Then
        Text2.Text = Text2.Text & " 剩 " & 8 - cnt & Chr(13) & Chr(10)
    End If
End Sub
Private Sub Command2_Click() '列出組合清單  Dim i1 As Integer, j1 As Integer  Dim startime As Date
startime = Now
clsxyicon 1, 1  Text2.Text = "": Text2.Text = "開始時間 " & Format(Now, "hh:mm:ss") & Chr(13) & Chr(10)  Text2.Text = Text2.Text & "-------------------------------------------------" & Chr(13) & Chr(10)
tot = 0  For i = 1 To 8 '四面的組合都是一樣，只求一面即可
    tmpx = i: tmpy = 1: recxy
    For i1 = 1 To 8 '二元樹規範取得八后
        For j1 = 1 To 8
            tmpx = i1: tmpy = j1: recxy
            If rule = 0 Then '取得每一Y軸所有皇后的位置
                doxyicon
                If i1 = 8 Then '當X軸在8且又可放皇后則列出組合
                    calarrQ
                    If Check2.Value = 1 Then
                        Dim yn As Integer
                        yn = MsgBox("第 " & tot & " 組，是否繼續!!", vbYesNo)
                        If yn = vbNo Then cnt = 0: Exit Sub
                    End If
                    For k = 1 To 8
                        If xy(2, k) = "Q" Then
                            If k <= 8 Then GoTo once
                        End If
                    Next
                End If
                j1 = 8 '取得皇后讓程式省時不再往下算
            Else
once:
                If i1 > 1 And j1 = 8 Then 'Y軸沒有辦法放置皇后則退回前行X軸開始
                    If j1 = 8 And xy(i1 - 1, 8) = "Q" Then '算出前二行 X 軸 Y 軸起算值
                        i1 = i1 - 2
                    Else
                        i1 = i1 - 1 'Y 軸無法放則 X 軸再減一
                    End If
                    For k = 1 To 8
                        On Error GoTo endline '左子樹A8,B8無法再退，以錯誤離開二元樹
                        If xy(i1, k) = "Q" Then Exit For
                    Next
                    j1 = k
                    clsxyicon i1, 1 '清除皇后資訊
                End If
            End If
        Next
    Next  Next
endline:
clsxyicon 1, 1 '清除皇后資訊
cnt = 0
Text2.Text = Text2.Text & "-------------------------------------------------" & Chr(13) & Chr(10)
Text2.Text = Text2.Text & "結束時間 " & Format(Now, "hh:mm:ss") & Chr(13) & Chr(10)
Text2.Text = Text2.Text & "處理時間 " & DateDiff("s", startime, Now) & " 秒 ": Text2.SelStart = Len(Text2.Text)
End Sub
Private Sub Command3_Click() '清除再玩
    clsxyicon 1, 1
    Text2.Text = "": cnt = 0  End Sub  Private Sub calarrQ() '列出組合清單
For g = 1 To 8
    For h = 1 To 8
        If xy(g, h) = "Q" Then Text2.Text = Text2.Text & Chr(64 + g) & h & " "
    Next
Next
tot = tot + 1
Text2.Text = Text2.Text & " 第 " & tot & " 組 " & Chr(13) & Chr(10): Text2.SelStart = Len(Text2.Text)
End Sub
Private Sub doxyicon() '註記皇后資訊
    xy(tmpx, tmpy) = "Q"
    selicon (tmpy - 1) * 8 + tmpx  End Sub  Private Sub clsxyicon(clsx As Integer, clsy As Integer) '清除皇后資訊
    For g = clsx To 8
        For h = clsy To 8
            xy(g, h) = ""
            Command1((h - 1) * 8 + g).Picture = LoadPicture()
        Next
    Next
End Sub
Private Sub judgequeen(pstion As Integer) '單局八后棋
    If Mid(Text2.Text, 1, 1) = "開" Then
        Text2.Text = ""
        clsxyicon 1, 1
    End If
    calxy pstion
    recxy
    If rule = 0 Then
        doxyicon
        cnt = cnt + 1
        Text2.Text = Text2.Text & Chr(64 + tmpx) & tmpy & " "
    End If  End Sub  Private Sub calxy(pstion As Integer) '算出物件陣列所屬坐標
    If (pstion Mod 8) = 0 Then
        tmpx = 8: tmpy = pstion \ 8
    Else
        tmpx = pstion Mod 8: tmpy = pstion \ 8 + 1
    End If
End Sub
Private Sub selicon(iconno As Integer) '選擇皇后
    With Command1(iconno)
        If .BackColor = RGB(0, 0, 0) Then
            .Picture = Command1(65).Picture
        Else
            .Picture = Command1(0).Picture
        End If
        Text1.Top = .Top + 220: Text1.Left = .Left - 3500
        Text3.Top = .Top - 3500: Text3.Left = .Left + 220
    End With  End Sub  Private Sub recxy() '判斷米字範圍
    rule = 0
    For k = 1 To 8
        If rule = 1 Then Exit For
        If xy(k, tmpy) = "Q" Then rule = 1
        If xy(tmpx, k) = "Q" Then rule = 1
        If (tmpx + k > 0 And tmpx + k < 9) And (tmpy + k > 0 And tmpy + k < 9) Then
            If xy(tmpx + k, tmpy + k) = "Q" Then rule = 1
        End If
        If (tmpx - k > 0 And tmpx - k < 9) And (tmpy - k > 0 And tmpy - k < 9) Then
            If xy(tmpx - k, tmpy - k) = "Q" Then rule = 1
        End If
        If (tmpx + k > 0 And tmpx + k < 9) And (tmpy - k > 0 And tmpy - k < 9) Then
            If xy(tmpx + k, tmpy - k) = "Q" Then rule = 1
        End If
        If (tmpx - k > 0 And tmpx - k < 9) And (tmpy + k > 0 And tmpy + k < 9) Then
            If xy(tmpx - k, tmpy + k) = "Q" Then rule = 1
        End If
    Next

End Sub