实现放大缩小图片

朱付安

点击图片自动实现放大缩小，谢谢

过客fppt

1. ' 以下代码放置在ThisWorkbook模块中
   
2. Private Sub Workbook_Open()
   
3.     Dim ws As Worksheet
   
4.     For Each ws In ThisWorkbook.Worksheets
   
5.         Call AdjustPictures(ws)
   
6.     Next ws
   
7. End Sub
   
8. 
   
9. ' 以下代码放置在标准模块中
   
10. Sub AdjustPictures(ws As Worksheet)
    
11.     Dim shp As Shape
    
12.     For Each shp In ws.Shapes
    
13.         If shp.Type = msoPicture Then
    
14.             ' 4. 图片自动缩放，保持原有比例，自适应单元格大小
    
15.             shp.Placement = xlMoveAndSize
    
16.             shp.LockAspectRatio = msoTrue
    
17.         End If
    
18.     Next shp
    
19. End Sub
    
20. 
    
21. Sub ZoomInPicture()
    
22.     Dim shp As Shape
    
23.     Set shp = ActiveSheet.Shapes(Application.Caller)
    
24.     If shp.Type = msoPicture Then
    
25.         ' 获取图片当前的宽度
    
26.         Dim currentWidth As Double
    
27.         currentWidth = shp.Width
    
28.         ' 5. 单击图片，可放大（默认20倍，图片放大最大宽度300磅，避免放大太大不便查看）
    
29.         If currentWidth < 300 Then
    
30.             shp.Width = currentWidth * 20
    
31.         End If
    
32.     End If
    
33. End Sub
    
34. 
    
35. Sub ZoomOutPicture()
    
36.     Dim shp As Shape
    
37.     Set shp = ActiveSheet.Shapes(Application.Caller)
    
38.     If shp.Type = msoPicture Then
    
39.         ' 获取图片当前的宽度
    
40.         Dim currentWidth As Double
    
41.         currentWidth = shp.Width
    
42.         ' 6. 再单击放大图片，自动恢复小图
    
43.         shp.Width = currentWidth / 20
    
44.     End If
    
45. End Sub

复制代码

朱付安

过客fppt 发表于 2024-12-1 16:29

好的，老师我试试，还是出现运行错误

朱付安

朱付安 发表于 2024-12-1 16:34
好的，老师我试试

还是不行，运行错误啊

过客fppt

朱付安 发表于 2024-12-1 16:40
还是不行，运行错误啊

何必用代码，图片嵌入单元格之后，双击图片本身就会自动放大了呀

gateun

Sub 图片点击缩放()

    Dim shp As shape
    Dim LastShp As Object
   
    On Error Resume Next

    ' 遍历当前工作表的所有形状
    For Each shp In ActiveSheet.Shapes

        ' 检查形状是否为OLE对象或图片
        If shp.Type = msoLinkedOLEObject Or shp.Type = msoPicture Then
            
            ' 如果形状的OnAction属性为空，则设置为"图片点击缩放"
            If shp.OnAction = vbNullString Then
                shp.OnAction = "图片点击缩放"
            End If

            ' 如果形状的名称与调用者（即当前活动单元格）的形状名称相同
            If shp.Name = ActiveSheet.Shapes(Application.Caller).Name Then
               
                ' 如果形状的AlternativeText为空，则记录其原始高度和宽度
                If shp.AlternativeText = vbNullString Then
                    If Not LastShp Is Nothing Then
                        ' 还原上一个图片的大小
                        LastShp.Height = Split(LastShp.AlternativeText, Chr(28))(0)
                        LastShp.Width = Split(LastShp.AlternativeText, Chr(28))(1)
                        LastShp.AlternativeText = vbNullString
                    End If
                    
                    ' 锁定纵横比并记录图片的原始尺寸
                    shp.LockAspectRatio = msoTrue
                    shp.AlternativeText = shp.Height & Chr(28) & shp.Width
                    
                    ' 缩放图片
                    shp.Height = shp.Height * 1.8 ' 调整此处的倍数以改变缩放比例
                    shp.Width = shp.Width * 1.8
                    shp.ZOrder msoBringToFront
                    
                    ' 记录当前图片作为上一个图片
                    Set LastShp = shp
                Else
                    ' 如果已经记录了图片的原始尺寸，则还原图片大小
                    shp.Height = Split(shp.AlternativeText, Chr(28))(0)
                    shp.Width = Split(shp.AlternativeText, Chr(28))(1)
                    shp.AlternativeText = vbNullString
                End If
            End If
        End If
    Next shp

End Sub

朱付安

过客fppt 发表于 2024-12-1 17:44
何必用代码，图片嵌入单元格之后，双击图片本身就会自动放大了呀

试了一下，双击图片并不能放大图片

lss001

朱付安 发表于 2024-12-1 18:20
试了一下，双击图片并不能放大图片

点击放，再点缩
参考一下附件代码！
xiugai.zip (376.41 KB, 下载次数: 39)

2024-12-1 18:25 上传

点击文件名下载附件

朱付安

lss001 发表于 2024-12-1 18:24
点击放，再点缩
参考一下附件代码！

好啦老师，谢谢

过客fppt

朱付安 发表于 2024-12-1 18:20
试了一下，双击图片并不能放大图片

记错了，但是嵌入后点加号也是放大图片啊