module1.bas

关于国际象棋的VB示例

Attribute VB_Name = "Module1"
Option Explicit

Public Declare Function GetWindowsDirectory Lib "Kernel32" Alias "GetWindowsDirectoryA" (ByVal lpBuffer As String, ByVal nSize As Long) As Long
Public FoundWindows As String, ZSend As String
Public ZTop As Integer, ZLeft As Integer, ZWidth As Integer, ZHeight As Integer
Public AQZ_H As Integer, AQZ_M As Integer, AQZ_S As Integer, ZTempPath As String

' Object reference to the DLL that contains the resources to be loaded.
Public clsCTARS As Object
Public Const Indicator = ":':"

'UDP Port
Public Client As New Collection
Public Names As New Collection
Public RmIP As String, RmPt As String

'Sound
Public Declare Function sndPlaySound Lib "winmm.dll" Alias "sndPlaySoundA" (ByVal lpszSoundName As String, ByVal uFlags As Long) As Long
'  flag values for uFlags parameter
Public Const SND_SYNC = &H0         '  play synchronously (default)
Public Const SND_ASYNC = &H1         '  play asynchronously
Public Const SND_NODEFAULT = &H2         '  silence not default, if sound not found
Public Const SND_MEMORY = &H4         '  lpszSoundName points to a memory file
Public Const SND_ALIAS = &H10000     '  name is a WIN.INI [sounds] entry
Public Const SND_FILENAME = &H20000     '  name is a file name
Public Const SND_RESOURCE = &H40004     '  name is a resource name or atom
Public Const SND_ALIAS_ID = &H110000    '  name is a WIN.INI [sounds] entry identifier
Public Const SND_ALIAS_START = 0  '  must be > 4096 to keep strings in same section of resource file
Public Const SND_LOOP = &H8         '  loop the sound until next sndPlaySound
Public Const SND_NOSTOP = &H10        '  don't stop any currently playing sound
Public Const SND_VALID = &H1F        '  valid flags          / ;Internal /
Public Const SND_NOWAIT = &H2000      '  don't wait if the driver is busy
Public Const SND_VALIDFLAGS = &H17201F    '  Set of valid flag bits.  Anything outside
Public Const SND_RESERVED = &HFF000000  '  In particular these flags are reserved
Public Const SND_TYPE_MASK = &H170007

Public Declare Function GetWindow Lib "user32" (ByVal hWnd As Long, ByVal wCmd As Long) As Long
Public Declare Function GetDesktopWindow Lib "user32" () As Long
Public Declare Function GetWindowLW Lib "user32" Alias "GetWindowLongA" (ByVal hWnd As Long, ByVal nIndex As Long) As Long
Public Declare Function GetParent Lib "user32" (ByVal hWnd As Long) As Long
Public Declare Function GetClassName Lib "user32" Alias "GetClassNameA" (ByVal hWnd As Long, ByVal lpClassName As String, ByVal nMaxCount As Long) As Long
Public Declare Function GetWindowText Lib "user32" Alias "GetWindowTextA" (ByVal hWnd As Long, ByVal lpString As String, ByVal cch As Long) As Long
Public Const GWL_ID = (-12)
Public Const GW_HWNDNEXT = 2
Public Const GW_CHILD = 5

'My Defs
Public ZWhosTurn As Integer, ZRotated As Boolean, ZToggle As Integer, BoardFrom As Integer, BoardTo As Integer, BlackInCheck As Boolean, WhiteInCheck As Boolean, BlackCheckMate As Boolean, WhiteCheckMate As Boolean
Public LegalMove As Boolean, OpInProgress As Boolean, OpInProgress2 As Boolean, WhatPiece As String, BlackKingHasMoved As Boolean, WhiteKingHasMoved As Boolean
Public WhiteCanCastleKingSide As Boolean, WhiteCanCastleQueenSide As Boolean, BlackCanCastleKingSide As Boolean, BlackCanCastleQueenSide As Boolean, TriedToCastle As Boolean
Public ZBoardFrom As Integer, ZBoardTo As Integer, ZBoardFromTo As String, ZLastMove As String, ZGameInProcess As Boolean, ZMovingPiece As Boolean
Public ZGuestMode As Boolean, ZLastMessage As String
Public Const CWhite = 1
Public Const CBlack = 2


Public Sub SendOutIP()
On Local Error Resume Next
Err.Clear

'Send a text message to all clients in collection/listbox
Dim X As Integer

'Loop through all IP in listbox and get the right Users IP
For X = 0 To RJSoftChess.lName.ListCount - 1
    'Select each IP
    RJSoftChess.lName.ListIndex = X
    'Set IP and Port to send to
    RmIP = RJSoftChess.lName.Text
    RmPt = Client(RmIP)
    RJSoftChess.Wsck.RemoteHost = RmIP
    RJSoftChess.Wsck.RemotePort = RmPt
    'Send text message
    RJSoftChess.Wsck.SendData ZSend
Next
Err.Clear

End Sub

Public Sub FindPath()
On Local Error Resume Next
Err.Clear

Dim ZTempPath As String, X As Integer

ZTempPath = String(145, 0)
X = GetWindowsDirectory(ZTempPath, 145)
ZTempPath = Left(ZTempPath, X)

If Right(ZTempPath, 1) <> "\" Then
    FoundWindows = ZTempPath + "\"
Else
    FoundWindows = ZTempPath
End If

End Sub
Public Function CheckForLegalMove(XMove As Boolean)
On Local Error Resume Next
Err.Clear

Dim ZFrom As Integer, ZTo As Integer, ZFrom2 As Integer, ZTo2 As Integer, XY As Integer, Y As Integer, ZDirection As Long, ZTempKing As String

LegalMove = False
TriedToCastle = False

'Pawn
If WhatPiece = "PN" Then
    'check 2
    If (Abs(Int(BoardFrom / 8)) = 1) Or (Abs(Int(BoardFrom / 8)) = 6) Then
        If (Abs(BoardFrom - (Int(BoardFrom / 8) * 8) = Abs(BoardTo - (Int(BoardTo / 8) * 8)))) And (Abs(Int(BoardTo / 8) - Int(BoardFrom / 8)) = 2) And (RJSoftChess.Board(BoardTo).Tag = "") Then LegalMove = True
        If Abs(Int(BoardTo / 8) - Int(BoardFrom / 8)) > 2 Then Exit Function
     Else
        If Abs(Int(BoardTo / 8) - Int(BoardFrom / 8)) > 1 Then Exit Function
    End If
    'check 1
    If ZRotated = True Then
        If ZWhosTurn = CWhite Then
            If BoardTo < BoardFrom Then Exit Function
         Else
            If BoardFrom < BoardTo Then Exit Function
        End If
        If ZWhosTurn = CWhite Then
            If Abs(BoardFrom - (Int(BoardFrom / 8) * 8) = Abs(BoardTo - (Int(BoardTo / 8) * 8))) And (Int(BoardTo / 8) - Int(BoardFrom / 8)) = 1 Then LegalMove = True
            If BoardTo >= 56 And BoardTo <= 63 And XMove = True Then
                RJSoftChess.Board(BoardFrom).Picture = RJSoftChess.Master_White(1).Picture
                RJSoftChess.Board(BoardFrom).Tag = "WQU"
            End If
         Else
            If Abs(BoardFrom - (Int(BoardFrom / 8) * 8) = Abs(BoardTo - (Int(BoardTo / 8) * 8))) And (Int(BoardTo / 8) - Int(BoardFrom / 8)) = -1 Then LegalMove = True
            If BoardTo >= 0 And BoardTo <= 7 And XMove = True Then
                RJSoftChess.Board(BoardFrom).Picture = RJSoftChess.Master_Black(1).Picture
                RJSoftChess.Board(BoardFrom).Tag = "BQU"
            End If
        End If
     Else
        If ZWhosTurn = CWhite Then
            If BoardFrom < BoardTo Then Exit Function
         Else
            If BoardTo < BoardFrom Then Exit Function
        End If
        If ZWhosTurn = CWhite Then
            If Abs(BoardFrom - (Int(BoardFrom / 8) * 8) = Abs(BoardTo - (Int(BoardTo / 8) * 8))) And (Int(BoardTo / 8) - Int(BoardFrom / 8)) = -1 Then LegalMove = True
            If BoardTo >= 0 And BoardTo <= 7 And XMove = True Then
                RJSoftChess.Board(BoardFrom).Picture = RJSoftChess.Master_White(1).Picture
                RJSoftChess.Board(BoardFrom).Tag = "WQU"
            End If
         Else
            If Abs(BoardFrom - (Int(BoardFrom / 8) * 8) = Abs(BoardTo - (Int(BoardTo / 8) * 8))) And (Int(BoardTo / 8) - Int(BoardFrom / 8)) = 1 Then LegalMove = True
            If BoardTo >= 56 And BoardTo <= 63 And XMove = True Then
                RJSoftChess.Board(BoardFrom).Picture = RJSoftChess.Master_Black(1).Picture
                RJSoftChess.Board(BoardFrom).Tag = "BQU"
            End If
        End If
    End If
    'Can take the piece?
    If RJSoftChess.Board(BoardTo).Tag <> "" Then
        'Kill at angle
        If (Abs(BoardFrom - (Int(BoardFrom / 8) * 8)) + 1 = Abs(BoardTo - (Int(BoardTo / 8) * 8))) And (Abs(Int(BoardTo / 8) - Int(BoardFrom / 8)) > 0) Then LegalMove = True
        If (Abs(BoardFrom - (Int(BoardFrom / 8) * 8)) - 1 = Abs(BoardTo - (Int(BoardTo / 8) * 8))) And (Abs(Int(BoardTo / 8) - Int(BoardFrom / 8)) > 0) Then LegalMove = True
        'Can't kill head on.  Must be at an angle
        If Abs(BoardFrom - (Int(BoardFrom / 8) * 8)) - Abs(BoardTo - (Int(BoardTo / 8) * 8)) = 0 Then LegalMove = False
        If LegalMove = False Then
            'Must not be backwards
            If ZRotated = True Then
                If ZWhosTurn = CWhite Then
                    ZDirection = ((BoardFrom - BoardTo) / Abs(Int(BoardTo / 8) - Int(BoardFrom / 8)))
                    If ZDirection = 7 Or ZDirection = 9 Then LegalMove = False
                 Else
                    ZDirection = ((BoardFrom - BoardTo) / Abs(Int(BoardTo / 8) - Int(BoardFrom / 8)))
                    If ZDirection = -7 Or ZDirection = -9 Then LegalMove = False
                End If
             Else
                If ZWhosTurn = CWhite Then
                    ZDirection = ((BoardFrom - BoardTo) / Abs(Int(BoardTo / 8) - Int(BoardFrom / 8)))
                    If ZDirection = -7 Or ZDirection = -9 Then LegalMove = False
                 Else
                    ZDirection = ((BoardFrom - BoardTo) / Abs(Int(BoardTo / 8) - Int(BoardFrom / 8)))
                    If ZDirection = 7 Or ZDirection = 9 Then LegalMove = False
                End If
            End If
        End If
     Else
        If Abs(BoardFrom - (Int(BoardFrom / 8) * 8) = Abs(BoardTo - (Int(BoardTo / 8) * 8))) And (Abs(Int(BoardTo / 8) - Int(BoardFrom / 8))) = 2 Then
            'Can't move backwards
            If ZRotated = True Then
                If ZWhosTurn = CWhite Then
                    If RJSoftChess.Board(BoardTo - 8).Tag <> "" Then LegalMove = False
                 Else
                    If RJSoftChess.Board(BoardTo + 8).Tag <> "" Then LegalMove = False
                End If
             Else
                If ZWhosTurn = CWhite Then
                    If RJSoftChess.Board(BoardTo + 8).Tag <> "" Then LegalMove = False
                 Else
                    If RJSoftChess.Board(BoardTo - 8).Tag <> "" Then LegalMove = False
                End If
            End If
        End If
    End If
    GoTo TestMove
    Exit Function
End If

'Rook
If WhatPiece = "RK" Then
    If (Abs(BoardFrom - (Int(BoardFrom / 8) * 8)) = Abs(BoardTo - (Int(BoardTo / 8) * 8))) And (Abs(Int(BoardTo / 8) - Int(BoardFrom / 8)) > 0) Then
        LegalMove = True
        ZDirection = ((BoardFrom - BoardTo) / Abs(Int(BoardTo / 8) - Int(BoardFrom / 8)))
    End If
    If (Abs(BoardFrom - (Int(BoardFrom * 8) / 8)) = Abs(BoardTo - (Int(BoardTo * 8) / 8))) And (Abs(Int(BoardTo / 8) - Int(BoardFrom / 8)) = 0) Then
        LegalMove = True
        ZDirection = BoardFrom - BoardTo
    End If
    If LegalMove = True Then
        GoSub TestUpDownSideSide
        GoTo TestMove
    End If
    Exit Function
End If

'Knight
If WhatPiece = "KN" Then
    ZFrom = BoardFrom - (Int(BoardFrom / 8) * 8)
    ZTo = BoardTo - (Int(BoardTo / 8) * 8)
    ZFrom2 = Int(BoardFrom / 8)
    ZTo2 = Int(BoardTo / 8)
    'check 1 right 2 down
    If ZTo = ZFrom + 1 And ZTo2 = ZFrom2 + 2 Then LegalMove = True
    'check 2 right 1 down
    If ZTo = ZFrom + 2 And ZTo2 = ZFrom2 + 1 Then LegalMove = True
    'check 1 right 2 up
    If ZTo = ZFrom + 1 And ZTo2 = ZFrom2 - 2 Then LegalMove = True
    'check 2 right 1 up
    If ZTo = ZFrom + 2 And ZTo2 = ZFrom2 - 1 Then LegalMove = True
    'check 1 left 2 down
    If ZTo = ZFrom - 1 And ZTo2 = ZFrom2 + 2 Then LegalMove = True
    'check 1 left 2 up
    If ZTo = ZFrom - 1 And ZTo2 = ZFrom2 - 2 Then LegalMove = True
    'check 2 left 1 down
    If ZTo = ZFrom - 2 And ZTo2 = ZFrom2 + 1 Then LegalMove = True
    'check 2 left 1 up
    If ZTo = ZFrom - 2 And ZTo2 = ZFrom2 - 1 Then LegalMove = True
    GoTo TestMove
    Exit Function
End If

'Bishop
If WhatPiece = "BP" Then
    If Abs(Abs(BoardFrom - (Int(BoardFrom / 8) * 8)) - Abs(BoardTo - (Int(BoardTo / 8) * 8))) = Abs(Int(BoardTo / 8) - Int(BoardFrom / 8)) Then
        LegalMove = True
        GoSub TestAngle
        GoTo TestMove
    End If