|
小弟我是第一次做的游戏，希望大家多多鼓励鼓励。 没有用API函数，只用Ｅxcel控件自己的方法．事件．属性等，比较适合我等初学者学习。 须注意，原始图片与E表在同一文件夹，图片为500X500 以下为代码： 
模块------------------------------------------------------------------------------------ Public Sh2 As New Worksheet
Public mYxJh As New Collection
Public tptem As Shape
Public mPl(1 To 17) As String
Public jb As Integer Sub Shape_Click(ByVal SHname As String) '图片点击事件
On Error Resume Next '捕捉错误
Dim szXH As Integer
Dim szXHt As Integer
Dim tpXH As Integer
jb = jb + 1 '累计点击次数 tpXH = Val(Mid(SHname, 3, 2)) '获得该图片的序号
For q1 = 1 To 17 '遍历数组
If mPl(q1) = mYxJh.Item(tpXH).Name Then szXHt = q1 '获得该图片对应的数组的序号
If mPl(q1) = "" Then szXH = q1 '获得空数组(空格)的序号
Next Select Case szXHt - szXH
Case -1 '图片右移
With mYxJh.Item(tpXH)
.Left = .Left + .Width
mPl(szXHt) = ""
mPl(szXH) = .Name
End With
Case 1 '图片左移
With mYxJh.Item(tpXH)
.Left = .Left - .Width
mPl(szXHt) = ""
mPl(szXH) = .Name
End With
Case -4 '图片下移
With mYxJh.Item(tpXH)
.Top = .Top + .Height
mPl(szXHt) = ""
mPl(szXH) = .Name
End With Case 4 '图片上移
With mYxJh.Item(tpXH)
.Top = .Top - .Height
mPl(szXHt) = ""
mPl(szXH) = .Name
End With
End Select With Sh2
.Range("L14") = "最高纪录"
.Range("N14") = "次"
.Range("L15") = "已点击了"
.Range("M15") = jb
.Range("N15") = "次"
End With q2 = 1
Do While q2 <= 16 '判断是否完成该游戏
If mPl(q2) = mYxJh.Item(q2).Name Then
q2 = q2 + 1
If q2 = 17 Then
MsgBox "恭喜你,已成功完成!" + Chr(10) + "你共点击了" + Str(jb) + "次"
If Sh2.Range("M14") = 0 Then Sh2.Range("M14") = jb
If jb < Sh2.Range("M14") Then Sh2.Range("M14") = jb
End If
Else
Exit Do
End If
Loop
End Sub 按钮1------------------------------------------------------------------------------------
Private Sub CommandButton1_Click()
jb = 0
Set Sh2 = Sheet2 '对象变量赋值
Set mYxJh = Nothing '集合清空
With Sh2
.Range("I27") = "<--点击右下角图片"
.Range("L30") = "建明工作室"
.Range("M15") = 0
End With
Application.ScreenUpdating = False '屏幕更新功能_关闭(加快速度)
mYxQk '调用清空过程
mYxFg '调用图片分割过程
mYxPl '调用图片排列过程
For sz = 1 To 16
mName = "tu" & sz
Sh2.Shapes("tu" & sz).OnAction = "'Shape_Click """ & mName & """'" '给分割后的图片加入点击事件
Next Application.ScreenUpdating = True '屏幕更新功能_打开 End Sub 过程---------------------------------------------------------------------------- Private Sub mYxQk() '清空界面
For Each ct In Sh2.Shapes '删除全部图片
If Left(ct.Name, 13) = "CommandButton" Then
Else
ct.Delete
End If
Next With Sh2.Shapes.AddPicture(ThisWorkbook.Path + "\tu.jpg", True, True, 530, 200, 160, 160)
.Name = "tu0" '加入一张图片(必须为正方形)
'.ShapeStyle = msoLineStylePreset1 '加入外框(Excel2007适用)
End With
End Sub Private Sub mYxFg() '分割图片
Dim r1 As Integer
Dim b1 As Integer
Dim xh As Integer Set tptem = Sh2.Shapes("tu0").Duplicate
With tptem '获得图片1:1的高度(必须为正方形)后删除
.ScaleWidth 1, True
.ScaleHeight 1, True
b1 = .Height
.Delete
End With For l1 = 0 To 3 '以下为复制16张图片并分割
For t1 = 0 To 3
xh = xh + 1
Set tptem = Sh2.Shapes("tu0").Duplicate
With tptem
.Name = "tu" + Trim(Str(xh))
.ScaleWidth 1, True
.ScaleHeight 1, True
End With With tptem.PictureFormat
.CropLeft = b1 * t1 / 4
.CropTop = b1 * l1 / 4
.CropRight = b1 * (3 - t1) / 4
.CropBottom = b1 * (3 - l1) / 4
End With 'With tptem
' .Left = b1 * t1 / 4
' .Top = b1 * l1 / 4
'End With mYxJh.Add tptem '把图片加入集合
Set tptem = Nothing '对象清空
Next
Next End Sub Private Sub mYxPl() '随机排列图片
Randomize ' 对随机数生成器做初始化的动作 For qk = 1 To 17 '数组清空
mPl(qk) = ""
Next p1 = 15 '以下为随机排列图片
For xh = 1 To p1
k = Int((p1 * Rnd) + 1) ' 生成1-16之间的随机数值
For p2 = 1 To p1
If Val(Mid(mPl(p2), 3, 2)) = k Then
k = Int((p1 * Rnd) + 1) ' 生成1-16之间的随机数值
p2 = 0
End If
Next With mYxJh.Item(k) '指定15张图片到指定位置
mPl(xh) = .Name
.Left = .Width * ((xh - 1) Mod 4)
.Top = .Height * (Int((xh - 1) / 4) Mod 4)
End With
Next With mYxJh.Item(16) '指定第16张图片到指定位置
mPl(16) = .Name
.Left = .Width * 3
.Top = .Height * 3
End With
End Sub
bQkkYvOK.zip
(230.48 KB, 下载次数: 840)
| 
沪公网安备 31011702000001号 沪ICP备11019229号-2
发表于 2008-7-12 16:01
