如何实现单击按钮后更换工作表中的图片？

楼主
kevinchengcw

Q: 如何实现单击按钮后更换工作表中的图片？
A: 有些情况下我们需要实现单击鼠标后更换工作表中图片的功能，下面提供两个简单的方法及示例附件，实现单击按钮后的图片变换效果，当然也可以进一步实现选择单元格等可触发事件来实现变换功能。

方法一：通过插入与删除图片的方式实现图片变换
优点：图片随意更改，只需加入或替换掉PIC文件夹内JPG图片文件即可，灵活性高。
缺点：文件不能单独使用，一定要配合附属图片文件，本例中是本工作簿路径下的PIC文件夹中JPG文件，另外就是速度有些慢，当电脑配置低时延时明显。

Dim N As Integer '定义公共变量N用来存储循环到的图片名数组的索引值
Dim Arr '定义用来存放图片名的数组
Sub ChangePic1()
Dim Rng As Range
Dim mShape As Shape
Dim Str, StrA As String
Str = ""
StrA = ""
Application.ScreenUpdating = False '关闭屏幕刷新，避免中间效果都被看到，同时也加速代码执行速度
Set Rng = Range("a1:d10") '设定图片要插入的范围
For Each mShape In ActiveSheet.Shapes '枚举图片，删除原来位于A1单元格上的图片
If mShape.TopLeftCell.Address = "$A$1" Then mShape.Delete
Next mShape
If Dir(ThisWorkbook.Path & "\pic\*.jpg") <> "" Then '获取PIC文件夹下图片列表
Str = Dir(ThisWorkbook.Path & "\pic\*.jpg")
Do While Str <> ""
If StrA = "" Then
StrA = Str
Else
StrA = StrA & "," & Str
End If
Str = Dir
Loop
Arr = Split(StrA, ",") '将列表装入数组，便于循环调用
End If
If N > UBound(Arr) Then N = 0 '当循环值超出数组范围后归零，即回到数组起始值
ThisWorkbook.ActiveSheet.Pictures.Insert(ThisWorkbook.Path & "\pic\" & Arr(N)).Select '插入图片并选定，这句是关键
With Selection '对选定的图片调整大小以适合到设定的单元格范围内，注意：未设定自动居中
.Top = [a1].Top
.Left = [a1].Left
If .Height / .Width > Rng.Height / Rng.Width Then '用来判断图片长宽比与单元格范围的长宽比
.Height = Rng.Height
.Width = Rng.Width * Rng.Height / .Height
Else
.Width = Rng.Width
.Height = Rng.Height * Rng.Width / .Width
End If
End With
N = N + 1 '循环值递增，因为N是公共变量，下次循环到时N值仍存在
Application.ScreenUpdating = True '操作完成，打开屏幕更新
End Sub

方法二：通过层叠图片的置顶功能实现图片变换
优点：速度快，图片变换基本没有明显延时
缺点：图片全部插入文件，造成文件体积偏大，另通过索引值操作图片存在出错可能

Dim N As Integer '定义公共变量N用来存储循环到的图片名数组的索引值
Dim Arr '定义用来存放图片名的数组
Sub ChangePic2()
Dim M As Integer
Application.ScreenUpdating = False '关闭屏幕刷新，主要为了提高速度
M = ThisWorkbook.ActiveSheet.Shapes.Count '获取活动工作表中形状数量
Do While ActiveSheet.Shapes((N Mod M) + 1).Type <> 13 '索引值为(N Mod M) + 1的形状不是图片时继续到下一个
N = (N Mod M) + 1 '(N mod M) + 1保证使N的值介于1到M之间
Loop '当索引值是图片时会跳出循环（在循环中可加入对图片位置的判断，这样就可以只对指定的区域的图片进行操作）
ActiveSheet.Shapes((N Mod M) + 1).Select '选中符合条件的图片
Selection.ShapeRange.ZOrder msoBringToFront '将图片移到顶层
Application.ScreenUpdating = True '打开屏幕更新展示结果
End Sub

鼠标点击变换图片.part1.rar

鼠标点击变换图片.part2.rar

鼠标点击变换图片.part3.rar

2楼
成就滋味

谢谢分享

3楼
成就滋味

谢谢分享