Excel制作五子棋vba源代码.pdf
![资源得分’ title=](/images/score_1.gif)
![资源得分’ title=](/images/score_1.gif)
![资源得分’ title=](/images/score_1.gif)
![资源得分’ title=](/images/score_1.gif)
![资源得分’ title=](/images/score_05.gif)
《Excel制作五子棋vba源代码.pdf》由会员分享,可在线阅读,更多相关《Excel制作五子棋vba源代码.pdf(20页珍藏版)》请在得力文库 - 分享文档赚钱的网站上搜索。
1、Excel 制作象棋vba 源代码 The algorithm of judge and urgentpoint function are exported from one VC program which I downloaded from web.Sorry I cant remebered the program and the author name.The original VC program have three options for different level.I simplized it to the hardest one in this VBA Dim m_Boa
2、rd(17,17)As Integer Private Type Cpoint x As Integer y As Integer End Type Dim m_nType As Integer Dim iWho As Integer Private Sub Excelba_Click()ActiveWorkbook.FollowHyperlink http:/ End Sub Private Sub cmdStart_Click()Cells(17,1)=Start Cells(17,3)=0 total number of stones clear the board Range(Cell
3、s(17+1,1),Cells(17+15,15).Value=0 clear all picture in this sheet except for two orginal picture For Each ipic In ActiveSheet.Shapes If ipic.Name Picture 9 And ipic.Name Picture 10 And Left(ipic.Name,7)=Picture Then ipic.Delete End If Next start it If optComputer.Value=True Then Call drawit(8,8,1)Ca
4、ll setarray(8,8,1)Cells(17,3)=1 End If End Sub Private Sub optComputer_Click()Cells(17,1)=Cells(17,2)=2 Cells(17,3)=0 End Sub Private Sub optYou_Click()Cells(17,1)=Cells(17,2)=1 Cells(17,3)=0 End Sub Private Function confArray(ix As Integer,iy As Integer)As Integer confArray=Cells(17+ix,iy)End Funct
5、ion Private Sub setarray(ix As Integer,iy As Integer,iz As Integer)Cells(17+ix,iy)=iz End Sub Private Sub drawit(ix As Integer,iy As Integer,iz As Integer)Dim strP As String If ix 15 Or iy 15 Or iz 2 Then MsgBox Wrong Entry Number,please check it!,vbCritical,Wrong Entry End End If If iz=1 Then strP=
6、Picture 9 ElseIf iz=2 Then strP=Picture 10 End If Application.ScreenUpdating=False ActiveSheet.Shapes(strP).Select Selection.Copy Cells(16,4).Select ActiveSheet.Paste Selection.ShapeRange.IncrementLeft-(Selection.Left-Cells(ix,iy).Left)+1 Selection.ShapeRange.IncrementTop-(Selection.Top-Cells(ix,iy)
7、.Top)+1 Cells(17,4).Select Application.ScreenUpdating=True End Sub Private Function UrgentPoint(ByVal iz As Integer)As String Dim i,i0,j,j0 As Integer Dim ptUrgent(2025)As Cpoint Dim nGrade1 As Integer Dim nGrade2 As Integer Dim nUrgent1 As Integer Dim nUrgent2 As Integer Dim nUrgent As Integer Dim
8、iEnd As Integer Dim iStep As Integer Dim jEnd As Integer Dim jStep As Integer For i=0 To 2024 ptUrgent(i).x=-1 ptUrgent(i).y=-1 Next i If(Rnd()*32767)Mod 2)=0 Then i0=0 Else i0=14 End If If i0=0 Then iEnd=14 iStep=1 Else iEnd=0 iStep=-1 End If For i=i0 To iEnd Step iStep If(Rnd()*32767)Mod 2)=0 Then
9、 j0=0 Else j0=14 End If If j0=0 Then jEnd=14 jStep=1 Else jEnd=0 jStep=-1 End If For j=j0 To jEnd Step jStep If(m_Board(i,j)=0)Then nGrade1=Judge(i,j,iz)nGrade2=Judge(i,j,iz+1)Select Case(nGrade1)Case 0 nUrgent1=0 Case 1 nUrgent1=2 Case 2 nUrgent1=4 Case 3 nUrgent1=5 Case 4 nUrgent1=8 Case 5 nUrgent
10、1=10 Case 6 nUrgent1=11 Case 7 nUrgent1=12 Case 8 nUrgent1=13 Case 9 nUrgent1=14 Case 10 nUrgent1=15 Case 11 nUrgent1=16 Case 12 nUrgent1=17 Case 13 nUrgent1=18 Case 14 nUrgent1=19 Case 15 nUrgent1=20 Case 16 nUrgent1=32 Case 17 nUrgent1=34 Case 18 nUrgent1=36 Case 19 nUrgent1=38 Case 20 nUrgent1=40
11、 Case Else nUrgent1=40 End Select Select Case(nGrade2)Case 0 nUrgent2=1 Case 1 nUrgent2=3 Case 2 nUrgent2=6 Case 3 nUrgent2=7 Case 4 nUrgent2=9 Case 5 nUrgent2=21 Case 6 nUrgent2=22 Case 7 nUrgent2=23 Case 8 nUrgent2=24 Case 9 nUrgent2=25 Case 10 nUrgent2=26 Case 11 nUrgent2=27 Case 12 nUrgent2=28 C
12、ase 13 nUrgent2=29 Case 14 nUrgent2=30 Case 15 nUrgent2=31 Case 16 nUrgent2=33 Case 17 nUrgent2=35 Case 18 nUrgent2=37 Case 19 nUrgent2=39 Case 20 nUrgent2=41 Case Else nUrgent2=41 End Select nUrgent=WorksheetFunction.Min(nUrgent1,nUrgent2)*45+WorksheetFunction.Max(nUrgent1,nUrgent2)ptUrgent(nUrgent
13、).x=i ptUrgent(nUrgent).y=j End If Next j Next i For i=0 To 2024 If(ptUrgent(i).x -1)And(ptUrgent(i).y -1)Then Exit For End If Next i If(ptUrgent(i).x=-1 And ptUrgent(i).y=-1)Then MsgBox Make Draw End If UrgentPoint=ptUrgent(i).x&|&ptUrgent(i).y End Function Private Sub Worksheet_SelectionChange(ByV
14、al Target As Range)Dim ix As Integer Dim iy As Integer Dim iz As Integer Dim ix1 As Integer Dim iy1 As Integer Dim stmp As String Dim i As Integer Dim j As Integer If Target.Areas.Count 1 Or Target.Areas(1).Columns.Count 1 Or Target.Areas(1).Rows.Count 1 Then Exit Sub End If ix=Target.Areas(1).Row i
15、y=Target.Areas(1).Column iz=confArray(ix,iy)If ix 15 Or iy 15 Then Exit Sub End If If iz 1 And iz 2 And Cells(17,1)=Start Then For i=0 To 14 For j=0 To 14 m_Board(j,i)=Cells(17+i+1,j+1)Next j Next i Call drawit(ix,iy,2)Call setarray(ix,iy,2)m_Board(iy-1,ix-1)=2 Call Judge(iy-1,ix-1,2)Call ring If Ce
16、lls(17,1)=Start Then stmp=UrgentPoint(1)iy1=Left(stmp,InStr(1,stmp,|)-1)ix1=Mid(stmp,InStr(1,stmp,|)+1)Call drawit(ix1+1,iy1+1,1)Call setarray(ix1+1,iy1+1,1)m_Board(iy1,ix1)=1 Call Judge(iy1,ix1,1)Call ring End If End If End Sub Private Function Judge(ByVal nX As Integer,ByVal nY As Integer,ByVal cV
17、alue As Integer)As Integer Dim nGrade As Integer Dim i As Integer Dim j As Integer Dim k As Integer Dim l As Integer Dim nXStart As Integer Dim nXEnd As Integer Dim nYStart As Integer Dim nYEnd As Integer Dim nXYStart As Integer Dim nXYEnd As Integer Dim nYXStart As Integer Dim nYXEnd As Integer Dim
18、 nXStartAdd As Integer Dim nYStartAdd As Integer Dim nXYStartAdd As Integer Dim nYXStartAdd As Integer Dim nXEndAdd As Integer Dim nYEndAdd As Integer Dim nXYEndAdd As Integer Dim nYXEndAdd As Integer Dim bXStartEmpty As Boolean Dim bXEndEmpty As Boolean Dim bXStartEmpty1 As Boolean Dim bXEndEmpty1
19、As Boolean Dim bYStartEmpty As Boolean Dim bYEndEmpty As Boolean Dim bYStartEmpty1 As Boolean Dim bYEndEmpty1 As Boolean Dim bXYStartEmpty As Boolean Dim bXYEndEmpty As Boolean Dim bXYStartEmpty1 As Boolean Dim bXYEndEmpty1 As Boolean Dim bYXStartEmpty As Boolean Dim bYXEndEmpty As Boolean Dim bYXSt
20、artEmpty1 As Boolean Dim bYXEndEmpty1 As Boolean nXStart=nX nXEnd=nX nYStart=nY nYEnd=nY nXYStart=nX nXYEnd=nX nYXStart=nX nYXEnd=nX nXStartAdd=0 nYStartAdd=0 nXYStartAdd=0 nYXStartAdd=0 nXEndAdd=0 nYEndAdd=0 nXYEndAdd=0 nYXEndAdd=0 bXStartEmpty=False bYStartEmpty=False bXYStartEmpty=False bYXStartE
21、mpty=False bXEndEmpty=False bYEndEmpty=False bXYEndEmpty=False bYXEndEmpty=False bXStartEmpty1=False bYStartEmpty1=False bXYStartEmpty1=False bYXStartEmpty1=False bXEndEmpty1=False bYEndEmpty1=False bXYEndEmpty1=False bYXEndEmpty1=False For i=nX-1 To 0 Step-1 -If m_Board(i,nY)=cV alue Then nXStart=i
22、 ElseIf m_Board(i,nY)=0 Then bXStartEmpty=True For j=i-1 To 0 Step-1 If m_Board(i,nY)=cV alue Then nXEnd=i ElseIf m_Board(i,nY)=0 Then bXEndEmpty=True For j=i+1 To 14 -If m_Board(j,nY)=cValue Then nXEndAdd=j-i ElseIf m_Board(j,nY)=0 Then bXEndEmpty1=True Exit For Else Exit For End If Next j Exit For
23、 Else Exit For End If Next i For i=nY-1 To 0 Step-1|If m_Board(nX,i)=cV alue Then nYStart=i ElseIf m_Board(nX,i)=0 Then bYStartEmpty=True For j=i-1 To 0 Step-1 If m_Board(nX,j)=cValue Then nYEndAdd=j-i ElseIf m_Board(nX,j)=0 Then bYEndEmpty1=True Exit For Else Exit For End If Next j Exit For Else Ex
- 配套讲稿:
如PPT文件的首页显示word图标,表示该PPT已包含配套word讲稿。双击word图标可打开word文档。
- 特殊限制:
部分文档作品中含有的国旗、国徽等图片,仅作为作品整体效果示例展示,禁止商用。设计者仅对作品中独创性部分享有著作权。
- 关 键 词:
- Excel 制作 五子棋 vba 源代码
![提示](https://www.deliwenku.com/images/bang_tan.gif)
限制150内