I found some Code from here on the forums and have thus far tried to clean it up and make it work for me, but it's above my head.
Code:
Dim Turn As String
Dim myFrom As Integer, myCap As Integer, myTo As Intege
Private Sub Form_Load()
'set form to full screen
WindowState = 2
End Sub
Sub Cap_And_King()
'IDK what this is yet.
LM = LM + 1
Legal_Move_From(LM) = myFrom
Legal_Cap_One(LM) = myCap
Legal_Cap_Two(LM) = (I - FN * 3)
Legal_Move_To(LM) = myTo
intPriority(LM) = 9
Pawn_Pieces(myFrom).Priority = 9
Legal_Capture = True
Legal_Move = False
End Sub
Sub Check_Pos_Back(ByVal myI As Integer, myDir As Integer, myOpp As Integer)
Select Case Pawn_Pieces(myI + myDir).Colour
Case "WHITE", "RED", "RED_KING"
'DON'T MOVE
Case "NONE"
If (myI + myDir * 2) > 64 Then
'DO NOTHING
Else
If Pawn_Pieces(myI + myDir * 2).Colour = "" Then
'CAN'T MAKE THIS MOVE
Else
Select Case Pawn_Pieces(myI + myDir * 2).Colour
Case "RED", "RED_KING"
'DO NOTHING
Case "WHITE"
Call Backup_Move(myI, myDir, myOpp)
Case "NONE"
Select Case Pawn_Pieces(myI + myDir + myOpp).Colour
Case "WHITE"
LM = LM + 1
Legal_Move_From(LM) = (myI + myDir + myOpp)
Legal_Move_To(LM) = (myI + myDir)
intPriority(LM) = 5
Pawn_Pieces(myI).Priority = 5
Legal_Move = True
Case "NONE"
End Select
End Select
End If
End If
End Select
End Sub
Sub Check_Pos_Cap(ByVal myI As Integer, myDir As Integer, myOpp As Integer)
If (myI - myDir * 2) < 1 Then 'do nothing Else
If (myI - myDir * 2) >= 1 And (myI - myDir * 2) <= 8 Then
Select Case Pawn_Pieces(myI - myDir * 2).Colour
Case "NONE"
Call Cap_And_King(myI, (myI - myDir), (myI - myDir * 2))
End Select
Else
Select Case Pawn_Pieces(myI - myDir * 2).Colour
Case "NONE"
Call Normal_Cap(myI, myDir)
End Select
End If
End If
End Sub
Sub Check_Pos_Evasive(ByVal myI As Integer, myDir As Integer, myOpp As Integer)
Select Case (myI - myDir)
Case 16, 17, 32, 33, 48, 49, 64
Select Case Pawn_Pieces(myI - myDir).Colour
Case "NONE"
LM = LM + 1
Legal_Move_From(LM) = myI
Legal_Move_To(LM) = myI - myOpp
intPriority(LM) = 4
Pawn_Pieces(myI).Priority = 4
Legal_Move = True
Case Else
'THERE IS NOTHING YOU CAN DO
End Select
Case Else
Select Case Pawn_Pieces(myI - myDir).Colour
Case "NONE"
Select Case Pawn_Pieces(myI - myDir * 2).Colour
Case "NONE", "WHITE"
Select Case Pawn_Pieces(myI - myOpp - myDir).Colour
Case "NONE", "WHITE"
Call Normal_Move(myI, myDir)
Case "RED", "RED_KING"
Call Last_Resort(myI, myDir)
End Select
Case "RED", "RED_KING"
Call Last_Resort(myI, myDir)
End Select
End Select
End Select
End Sub
Sub Check_Pos_Move(ByVal myI As Integer, myDir As Integer, myOpp As Integer)
If (myI - myDir * 2) < 1 Then
'DO NOTHING
Else
Select Case Pawn_Pieces(myI - myDir * 2).Colour
'*********** THIRD MOVE
Case "NONE", "WHITE"
Select Case Pawn_Pieces(myI - myDir - myOpp).Colour
'******************* FOURTH MOVE
Case "NONE", "WHITE"
Call Normal_Move(myI, myOpp)
Case "RED", "RED_KING"
Call Last_Resort(myI, myOpp)
End Select
Case "RED", "RED_KING"
Call Last_Resort(myI, myOpp)
End Select
End If
End Sub
Public Sub Check_Red_Legal(ByVal MF As Integer, MT As Integer)
intR = MT - MF
Select Case Pawn_Pieces(MF).Colour
Case "RED_KING"
Select Case intR
Case -7, -9, 7, 9
If Pawn_Pieces(MT).Colour = "NONE" Then
B(MT).Picture = LoadResPicture(Kleur + 2, 0)
Pawn_Pieces(MT).Colour = "RED_KING"
Red_Legal_Move = True
Else
Red_Legal_Move = False
End If
Case -14, -18, 14, 18
If Pawn_Pieces(MT).Colour = "NONE" Then
B(MT).Picture = LoadResPicture(Kleur + 2, 0)
Pawn_Pieces(MT).Colour = "RED_KING"
If Pawn_Pieces(MF + (intR / 2)).Colour = "WHITE" Then
RedCap = MF + (intR / 2)
Red_Legal_Cap = True
Red_Legal_Move = False
End If
End If
Case 28
Case 36
Case 42
Case 54
End Select
Case "RED"
Select Case intR
Case 7, 9
If Pawn_Pieces(MT).Colour = "NONE" Then
If MT >= 57 And MT <= 64 Then
B(MT).Picture = LoadResPicture(Kleur + 2, 0)
Pawn_Pieces(MT).Colour = "RED_KING"
Else
B(MT).Picture = LoadResPicture(Kleur, 0)
Pawn_Pieces(MT).Colour = strKleur
End If
Red_Legal_Move = True
Else
Red_Legal_Move = False
End If
Case 14, 18
If Pawn_Pieces(MT).Colour = "NONE" Then
If MT >= 57 And MT <= 64 Then
B(MT).Picture = LoadResPicture(Kleur + 2, 0)
Pawn_Pieces(MT).Colour = "RED_KING"
Else
B(MT).Picture = LoadResPicture(Kleur, 0)
Pawn_Pieces(MT).Colour = strKleur
End If
If Pawn_Pieces(MF + (intR / 2)).Colour = "WHITE" Then
RedCap = MF + (intR / 2)
Red_Legal_Cap = True
Red_Legal_Move = False
End If
End If
Case 28
Case 36
Case 42
Case 54
End Select
End Select
End Sub
Sub First_Move(ByVal myI As Integer, myFN As Integer, myON As Integer, myStep As Integer)
If myStep <> 0 Then
For myNum = myFN To myON Step myStep
Call Select_MyNum(myNum)
Select Case Pawn_Pieces(myI - myNum).Colour
'******************* FIRST MOVE
Case "NONE"
Select Case (myI - myNum)
Case 17, 32, 33, 48, 49
If Pawn_Pieces(myI - myNum - Opp_MyNum).Colour = "RED" Or Pawn_Pieces(myI - myNum - Opp_MyNum).Colour = "RED_KING" Then
Call To_Side(myI, (myNum))
Else
Call Normal_Move(myI, (myNum))
End If
End Select
If (myI - myNum) >= 1 And (myI - myNum) <= 8 Then
Call Move_King(myI, (myNum))
Else
Select Case Pawn_Pieces(myI - myNum * 2).Colour
'******************************* SECOND MOVE
Case "NONE", "WHITE"
Select Case Pawn_Pieces(myI - myNum - Opp_MyNum).Colour
'*************************************** THIRD MOVE
Case "NONE", "WHITE"
XX = myNum
Call Normal_Move(myI, (myNum))
Case "RED", "RED_KING"
Select Case (myI - myNum + Opp_MyNum)
Case "RED", "WHITE", "RED_KING"
Call Normal_Move(myI, (myNum))
End Select
Select Case (myI - myNum)
Case 17, 32, 33, 48, 49
Call To_Side(myI, (myNum))
Case Else
Call Last_Resort(myI, (myNum))
End Select
End Select
'******************************* SECOND MOVE
Case "RED", "RED_KING"
If (myI + myNum) > 64 Then
'DO NOTHING
ElseIf Pawn_Pieces(myI + myNum).Colour = "WHITE" Then
'DON'T MOVE THIS PIECE
Else
Call Last_Resort(myI, (myNum))
End If
End Select
End If
'******************* FIRST MOVE
Case "RED", "RED_KING"
If myI >= 57 And myI <= 64 Then
'DON'T MOVE THIS PIECE
Else
Call Check_Pos_Cap(myI, (myNum), (Opp_MyNum))
Call Check_Pos_Back(myI, (myNum), (Opp_MyNum))
Call Check_Pos_Evasive(myI, (myNum), Opp_MyNum)
End If
End Select
Next myNum
Else
For myNum = myFN To myON
Call Select_MyNum(myNum)
Select Case Pawn_Pieces(myI - myNum).Colour
'******************* FIRST MOVE
Case "NONE"
Select Case (myI - myNum)
Case 17, 32, 33, 48, 49
If Pawn_Pieces(myI - myNum - Opp_MyNum).Colour = "RED" Or Pawn_Pieces(myI - myNum - Opp_MyNum).Colour = "RED_KING" Then
Call To_Side(myI, (myNum))
Else
Call Normal_Move(myI, (myNum))
End If
End Select
If (myI - myNum) >= 1 And (myI - myNum) <= 8 Then
Call Move_King(myI, (myNum))
Else
Select Case Pawn_Pieces(myI - myNum * 2).Colour
'******************************* SECOND MOVE
Case "NONE", "WHITE"
Select Case Pawn_Pieces(myI - myNum - Opp_MyNum).Colour
'*************************************** THIRD MOVE
Case "NONE", "WHITE"
XX = myNum
Call Normal_Move(myI, (myNum))
Case "RED", "RED_KING"
Select Case (myI - myNum + Opp_MyNum)
Case "RED", "WHITE", "RED_KING"
Call Normal_Move(myI, (myNum))
End Select
Select Case (myI - myNum)
Case 17, 32, 33, 48, 49
Call To_Side(myI, (myNum))
Case Else
Call Last_Resort(myI, (myNum))
End Select
End Select
'******************************* SECOND MOVE
Case "RED", "RED_KING"
If (myI + myNum) > 64 Then
'DO NOTHING
ElseIf Pawn_Pieces(myI + myNum).Colour = "WHITE" Then
'DON'T MOVE THIS PIECE
Else
Call Last_Resort(myI, (myNum))
End If
End Select
End If
'******************* FIRST MOVE
Case "RED", "RED_KING"
If myI >= 57 And myI <= 64 Then
'DON'T MOVE THIS PIECE
Else
Call Check_Pos_Cap(myI, (myNum), (Opp_MyNum))
Call Check_Pos_Back(myI, (myNum), (Opp_MyNum))
Call Check_Pos_Evasive(myI, (myNum), Opp_MyNum)
End If
End Select
Next myNum
End If
End Sub
Public Sub Load_Board() '**************************************************** ' LOAD AND PLACE FIRST ROW OF RED PEICES ONTO BOARD '**************************************************** For I = 1 To 8 Step 2
B(I).Picture = LoadResPicture(100, 0)
Pawn_Pieces(I).Color = "RED"
B(I).Left = B(I - 1).Left + B(I).Width
Next I
'LOAD AND PLACE SECOND ROW OF RED PEICES ONTO BOARD
For I = 10 To 16 Step 2
B(I).Picture = LoadResPicture(100, 0)
Pawn_Pieces(I).Colour = "RED"
Next I
'LOAD AND PLACE FIRST ROW OF WHITE PEICES ONTO BOARD
For I = 49 To 55 Step 2
B(I).Picture = LoadResPicture(200, 0)
Pawn_Pieces(I).Colour = "WHITE"
Next I
'LOAD AND PLACE SECOND ROW OF WHITE PEICES ONTO BOARD
For I = 58 To 64 Step 2
B(I).Picture = LoadResPicture(200, 0)
Pawn_Pieces(I).Colour = "WHITE"
Next I
Turn = "Your Turn"
MsgBox = Turn
End Sub
Public Sub Move_Pawn(skuif)
B(Legal_Move_From(skuif)).Picture = LoadResPicture(201, 0) 'DON'T FORGET TO ACTIVATE LATER
Dim PauseTime, Start, Finish, TotalTime
PauseTime = 1 ' Set duration.
Start = Timer ' Set start time.
Do While Timer < Start + PauseTime
MousePointer = 11
Me.Caption = "White's Turn"
DoEvents ' Yield to other processes.
Loop
Finish = Timer ' Set end time.
TotalTime = Finish - Start ' Calculate total time.
MousePointer = 0
'**********************************************************************
If Legal_Move_To(skuif) < 8 Then
B(Legal_Move_To(skuif)).Picture = LoadResPicture(202, 0)
Pawn_Pieces(Legal_Move_To(skuif)).Colour = "WHITE_KING"
Else
B(Legal_Move_To(skuif)).Picture = LoadResPicture(200, 0)
Pawn_Pieces(Legal_Move_To(skuif)).Colour = "WHITE"
End If
B(Legal_Move_From(skuif)).Picture = Nothing
Pawn_Pieces(Legal_Move_From(skuif)).Color = "NONE"
Turn = "Your Turn"
End Sub
Sub Cap_Pawn(skuif)
B(Legal_Move_From(skuif)).Picture = LoadResPicture(201, 0)
'DON'T FORGET TO ACTIVATE LATER
Dim PauseTime, Start, Finish, TotalTime
PauseTime = 1 ' Set duration.
Start = Timer ' Set start time.
Do While Timer < Start + PauseTime
MousePointer = 11
Me.Caption = "White's Turn"
DoEvents ' Yield to other processes.
Loop
Finish = Timer ' Set end time.
TotalTime = Finish - Start ' Calculate total time.
MousePointer = 0
'**********************************************************************
If Legal_Move_To(skuif) < 8 Then
B(Legal_Move_To(skuif)).Picture = LoadResPicture(202, 0)
Pawn_Pieces(Legal_Move_To(skuif)).Colour = "WHITE_KING"
Else
B(Legal_Move_To(skuif)).Picture = LoadResPicture(200, 0)
Pawn_Pieces(Legal_Move_To(skuif)).Colour = "WHITE"
End If
B(Legal_Cap_One(skuif)).Picture = Nothing
B(Legal_Cap_Two(skuif)).Picture = Nothing
B(Legal_Move_From(skuif)).Picture = Nothing
Pawn_Pieces(Legal_Move_From(skuif)).Color = "NONE"
Pawn_Pieces(Legal_Cap_One(skuif)).Color = "NONE"
If Pawn_Pieces(Legal_Cap_Two(skuif)).Color = "RED" Then
Pawn_Pieces(Legal_Cap_Two(skuif)).Color = "NONE"
intRCap = intRCap + 1
RC(intRCap).Picture = LoadResPicture(100, 0)
End If
Turn = "Your Turn"
intRCap = intRCap + 1
RC(intRCap).Picture = LoadResPicture(100, 0)
Check_End_Game
End Sub
Sub Check_End_Game()
If intWCap = 8 Then
MsgBox "You are the winner!!", vbExclamation, "CONGRATULATIONS"
intRCap = 0
intWCap = 0
Else
If intRCap = 8 Then
MsgBox "Sorry, you loose!!", vbExclamation, "CONDOLENCES"
intRCap = 0
intWCap = 0
End If
End Sub
Sub Make_Move()
intOne = 0
intTwo = 0
intThree = 0
intFour = 0
intFive = 0
intSix = 0
intSeven = 0
intEight = 0
intNine = 0
intTen = 0
For I = 1 To LM
Select Case intPriority(I)
Case 10
intTen = intTen + 1
intJ(intTen) = I
Case 9
intNine = intNine + 1
intI(intNine) = I
Case 8
intEight = intEight + 1
intH(intEight) = I
Case 7
intSeven = intSeven + 1
intG(intSeven) = I
Case 6
intSix = intSix + 1
intF(intSix) = I
Case 5
intFive = intFive + 1
intE(intFive) = I
Case 4
intFour = intFour + 1
intD(intFour) = I
Case 3
intThree = intThree + 1
intC(intThree) = I
Case 2
intTwo = intTwo + 1
intB(intTwo) = I
Case 1
intOne = intOne + 1
intA(intOne) = I
End Select
Next I
If intTen > 0 Then
Randomize
myValue = Int(intTen * Rnd) + 1
Cap_Pawn (intJ(myValue))
ElseIf intNine > 0 Then
Randomize
myValue = Int(intNine * Rnd) + 1
Cap_Pawn (intI(myValue))
ElseIf intEight > 0 Then
Randomize
myValue = Int(intEight * Rnd) + 1
Cap_Pawn (intH(myValue))
ElseIf intSeven > 0 Then
Randomize
myValue = Int(intSeven * Rnd) + 1
Move_Pawn (intG(myValue))
ElseIf intSix > 0 Then
Randomize
myValue = Int(intSix * Rnd) + 1
Cap_Pawn (intF(myValue))
ElseIf intFive > 0 Then
Randomize
myValue = Int(intFive * Rnd) + 1
Move_Pawn (intE(myValue))
ElseIf intFour > 0 Then
Randomize
myValue = Int(intFour * Rnd) + 1
Move_Pawn (intD(myValue))
ElseIf intThree > 0 Then
Randomize
myValue = Int(intThree * Rnd) + 1
Move_Pawn (intC(myValue))
ElseIf intTwo > 0 Then
Randomize
myValue = Int(intTwo * Rnd) + 1
Move_Pawn (intB(myValue))
ElseIf intOne > 0 Then
Randomize
myValue = Int(intOne * Rnd) + 1
Move_Pawn (intA(myValue))
End If
End Sub
Public Function GetCol(Index)
GetCol = B(Index).Left / B(Index).Width + 1
End Function
Sub Normal_Cap(ByVal I As Integer, FN As Integer)
LM = LM + 1
Legal_Move_From(LM) = I
Legal_Cap_One(LM) = (I - FN)
Legal_Cap_Two(LM) = (I - FN * 3)
Legal_Move_To(LM) = (I - FN * 2)
intPriority(LM) = 6
Pawn_Pieces(I).Priority = 6
Legal_Capture = True
Legal_Move = False
End Sub
Sub Normal_Move(I As Integer, FN As Integer)
LM = LM + 1
Legal_Move_From(LM) = I
Legal_Move_To(LM) = I - FN
intPriority(LM) = 2
Pawn_Pieces(I).Priority = 2
Legal_Move = True
End Sub
Sub Move_King(I As Integer, FN As Integer)
'LM = LM + 1 Legal_Move_From(LM) = I Legal_Move_To(LM) = I - FN intPriority(LM) = 7 Pawn_Pieces(I).Priority = 7 Legal_Move = True
End Sub
Sub Last_Resort(ByVal I As Integer, FN As Integer)
'LM = LM + 1 Legal_Move_From(LM) = I Legal_Move_To(LM) = I - FN intPriority(LM) = 1 Pawn_Pieces(I).Priority = 1 Legal_Move = True
End Sub
Sub Evasive_Move(ByVal I As Integer, Opp As Integer)
'LM = LM + 1 Legal_Move_From(LM) = I Legal_Move_To(LM) = I - Opp intPriority(LM) = 4 Pawn_Pieces(I).Priority = 4 Legal_Move = True
End Sub
Sub To_Side(ByVal I As Integer, FN As Integer)
'LM = LM + 1 Legal_Move_From(LM) = I Legal_Move_To(LM) = I - FN intPriority(LM) = 3 Pawn_Pieces(I).Priority = 3 Legal_Move = True
End Sub
Sub Backup_Move(ByVal I As Integer, FN As Integer, Opp As Integer)
'LM = LM + 1 Legal_Move_From(LM) = (I + FN * 2) Legal_Move_To(LM) = I + FN intPriority(LM) = 5 Pawn_Pieces(I).Priority = 5 Legal_Move = True
End Sub
Private Sub B_Click(Index As Integer)
'intMove_Counter = intMove_Counter + 1
Click = Click + 1
MyCurCol = GetCol(Index)
MyCurRow = GetRow(Index)
MyCurIndex = Index
Select Case Click
Case 1
MoveFrom = Index
If Turn = "White's Turn" Then
Kleur = 200
strKleur = "WHITE"
Else
Kleur = 100
strKleur = "RED"
End If
Select Case Pawn_Pieces(Index).Colour
Case "RED_KING"
B(MoveFrom).Picture = LoadResPicture(Kleur + 3, 0)
Case "WHITE", ""
Click = 0
Exit Sub
Case Else
B(MoveFrom).Picture = LoadResPicture(Kleur + 1, 0)
End Select
Case 2
If Pawn_Pieces(Index).Colour <> "NONE" Then
Click = 1
Exit Sub
End If
MoveTo = Index
'*************CHECK TO SEE IF YOU CLICKED THE SAME PIECE TWICE**************
If MoveTo = MoveFrom Then
B(MoveFrom).Picture = LoadResPicture(Kleur, 0)
Click = 0
Exit Sub
End If
Red_Legal_Cap = False
Red_Legal_Move = False
Call Check_Red_Legal(MoveFrom, MoveTo)
If Red_Legal_Move = True Then
B(MoveFrom).Picture = Nothing
Pawn_Pieces(MoveFrom).Colour = "NONE"
Click = 0
ElseIf Red_Legal_Cap = True Then
B(MoveFrom).Picture = Nothing
B(RedCap).Picture = Nothing
Pawn_Pieces(RedCap).Colour = "NONE"
Pawn_Pieces(MoveFrom).Colour = "NONE"
Click = 0
intWCap = intWCap + 1
WC(intWCap).Picture = LoadResPicture(200, 0)
Check_End_Game
Else
MsgBox "NOT A LEGAL MOVE!", vbCritical
Select Case Pawn_Pieces(MoveFrom).Colour
Case "RED_KING"
B(MoveFrom).Picture = LoadResPicture(Kleur + 2, 0)
Case "RED"
B(MoveFrom).Picture = LoadResPicture(Kleur, 0)
End Select
Click = 0
Exit Sub
End If
End Select
If Click = 1 Then Else
Select Case Turn
Case "Your Turn"
Turn = "White's Turn"
For I = 1 To 64
Pawn_Pieces(I).Priority = 0
Next I
LM = 0
For I = 1 To 64
If Pawn_Pieces(I).Colour = "WHITE" Then
Select Case I
Case 1, 17, 33, 49 'No -9 and -18
Call First_Move(I, 7, 7, 0)
Case 16, 32, 48, 64 ' no -7 and -14
Call First_Move(I, 9, 9, 0)
Case Else
Call First_Move(I, 9, 7, -2)
End Select
ElseIf Pawn_Pieces(I).Colour = "WHITE_KING" Then
Select Case I
' Case 1, 17, 33, 49 'No -9 and -18 ' Call First_Move(I, 7, 7, 0) ' Case 16, 32, 48, 64 ' no -7 and -14 ' Call First_Move(I, 9, 9, 0) ' Case Else ' Call First_Move(I, 9, 7, -2)
End Select
End If
Next I
Call Make_Move
Case "White's Turn"
Turn = "Your Turn"
End Select
End If
Me.Caption = Turn
End Sub
Sub B_MouseMove(Index As Integer, Button As Integer, Shift As Integer, X As Single, Y As Single)
'MyCurCol = GetCol(Index) MyCurRow = GetRow(Index) MyCurIndex = Index myCurColour = Pawn_Pieces(Index).Colour
'MyCol = B(MyCurIndex).Colour 'If MyCol = "NONE" Then lblXY = "Col = " & MyCurCol & vbNewLine & _
'Row = & MyCurRow & vbNewLine & _
'Index = & MyCurIndex & vbNewLine & _
'Colour = & myCurColour
' 'Else ' myking = B(MyCurIndex).Tag ' If myking = "" Then ' myking = "No King" ' Else ' myking = "King" ' End If ' lblXY = "Col = " & MyCurCol & vbNewLine & _ ' "Row = " & MyCurRow & vbNewLine & _ ' "Index = " & MyCurIndex & vbNewLine & _ ' "Colour = " & MyCol & vbNewLine & _ ' "King = " & myking ' ' 'End If
End Sub
Public Function GetRow(Index)
'GetRow = B(Index).Top / B(Index).Height + 1
End Function
Private Sub Form_Load()
'Legal_Move = False
For I = 17 To 23 Step 2
Pawn_Pieces(I).Colour = "NONE"
Next I
For I = 26 To 32 Step 2
Pawn_Pieces(I).Colour = "NONE"
Next I
For I = 33 To 39 Step 2
Pawn_Pieces(I).Colour = "NONE"
Next I
For I = 42 To 48 Step 2
Pawn_Pieces(I).Colour = "NONE"
Next I
Load_Board
End Sub
Login
Register
FAQ
Search
). It might seem like you're taking a shortcut, but all too often it ends up not being.
).
)