excel VBA点击图片放大缩小

Sub On_Action()
For Each shp In ActiveSheet.Shapes
'shp.OnActiom y shp. Type
If shp.Type = 13 Or shp.Type = 1 Or shp.Type = 11 Then
shp.OnAction = "test"
End If
Next
End Sub

Sub test()


Dim origW As Double, origH As Double
Dim a As Shape
'On Error Resume Next
b = Application.Caller
Set a = ActiveSheet.Shapes(b)
‘’MsgBox "test 宏已被触发，形状名称是：" & Application.Caller & a.Name & a.Type
If a.Type = 13 Or a.Type = 1 Or a.Type = 11 Then
' If a.Name = Application.Caller And a.AlternativeText = Empty Then
If a.AlternativeText = Empty Then
a.AlternativeText = a.height & Chr(28) & a.width
a.height = a.height * 3:
'a.width = a.width * 3
a.ZOrder msoBringToFront
Else
a.height = Split(a.AlternativeText, Chr(28))(0)
a.width = Split(a.AlternativeText, Chr(28))(1)
a.AlternativeText = Empty
End If
Err.Clear
End If

End Sub

Sub testall()
' MsgBox "test 宏已被触发，形状名称是：" & Application.Caller&
Dim origW As Double, origH As Double
On Error Resume Next
For Each a In ActiveSheet.Shapes
If a.Type = 13 Or a.Type = 1 Or a.Tpye = 11 Then
' If a.Name = Application.Caller And a.AlternativeText = Empty Then
If a.AlternativeText = Empty Then
a.AlternativeText = a.height & Chr(28) & a.width
a.height = a.height * 3:
'a.width = a.width * 3
a.ZOrder msoBringToFront
Else
a.height = Split(a.AlternativeText, Chr(28))(0)
a.width = Split(a.AlternativeText, Chr(28))(1)
a.AlternativeText = Empty
End If
Err.Clear
End If
Next

End Sub

Sub Atesta()
MsgBox "你点击了分配了宏的形状！"
End Sub

需说明：

1、要放在模块里，且要为图片分配test

2、分单击所有与单击一张

 

Sub 单击放大()
Dim str As String
str = Application.Caller
Worksheets("sheet1").Shapes(str).height = 2 * Worksheets("sheet1").Shapes(str).height
Worksheets("sheet1").Shapes(str).ZOrder msoBringToFront
Worksheets("sheet1").Shapes(str).OnAction = "单击缩小"
End Sub

Sub 单击缩小()
Dim str As String
str = Application.Caller
Worksheets("sheet1").Shapes(str).height = 0.2 * Worksheets("sheet1").Shapes(str).height
Worksheets("sheet1").Shapes(str).OnAction = "单击放大"
End Sub

Sub Atest()
On Error Resume Next
For Each a In Worksheets("sheet1").Shapes
If a.Type = 1 Or a.Type = 13 Then
If a.Name = Application.Caller And a.AlternativeText = Empty Then
a.AlternativeText = a.height & Chr(28) & a.width
origW = a.width:
origH = a.height
a.height = origW * 3:
a.width = origW * 3
a.ZOrder msoBringToFront
Else
a.height = Split(a.AlternativeText, Chr(28))(0)
a.width = Split(a.AlternativeText, Chr(28))(1)
a.AlternativeText = Empty
End If
Err.Clear
End If
Next

End Sub