VERSION 5.00
Begin VB.Form Form1
BackColor = &H00FFFFFF&
BorderStyle = 1 'Fixed Single
Caption = "InternationalChess"
ClientHeight = 8145
ClientLeft = 45
ClientTop = 690
ClientWidth = 13005
BeginProperty Font
Name = "宋体"
Size = 10.5
Charset = 134
Weight = 400
Underline = 0 'False
Italic = 0 'False
Strikethrough = 0 'False
EndProperty
Icon = "Form1.frx":0000
LinkTopic = "Form1"
MaxButton = 0 'False
ScaleHeight = 543
ScaleMode = 3 'Pixel
ScaleWidth = 867
StartUpPosition = 2 '屏幕中心
Begin VB.TextBox Text1
Appearance = 0 'Flat
Height = 360
Left = 0
TabIndex = 3
Top = 7800
Width = 12900
End
Begin VB.ListBox List2
Appearance = 0 'Flat
Height = 7380
Left = 9600
TabIndex = 2
Top = 300
Width = 3300
End
Begin VB.ListBox List1
Appearance = 0 'Flat
Height = 7380
Left = 7800
TabIndex = 1
Top = 300
Width = 1800
End
Begin VB.PictureBox Picture1
AutoRedraw = -1 'True
BorderStyle = 0 'None
Height = 7800
Left = 0
ScaleHeight = 520
ScaleMode = 3 'Pixel
ScaleWidth = 520
TabIndex = 0
Top = 0
Width = 7800
Begin VB.Image p
Height = 855
Index = 32
Left = 0
Top = 0
Width = 855
End
Begin VB.Image p
Height = 855
Index = 31
Left = 0
Top = 0
Width = 855
End
Begin VB.Image p
Height = 855
Index = 30
Left = 0
Top = 0
Width = 855
End
Begin VB.Image p
Height = 855
Index = 29
Left = 0
Top = 0
Width = 855
End
Begin VB.Image p
Height = 855
Index = 28
Left = 0
Top = 0
Width = 855
End
Begin VB.Image p
Height = 855
Index = 27
Left = 0
Top = 0
Width = 855
End
Begin VB.Image p
Height = 855
Index = 26
Left = 0
Top = 0
Width = 855
End
Begin VB.Image p
Height = 855
Index = 25
Left = 0
Top = 0
Width = 855
End
Begin VB.Image p
Height = 855
Index = 24
Left = 0
Top = 0
Width = 855
End
Begin VB.Image p
Height = 855
Index = 23
Left = 0
Top = 0
Width = 855
End
Begin VB.Image p
Height = 855
Index = 22
Left = 0
Top = 0
Width = 855
End
Begin VB.Image p
Height = 855
Index = 21
Left = 0
Top = 0
Width = 855
End
Begin VB.Image p
Height = 855
Index = 20
Left = 0
Top = 0
Width = 855
End
Begin VB.Image p
Height = 855
Index = 19
Left = 0
Top = 0
Width = 855
End
Begin VB.Image p
Height = 855
Index = 18
Left = 0
Top = 0
Width = 855
End
Begin VB.Image p
Height = 855
Index = 17
Left = 0
Top = 0
Width = 855
End
Begin VB.Image p
Height = 855
Index = 16
Left = 0
Top = 0
Width = 855
End
Begin VB.Image p
Height = 855
Index = 15
Left = 0
Top = 0
Width = 855
End
Begin VB.Image p
Height = 855
Index = 14
Left = 0
Top = 0
Width = 855
End
Begin VB.Image p
Height = 855
Index = 13
Left = 0
Top = 0
Width = 855
End
Begin VB.Image p
Height = 855
Index = 12
Left = 0
Top = 0
Width = 855
End
Begin VB.Image p
Height = 855
Index = 11
Left = 0
Top = 0
Width = 855
End
Begin VB.Image p
Height = 855
Index = 10
Left = 0
Top = 0
Width = 855
End
Begin VB.Image p
Height = 855
Index = 9
Left = 0
Top = 0
Width = 855
End
Begin VB.Image p
Height = 855
Index = 8
Left = 0
Top = 0
Width = 855
End
Begin VB.Image p
Height = 855
Index = 7
Left = 0
Top = 0
Width = 855
End
Begin VB.Image p
Height = 855
Index = 6
Left = 0
Top = 0
Width = 855
End
Begin VB.Image p
Height = 855
Index = 5
Left = 0
Top = 0
Width = 855
End
Begin VB.Image p
Height = 855
Index = 4
Left = 0
Top = 0
Width = 855
End
Begin VB.Image p
Height = 855
Index = 3
Left = 0
Top = 0
Width = 855
End
Begin VB.Image p
Height = 855
Index = 2
Left = 0
Top = 0
Width = 855
End
Begin VB.Image p
Height = 855
Index = 1
Left = 0
Top = 0
Width = 855
End
End
Begin VB.Menu menuFile
Caption = "文件(&F)"
Begin VB.Menu menuNew
Caption = "新建"
Shortcut = ^N
End
Begin VB.Menu menuOpen
Caption = "打开"
Shortcut = ^O
End
Begin VB.Menu menuSave
Caption = "保存"
Shortcut = ^S
End
Begin VB.Menu Separator1
Caption = "-"
End
Begin VB.Menu menuExit
Caption = "退出"
End
End
Begin VB.Menu menuOption
Caption = "选项(&O)"
Begin VB.Menu menuCopyFEN
Caption = "复制局面"
Shortcut = {F7}
End
Begin VB.Menu menuPasteFEN
Caption = "粘贴局面"
Shortcut = {F8}
End
Begin VB.Menu Separator3
Caption = "-"
End
Begin VB.Menu menuChangeColor
Caption = "更改颜色"
End
Begin VB.Menu menuRotate
Caption = "旋转棋盘"
Shortcut = ^R
End
Begin VB.Menu menuMoveControl
Caption = "显示移动路径"
Checked = -1 'True
End
End
Begin VB.Menu menuAI
Caption = "人工智能(&A)"
Begin VB.Menu menuShowRed
Caption = "显示白方招法"
Shortcut = ^W
End
Begin VB.Menu menuShowBlack
Caption = "显示黑方招法"
Shortcut = ^B
End
Begin VB.Menu menuAutoGo
Caption = "电脑自动走棋"
Shortcut = ^{F5}
End
Begin VB.Menu menuShowDetails
Caption = "显示局面信息"
End
Begin VB.Menu Separator2
Caption = "-"
End
Begin VB.Menu menuUseEngine
Caption = "使用引擎"
Shortcut = {F9}
End
Begin VB.Menu menuEngineSetting
Caption = "引擎设置"
Shortcut = ^{F9}
End
End
Begin VB.Menu menuHelp
Caption = "帮助(&H)"
Begin VB.Menu menuChessDB
Caption = "国际象棋云库查询"
End
Begin VB.Menu menuStockfish
Caption = "Stockfish引擎协议"
End
Begin VB.Menu Separator4
Caption = "-"
End
Begin VB.Menu menuAbout
Caption = "关于"
End
End
End
Attribute VB_Name = "Form1"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = False
Option Explicit
Private Declare Function PlaySound Lib "winmm.dll" Alias "PlaySoundA" (lpszName As Any, ByVal hModule As Long, ByVal dwFlags As Long) As Long
Private Declare Function timeGetTime Lib "winmm.dll" () As Long
Private Declare Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As Long)
Private Const SND_SYNC = &H0 ' play synchronously (default)
Private Const SND_ASYNC = &H1 ' play asynchronously
Private Const SND_NODEFAULT = &H2 ' silence not default, if sound not found
Private Const SND_MEMORY = &H4 ' lpszSoundName points to a memory file
Private Const SND_ALIAS = &H10000 ' name is a WIN.INI [sounds] entry
Private Const SND_FILENAME = &H20000 ' name is a file name
Private Const SND_RESOURCE = &H40004 ' name is a resource name or atom
Private Const SND_ALIAS_ID = &H110000 ' name is a WIN.INI [sounds] entry identifier
Private Const SND_ALIAS_START = 0 ' must be > 4096 to keep strings in same section of resource file
Private Const SND_LOOP = &H8 ' loop the sound until next sndPlaySound
Private Const SND_NOSTOP = &H10
Private Type CHOOSECOLOR
lStructSize As Long
hwndOwner As Long
hInstance As Long
rgbResult As Long
lpCustColors As String
Flags As Long
lCustData As Long
lpfnHook As Long
lpTemplateName As String
End Type
Private Declare Function CHOOSECOLOR Lib "comdlg32.dll" Alias "ChooseColorA" (pChoosecolor As CHOOSECOLOR) As Long
Private Const GridWidth As Integer = 60
Private QiziSize As Integer
Private color1 As Long, color2 As Long
Private Reg As RegExp, All As MatchCollection, Every As Match
Private FSO As Scripting.FileSystemObject
Private txt As Scripting.TextStream
Private jscode As String
Private IHDoc1 As MSHTML.IHTMLDocument
Private pW1 As MSHTML.IHTMLWindow2
Private IHDoc2 As MSHTML.IHTMLDocument
Private pW2 As MSHTML.IHTMLWindow2
Private X As MSXML2.XMLHTTP60
Private steps As Integer
Private FEN As String
Private FEN0 As String
Private FenCol() As Variant
Private Matrix(1 To 8, 1 To 8) As String
Private Indexes(1 To 8, 1 To 8) As Integer
Private MoveListCol() As String
Private KQkqCol() As String
Private enpassantCol() As String
Private Flag As Boolean
Private Rotated As Boolean
Private 红先 As Boolean
Private wb As String
Private KQkq As String
Private enpassant As String
Private Const QiZi As String = "rnbqkpRNBQKP"
Private images(1 To 12) As stdole.IPictureDisp
Private NewGame() As Byte
Private Draw() As Byte
Private Click() As Byte
Private Move2() As Byte
Private Capture() As Byte
Private Illegal() As Byte
Private First As image
Private Second As image
Private Promote As String
Private r1 As Integer, c1 As Integer, r2 As Integer, c2 As Integer
Private WS As WshShell
Private WE As WshExec
Private SI As IWshRuntimeLibrary.TextStream
Private SO As IWshRuntimeLibrary.TextStream
Private Sub Form_Load()
On Error GoTo Err1:
Dim b() As Byte
Dim S1 As ADODB.Stream
color1 = vbYellow
QiziSize = 56
LoadImage
DrawQipan
NewGame = VB.LoadResData(301, "CUSTOM") 'NewGame.wav
Draw = VB.LoadResData(302, "CUSTOM") 'Draw.wav
Click = VB.LoadResData(303, "CUSTOM") 'Click.wav
Move2 = VB.LoadResData(304, "CUSTOM") 'Move2.wav
Capture = VB.LoadResData(305, "CUSTOM") 'Capture.wav
Illegal = VB.LoadResData(306, "CUSTOM") 'Illegal.wav
'b = VB.LoadResData(201, "CUSTOM") 'UTF-8
b = VB.LoadResData(202, "CUSTOM") 'ANSI
' Set S1 = New ADODB.Stream
' With S1
' .Type = adTypeBinary
' .Mode = adModeReadWrite
' .open
' .Write b
' .position = 0
' .Type = adTypeText
' .Charset = "utf-8"
' jscode = .ReadText
' .Close
' End With
' Set S1 = Nothing
jscode = StrConv(b, vbUnicode, &H804)
Set IHDoc1 = New MSHTML.HTMLDocument
Set pW1 = IHDoc1.parentWindow
IHDoc1.Write "<script>" & jscode & "</script>"
EnginePath = GetSetting(App.ProductName, "Engine", "EnginePath", "")
Protocol = GetSetting(App.ProductName, "Engine", "Protocol", "uci")
Options = GetSetting(App.ProductName, "Engine", "Options", "")
GoCommand = GetSetting(App.ProductName, "Engine", "Go", "go depth 18")
Wait = CSng(GetSetting(App.ProductName, "Engine", "Wait", "3"))
MatchString = GetSetting(App.ProductName, "Engine", "MatchString", "info depth * multipv 1 * pv *")
menuNew_Click
Exit Sub
Err1:
MsgBox Err.Description, vbCritical
End Sub
Private Sub DrawQipan()
Dim r As Integer
Dim c As Integer
Dim i As Integer
Me.Picture1.Cls
Me.Picture1.BackColor = color1
color2 = OppColor(color1)
For i = 1 To 8 Step 2
Me.Picture1.Line (i * GridWidth + 20, 20)-(i * GridWidth + GridWidth + 20, 8 * GridWidth + 20), color2, BF
Next i
Me.Picture1.DrawMode = vbInvert
For i = 1 To 8 Step 2
Me.Picture1.Line (20, i * GridWidth + 20)-(8 * GridWidth + 20, i * GridWidth + GridWidth + 20), color2, BF
Next
Me.Picture1.DrawMode = vbCopyPen
Me.Picture1.DrawWidth = 2
Me.Picture1.Line (20, 20)-(8 * GridWidth + 20, 20), vbBlack
Me.Picture1.Line (20, 8 * GridWidth + 20)-(8 * GridWidth + 20, 8 * GridWidth + 20), vbBlack
Me.Picture1.Line (20, 20)-(20, 8 * GridWidth + 20), vbBlack
Me.Picture1.Line (8 * GridWidth + 20, 20)-(8 * GridWidth + 20, 8 * GridWidth + 20), vbBlack
Me.Picture1.DrawWidth = 1
If Rotated Then
For c = 1 To 8
Me.Picture1.CurrentX = GridWidth * c - 10: Me.Picture1.CurrentY = 4: Me.Picture1.Print Chr(Asc("h") - c + 1)
Next c
For r = 1 To 8
Me.Picture1.CurrentX = 8 * GridWidth + 20: Me.Picture1.CurrentY = r * GridWidth - 16: Me.Picture1.Print r
Next r
Else
For c = 1 To 8
Me.Picture1.CurrentX = GridWidth * c - 10: Me.Picture1.CurrentY = 8 * GridWidth + 20: Me.Picture1.Print Chr(Asc("a") + c - 1)
Next c
For r = 1 To 8
Me.Picture1.CurrentX = 4: Me.Picture1.CurrentY = r * GridWidth - 16: Me.Picture1.Print 9 - r
Next r
End If
End Sub
Private Function OppColor(ByVal Color As Long) As Long
Dim Red As Integer, Green As Integer, Blue As Integer
Red = Color And &HFF '拆分颜色
Green = (Color And 65280) \ 256
Blue = (Color And &HFF0000) \ 65536
Red = 255 - Red
Green = 255 - Green
Blue = 255 - Blue
If Red < 0 Then Red = 0
If Red > 255 Then Red = 255
If Green < 0 Then Green = 0
If Green > 255 Then Green = 255
If Blue < 0 Then Blue = 0
If Blue > 255 Then Blue = 255
OppColor = RGB(Red, Green, Blue) '得到反色
End Function
Private Sub Form_Terminate()
QuitEngine
PlaySound Draw(0), 0&, SND_MEMORY Or SND_ASYNC
End Sub
Private Sub List2_Click()
On Error GoTo Err1:
Dim Move As String
If Me.List2.ListIndex >= 1 Then
Move = Split(Me.List2.Text, vbTab)(0)
r1 = 9 - CInt(Mid(Move, 2, 1))
c1 = Asc(Mid(Move, 1, 1)) - Asc("a") + 1
r2 = 9 - CInt(Mid(Move, 4, 1))
c2 = Asc(Mid(Move, 3, 1)) - Asc("a") + 1
If Len(Move) = 5 Then
Promote = Right(Move, 1)
End If
Call Go(r1, c1, r2, c2)
End If
Exit Sub
Err1:
MsgBox Err.Description, vbCritical
End Sub
Private Sub menuAbout_Click()
On Error GoTo Err1:
Dim v As Variant
v = Array("作者：刘永富【ryueifu】", "邮箱：32669315@qq.com", "抖音号：ryueifu", "中国象棋棋谱浏览器QQ群：291644972", "", "产品名称：" & App.ProductName, "更新日期：2024年1月3日")
MsgBox Join(v, vbNewLine), vbInformation, "产品信息 & 联系方式"
Exit Sub
Err1:
MsgBox Err.Description, vbCritical
End Sub
Private Sub menuChangeColor_Click()
Dim Result As Long
Dim pChoosecolor As CHOOSECOLOR
Dim CustomColor() As Byte
With pChoosecolor
.hwndOwner = Me.hWnd
.lpCustColors = StrConv(CustomColor, vbUnicode)
.Flags = 0
.lStructSize = Len(pChoosecolor)
End With
Result = CHOOSECOLOR(pChoosecolor)
If Result > 0 Then
color1 = pChoosecolor.rgbResult
End If
DrawQipan
End Sub
Private Sub LoadImage()
On Error GoTo Err1
Dim b() As Byte
Dim i As Integer
For i = 1 To 12
b = VB.LoadResData(100 + i, "CUSTOM")
Open App.Path & "\temp.gif" For Binary Access Write As #1
Put #1, , b
Close #1
Set images(i) = LoadPicture(App.Path & "\temp.gif")
Next i
Kill App.Path & "\temp.gif"
Exit Sub
Err1:
MsgBox Err.Description, vbCritical
End Sub
Private Sub menuChessDB_Click()
OpenUrl "http://www.chessdb.cn/cloudbookc_api.html"
End Sub
Private Sub menuCopyFEN_Click()
With Clipboard
.Clear
.SetText FEN & " " & wb & " " & KQkq & " " & enpassant & " 0 1", VBRUN.ClipBoardConstants.vbCFText
End With
End Sub
Private Sub menuExit_Click()
Unload Me
End Sub
Private Sub menuMoveControl_Click()
Me.menuMoveControl.Checked = Not Me.menuMoveControl.Checked
End Sub
Private Sub menuNew_Click()
On Error GoTo Err1
FEN = "rnbqkbnr/pppppppp/8/8/8/8/PPPPPPPP/RNBQKBNR"
红先 = True
wb = "w"
KQkq = "KQkq"
enpassant = "-"
PasteFEN
PlaySound NewGame(0), 0&, SND_MEMORY Or SND_ASYNC
Exit Sub
Err1:
MsgBox Err.Description, vbCritical
End Sub
Private Sub PasteFEN()
On Error GoTo Err1
Set First = Nothing
FenToArray
ReDim FenCol(0 To 0)
FenCol(0) = Matrix
ReDim MoveListCol(1 To 1)
ReDim KQkqCol(0 To 0)
ReDim enpassantCol(0 To 0)
KQkqCol(0) = KQkq
enpassantCol(0) = enpassant
Me.List1.Clear
Me.List1.AddItem "回合." & vbTab & "棋 谱"
Me.List1.ListIndex = 0
FEN0 = FEN & " " & wb & " " & KQkq & " " & enpassant & " 0 1"
FenToLayout
Exit Sub
Err1:
MsgBox Err.Description, vbCritical
End Sub
Private Sub FenToLayout()
On Error GoTo Err1
Dim r As Integer
Dim c As Integer
Dim i As Integer
Dim p As String
Dim img As image
For i = 1 To 32
Set img = Me.p.Item(i)
img.Move -100, -100
img.BorderStyle = VBRUN.BorderStyleConstants.vbTransparent
Next i
Erase Indexes
i = 1
For r = 1 To 8
For c = 1 To 8
p = Matrix(r, c)
If p = "o" Then
Else
Set img = Me.p.Item(i)
Indexes(r, c) = i
UpdateImage img, p
If Rotated Then
img.Move 20 + GridWidth * (9 - c) - GridWidth / 2 - QiziSize / 2, 20 + GridWidth * (9 - r) - GridWidth / 2 - QiziSize / 2
Else
img.Move 20 + GridWidth * c - GridWidth / 2 - QiziSize / 2, 20 + GridWidth * r - GridWidth / 2 - QiziSize / 2
End If
i = i + 1
End If
Next c
Next r
Exit Sub
Err1:
MsgBox Err.Description, vbCritical
End Sub
Private Sub UpdateImage(image As VB.image, p As String)
Dim i As Integer
i = InStr(QiZi, p)
Set image.Picture = images(i)
If i <= 6 Then
image.Tag = "b"
Else
image.Tag = "w"
End If
End Sub
Private Sub FenToArray()
Dim r As Integer
Dim c As Integer
Dim f As String
f = 加空(FEN)
Erase Matrix
For r = 1 To 8
For c = 1 To 8
Matrix(r, c) = Mid(f, (r - 1) * 9 + c, 1)
Next c
Next r
End Sub
Private Sub ArrayToFen()
Dim r As Integer
Dim c As Integer
FEN = String(71, "/")
For r = 1 To 8
For c = 1 To 8
Mid(FEN, (r - 1) * 9 + c, 1) = Matrix(r, c)
Next c
Next r
FEN = 去空(FEN)
End Sub
Private Sub menuOpen_Click()
On Error GoTo Err1:
Dim FileName As String
Dim i As Integer
Dim s As String
Dim MoveListCol() As String
FileName = OpenDialog(Me.hWnd, Replace("棋谱文件(*.txt)|*.txt|所有文件(*.*)|*.*|", "|", Chr(0)))
If FileName = "" Then
Else
Open FileName For Input As #1
Line Input #1, s
Close #1
Me.menuAutoGo.Checked = False
Me.menuShowRed.Checked = False
Me.menuShowBlack.Checked = False
Me.menuShowDetails.Checked = False
FEN = Split(s, " ")(0)
wb = Split(s, " ")(1)
If wb = "w" Then
红先 = True
ElseIf wb = "b" Then
红先 = False
End If
KQkq = Split(s, " ")(2)
enpassant = Split(s, " ")(3)
PasteFEN
If InStr(s, "moves") > 0 Then
MoveListCol = Split(Split(s, "moves")(1), " ")
steps = UBound(MoveListCol)
For i = 1 To steps
ExecuteMove MoveListCol(i)
Next i
End If
Me.List1.ListIndex = 0
End If
Exit Sub
Err1:
MsgBox Err.Description, vbCritical
End Sub
Private Sub menuPasteFEN_Click()
On Error GoTo Err1:
Dim s As String
With Clipboard
s = .GetText(Format:=VBRUN.ClipBoardConstants.vbCFText)
End With
FEN = Split(s, " ")(0)
wb = Split(s, " ")(1)
If wb = "w" Then
红先 = True
ElseIf wb = "b" Then
红先 = False
End If
KQkq = Split(s, " ")(2)
enpassant = Split(s, " ")(3)
PasteFEN
Exit Sub
Err1:
MsgBox Err.Description, vbCritical
End Sub
Private Sub menuRotate_Click()
Me.menuRotate.Checked = Not Me.menuRotate.Checked
Rotated = Me.menuRotate.Checked
DrawQipan
FenToLayout
End Sub
Private Sub menuSave_Click()
On Error GoTo Err1
Dim FileName As String
Dim s As String
FileName = SaveDialog(Me.hWnd, Replace("棋谱文件(*.txt)|*.txt|所有文件(*.*)|*.*|", "|", Chr(0)))
If FileName = "" Then
Else
If UBound(MoveListCol) = 0 Then
s = FEN0
Else
s = FEN0 & " moves " & Join(MoveListCol, " ")
End If
Open FileName For Output As #1
Print #1, s
Close #1
End If
Exit Sub
Err1:
MsgBox Err.Description, vbCritical
End Sub
Private Sub menuShowDetails_Click()
Me.menuShowDetails.Checked = Not Me.menuShowDetails.Checked
If Me.menuShowDetails.Checked Then
ShowDetails
End If
End Sub
Private Sub menuShowRed_Click()
Me.menuShowRed.Checked = Not Me.menuShowRed.Checked
If wb = "w" And Me.menuShowRed.Checked Then
AI
End If
End Sub
Private Sub menuShowBlack_Click()
Me.menuShowBlack.Checked = Not Me.menuShowBlack.Checked
If wb = "b" And Me.menuShowBlack.Checked Then
AI
End If
End Sub
Private Sub menuAutoGo_Click()
Me.menuAutoGo.Checked = Not Me.menuAutoGo.Checked
If wb = "w" And Me.menuShowRed.Checked Or wb = "b" And Me.menuShowBlack.Checked Then
AI
End If
End Sub
Private Sub menuStockfish_Click()
OpenUrl "https://github.com/official-stockfish/Stockfish/wiki/UCI-&-Commands"
End Sub
Private Sub p_Click(index As Integer)
On Error GoTo Err1:
If First Is Nothing Then
If Me.p.Item(index).Tag = wb Then
Set First = Me.p.Item(index)
c1 = (First.Left - 20 + QiziSize / 2 + GridWidth / 2) / GridWidth
r1 = (First.Top - 20 + QiziSize / 2 + GridWidth / 2) / GridWidth
If Rotated Then
c1 = 9 - c1
r1 = 9 - r1
End If
First.BorderStyle = VBRUN.BorderStyleConstants.vbBSSolid
PlaySound Click(0), 0&, SND_MEMORY Or SND_ASYNC
End If
Else
If Me.p.Item(index).Tag = wb Then
First.BorderStyle = VBRUN.BorderStyleConstants.vbTransparent
Set First = Nothing
Else
Set Second = Me.p.Item(index)
c2 = (Second.Left - 20 + QiziSize / 2 + GridWidth / 2) / GridWidth
r2 = (Second.Top - 20 + QiziSize / 2 + GridWidth / 2) / GridWidth
If Rotated Then
c2 = 9 - c2
r2 = 9 - r2
End If
If Movable(FEN, wb, KQkq, enpassant, r1, c1, r2, c2) Then
Call Go(r1, c1, r2, c2)
Else
First.BorderStyle = VBRUN.BorderStyleConstants.vbTransparent
Set First = Nothing
PlaySound Illegal(0), 0&, SND_MEMORY Or SND_ASYNC
End If
End If
End If
Exit Sub
Err1:
MsgBox Err.Description, vbCritical
End Sub
Private Sub Picture1_MouseDown(Button As Integer, Shift As Integer, X As Single, Y As Single)
On Error GoTo Err1
c2 = Int((X - 20) / GridWidth) + 1: r2 = Int((Y - 20) / GridWidth) + 1
If First Is Nothing Then
ElseIf c2 < 1 Or c2 > 8 Or r2 < 1 Or r2 > 8 Then
Else
If Rotated Then
c2 = 9 - c2
r2 = 9 - r2
End If
If Movable(FEN, wb, KQkq, enpassant, r1, c1, r2, c2) Then
Call Go(r1, c1, r2, c2)
Else
First.BorderStyle = VBRUN.BorderStyleConstants.vbTransparent
Set First = Nothing
PlaySound Illegal(0), 0&, SND_MEMORY Or SND_ASYNC
End If
End If
Exit Sub
Err1:
MsgBox Err.Description, vbCritical
End Sub
Private Sub ExecuteMove(m5 As String)
On Error GoTo Err1:
Dim r1 As Integer, c1 As Integer, r2 As Integer, c2 As Integer
Dim i As Integer
Dim j As Integer
Dim qipu As String
i = Me.List1.ListIndex + 1
ReDim Preserve FenCol(0 To i)
ReDim Preserve MoveListCol(1 To i)
ReDim Preserve KQkqCol(0 To i)
ReDim Preserve enpassantCol(0 To i)
MoveListCol(i) = m5
r1 = 9 - CInt(Mid(m5, 2, 1)): c1 = Asc(Mid(m5, 1, 1)) - Asc("a") + 1: r2 = 9 - CInt(Mid(m5, 4, 1)): c2 = Asc(Mid(m5, 3, 1)) - Asc("a") + 1
enpassant = "-"
If Matrix(r1, c1) Like "[pP]" And Abs(r1 - r2) = 2 Then '兵进两步
enpassant = Mid(m5, 1, 1) & CStr((CInt(Mid(m5, 2, 1)) + CInt(Mid(m5, 4, 1))) / 2) 'movelist的平均值
End If
If Matrix(r1, c1) Like "[pP]" And Matrix(r2, c2) = "o" And Abs(c1 - c2) = 1 Then '吃过路兵
Me.p.Item(Indexes(r1, c2)).Move -100, -100
Matrix(r1, c2) = "o"
Indexes(r1, c2) = 0
End If
Matrix(r2, c2) = Matrix(r1, c1)
Matrix(r1, c1) = "o"
Indexes(r2, c2) = Indexes(r1, c1)
Indexes(r1, c1) = 0
If Len(m5) = 5 Then '底兵升变
Promote = Right(m5, 1)
Matrix(r2, c2) = Promote
UpdateImage Me.p.Item(Indexes(r2, c2)), Promote
Promote = ""
End If
If Matrix(r2, c2) = "k" And r1 = 1 And c1 = 5 And r2 = r1 And c2 = c1 + 2 Then '王车易位
Matrix(1, 6) = Matrix(1, 8): Matrix(1, 8) = "o"
Indexes(1, 6) = Indexes(1, 8): Indexes(1, 8) = 0
If Rotated Then
Me.p.Item(Indexes(1, 6)).Move 20 + GridWidth * (9 - 6) - GridWidth / 2 - QiziSize / 2, 20 + GridWidth * (9 - 1) - GridWidth / 2 - QiziSize / 2
Else
Me.p.Item(Indexes(1, 6)).Move 20 + GridWidth * 6 - GridWidth / 2 - QiziSize / 2, 20 + GridWidth * 1 - GridWidth / 2 - QiziSize / 2
End If
ElseIf Matrix(r2, c2) = "k" And r1 = 1 And c1 = 5 And r2 = r1 And c2 = c1 - 2 Then
Matrix(1, 4) = Matrix(1, 1): Matrix(1, 1) = "o"
Indexes(1, 4) = Indexes(1, 1): Indexes(1, 1) = 0
If Rotated Then
Me.p.Item(Indexes(1, 4)).Move 20 + GridWidth * (9 - 4) - GridWidth / 2 - QiziSize / 2, 20 + GridWidth * (9 - 1) - GridWidth / 2 - QiziSize / 2
Else
Me.p.Item(Indexes(1, 4)).Move 20 + GridWidth * 4 - GridWidth / 2 - QiziSize / 2, 20 + GridWidth * 1 - GridWidth / 2 - QiziSize / 2
End If
ElseIf Matrix(r2, c2) = "K" And r1 = 8 And c1 = 5 And r2 = r1 And c2 = c1 + 2 Then
Matrix(8, 6) = Matrix(8, 8): Matrix(8, 8) = "o"
Indexes(8, 6) = Indexes(8, 8): Indexes(8, 8) = 0
If Rotated Then
Me.p.Item(Indexes(8, 6)).Move 20 + GridWidth * (9 - 6) - GridWidth / 2 - QiziSize / 2, 20 + GridWidth * (9 - 8) - GridWidth / 2 - QiziSize / 2
Else
Me.p.Item(Indexes(8, 6)).Move 20 + GridWidth * 6 - GridWidth / 2 - QiziSize / 2, 20 + GridWidth * 8 - GridWidth / 2 - QiziSize / 2
End If
ElseIf Matrix(r2, c2) = "K" And r1 = 8 And c1 = 5 And r2 = r1 And c2 = c1 - 2 Then
Matrix(8, 4) = Matrix(8, 1): Matrix(8, 1) = "o"
Indexes(8, 4) = Indexes(8, 1): Indexes(8, 1) = 0
If Rotated Then
Me.p.Item(Indexes(8, 4)).Move 20 + GridWidth * (9 - 4) - GridWidth / 2 - QiziSize / 2, 20 + GridWidth * (9 - 8) - GridWidth / 2 - QiziSize / 2
Else
Me.p.Item(Indexes(8, 4)).Move 20 + GridWidth * 4 - GridWidth / 2 - QiziSize / 2, 20 + GridWidth * 8 - GridWidth / 2 - QiziSize / 2
End If
End If
If InStr(m5, "e8") > 0 Then
KQkq = Replace(KQkq, "k", ""): KQkq = Replace(KQkq, "q", "")
End If
If InStr(m5, "h8") > 0 Then
KQkq = Replace(KQkq, "k", "")
End If
If InStr(m5, "a8") > 0 Then
KQkq = Replace(KQkq, "q", "")
End If
If InStr(m5, "e1") > 0 Then
KQkq = Replace(KQkq, "K", ""): KQkq = Replace(KQkq, "Q", "")
End If
If InStr(m5, "h1") > 0 Then
KQkq = Replace(KQkq, "K", "")
End If
If InStr(m5, "a1") > 0 Then
KQkq = Replace(KQkq, "Q", "")
End If
If KQkq = "" Then
KQkq = "-"
End If
FenCol(i) = Matrix
KQkqCol(i) = KQkq
enpassantCol(i) = enpassant
If i = Me.List1.ListCount Then
Else
For j = i To Me.List1.ListCount - 1
Me.List1.RemoveItem i
Next j
End If
qipu = m5
If 红先 And (i Mod 2 = 1) Or 红先 = False And (i Mod 2 = 0) Then
Me.List1.AddItem i \ 2 + 1 & "." & vbTab & qipu
Else
Me.List1.AddItem " " & vbTab & qipu
End If
Flag = True
Me.List1.ListIndex = i '只更新FEN，不更新画面
Flag = False
Exit Sub
Err1:
MsgBox Err.Description, vbCritical
End Sub
Private Sub Go(r1 As Integer, c1 As Integer, r2 As Integer, c2 As Integer)
On Error GoTo Err1:
Dim i As Integer
Set First = Me.p.Item(Indexes(r1, c1))
If Matrix(r2, c2) = "o" Then
Set Second = Nothing
Else
Set Second = Me.p.Item(Indexes(r2, c2))
End If
First.BorderStyle = VBRUN.BorderStyleConstants.vbTransparent
If Matrix(r1, c1) = "p" And r2 = 8 Then '升变
If Promote = "" Then
Promote = InputBox("选择升变棋子[qrnb]", "升变", "q")
If Promote Like "[qrnb]" Then
Else
Set First = Nothing
Promote = ""
Exit Sub
End If
End If
ElseIf Matrix(r1, c1) = "P" And r2 = 1 Then '升变
If Promote = "" Then
Promote = InputBox("选择升变棋子[QRNB]", "升变", "Q")
If Promote Like "[QRNB]" Then
Else
Set First = Nothing
Promote = ""
Exit Sub
End If
End If
End If
If Rotated Then
If Me.menuMoveControl.Checked Then
MoveControl First, 20 + GridWidth * (9 - c2) - GridWidth / 2 - QiziSize / 2, 20 + GridWidth * (9 - r2) - GridWidth / 2 - QiziSize / 2
End If
First.Move 20 + GridWidth * (9 - c2) - GridWidth / 2 - QiziSize / 2, 20 + GridWidth * (9 - r2) - GridWidth / 2 - QiziSize / 2
Else
If Me.menuMoveControl.Checked Then
MoveControl First, 20 + GridWidth * c2 - GridWidth / 2 - QiziSize / 2, 20 + GridWidth * r2 - GridWidth / 2 - QiziSize / 2
End If
First.Move 20 + GridWidth * c2 - GridWidth / 2 - QiziSize / 2, 20 + GridWidth * r2 - GridWidth / 2 - QiziSize / 2
End If
If Second Is Nothing Then
PlaySound Move2(0), 0&, SND_MEMORY Or SND_ASYNC
Else
Second.Move -100, -100
PlaySound Capture(0), 0&, SND_MEMORY Or SND_ASYNC
End If
Set First = Nothing
Set Second = Nothing
ExecuteMove Chr((c1 - 1) + Asc("a")) & (9 - r1) & Chr((c2 - 1) + Asc("a")) & (9 - r2) & Promote
Exit Sub
Err1:
MsgBox Err.Description, vbCritical
End Sub
Private Sub MoveControl(img As VB.image, x2 As Double, y2 As Double)
Dim x1 As Double, y1 As Double
Dim i As Double
Dim s As Double
Dim v As Double
Dim count As Double
img.ZOrder 0
x1 = img.Left: y1 = img.Top
s = Sqr((x1 - x2) ^ 2 + (y1 - y2) ^ 2)
v = 10
count = s / v
For i = 1 To count
Delay 10
img.Move x1 + i * v * (x2 - x1) / s, y1 + i * v * (y2 - y1) / s
Next i
End Sub
Private Sub Delay(Interval As Long)
Dim Savetime As Long
Savetime = timeGetTime()
While timeGetTime < Savetime + Interval
DoEvents
Wend
End Sub
Private Sub List1_Click()
On Error GoTo Err1:
Dim i As Integer
Dim r As Integer
Dim c As Integer
Dim v As Variant
i = Me.List1.ListIndex
v = FenCol(i)
For r = 1 To 8
For c = 1 To 8
Matrix(r, c) = v(r, c)
Next c
Next r
ArrayToFen
If Flag = False Then
FenToLayout
End If
If i Mod 2 = 0 And 红先 Or i Mod 2 = 1 And 红先 = False Then
wb = "w"
Else
wb = "b"
End If
KQkq = KQkqCol(i)
enpassant = enpassantCol(i)
Me.Text1.Text = FEN & " " & wb & " " & KQkq & " " & enpassant & " 0 1"
If Me.menuShowDetails.Checked Then
ShowDetails
End If
Me.List2.Clear
If wb = "w" And Me.menuShowRed.Checked Or wb = "b" And Me.menuShowBlack.Checked Then
Delay 1000
AI
End If
Exit Sub
Err1:
MsgBox Err.Description, vbCritical
End Sub
Private Function GetSource(url As String) As String
On Error GoTo Err1:
Set X = New MSXML2.XMLHTTP60
With X
.open "GET", url, False
.send
GetSource = .ResponseText
End With
Exit Function
Err1:
GetSource = Err.Description
End Function
Private Sub AI()
Me.Picture1.Enabled = False
Me.List1.Enabled = False
Me.List2.Enabled = False
If Me.menuUseEngine.Checked Then
GoEngine
Else
queryall
End If
Me.Picture1.Enabled = True
Me.List1.Enabled = True
Me.List2.Enabled = True
End Sub
Private Sub ShowDetails()
On Error GoTo Err1:
Dim FEN1 As String
Dim ResponseText As String
Dim Msg As String
FEN1 = FEN & " " & wb & " " & KQkq & " " & enpassant & " 0 1"
ResponseText = GetSource("http://www.chessdb.cn/cdb.php?action=queryall&learn=1&showall=0&board=" & FEN1)
If ResponseText Like "move:*" Then
ElseIf ResponseText Like "invalid board*" Then
Msg = Msg & "非法局面 "
ElseIf ResponseText Like "checkmate*" Then
Msg = Msg & "绝杀 "
ElseIf ResponseText Like "stalemate*" Then
Msg = Msg & "逼和 "
ElseIf ResponseText Like "unknown*" Then
End If
ResponseText = GetSource("http://www.chessdb.cn/cdb.php?action=querypv&learn=1&board=" & FEN1)
If InStr(ResponseText, "pv:") > 0 Then
Msg = Msg & " " & ResponseText
End If
If Msg = "" Then
Else
Me.Text1.Text = Msg
End If
Exit Sub
Err1:
MsgBox Err.Description, vbCritical
End Sub
Private Sub queryall()
On Error GoTo Err1
Dim FEN1 As String
Dim movelist As String
Dim ResponseText As String
Dim moves As Variant
Dim v As Variant
Dim token As Long
FEN1 = FEN & " " & wb & " " & KQkq & " " & enpassant & " 0 1"
If wb = "w" Then
Me.List2.ForeColor = vbRed
Else
Me.List2.ForeColor = vbBlack
End If
ResponseText = GetSource("http://www.chessdb.cn/cdb.php?action=queryall&learn=1&showall=0&board=" & FEN1)
If ResponseText Like "move:*" Then
moves = Split(ResponseText, "|")
Set Reg = New RegExp
With Reg
.Global = False
.IgnoreCase = True
.Pattern = "move:([a-z1-8]+),score:(.+),rank:(.+),note:(.+)"
Me.List2.Clear
Me.List2.AddItem "move" & vbTab & "score" & vbTab & "rank" & vbTab & "note"
For Each v In moves
Set All = .Execute(CStr(v))
Set Every = All.Item(0)
Me.List2.AddItem Every.SubMatches(0) & vbTab & Every.SubMatches(1) & vbTab & Every.SubMatches(2) & vbTab & Every.SubMatches(3)
Next v
If Me.menuAutoGo.Checked Then
Me.List2.ListIndex = 1
End If
End With
ElseIf ResponseText Like "unknown*" Then '"unknown" & Chr(0)
token = CLng(pW1.get_token(FEN1))
ResponseText = GetSource("http://www.chessdb.cn/cdb.php?action=queryengine&board=" & FEN1 & "&movelist=&token=" & token)
Me.List2.Clear
Set Reg = New RegExp
With Reg
.Global = False
.IgnoreCase = True
.Pattern = "move:([a-z1-8]+)"
Set All = .Execute(ResponseText)
Set Every = All.Item(0)
End With
Me.List2.AddItem "move"
Me.List2.AddItem Every.SubMatches(0)
If Me.menuAutoGo.Checked Then
Me.List2.ListIndex = 1
End If
End If
Exit Sub
Err1:
MsgBox Err.Description, vbCritical
End Sub
Private Sub menuUseEngine_Click()
On Error GoTo Err1
Dim L As String
Me.menuUseEngine.Checked = Not Me.menuUseEngine.Checked
If Me.menuUseEngine.Checked Then
If EnginePath = "" Then
menuEngineSetting_Click
Me.menuUseEngine.Checked = False
Else
Set WS = New WshShell
Set WE = WS.Exec(EnginePath)
Set SI = WE.StdIn
SI.WriteLine Protocol
Set SO = WE.StdOut
Do
L = SO.ReadLine
If L Like "uciok*" Then
Exit Do
End If
Loop
If Options = "" Then
Else
SI.WriteLine Options
End If
End If
Else
QuitEngine
End If
Exit Sub
Err1:
MsgBox Err.Description, vbCritical
End Sub
Private Sub menuEngineSetting_Click()
Form2.Show vbModal, Me
End Sub
Private Sub QuitEngine()
On Error GoTo Err1
If WE Is Nothing Then
Else
If WE.Status = WshRunning Then
SI.WriteLine "quit"
SI.Close
WE.Terminate
End If
End If
Set WE = Nothing
Set WS = Nothing
Exit Sub
Err1:
MsgBox Err.Description, vbCritical
End Sub
