调整图片大小

爱疯

缩放.rar (198.93 KB, 下载次数: 19)

2019-2-10 14:24 上传

点击文件名下载附件

希望实现：
比如点击黄车，黄车图片高宽，就在1到2倍于C2大小之间切换。



Sub test()
    Dim w, h, i
    i = 2    '缩放系数
    With ActiveSheet.Shapes(Application.Caller)
        w = .TopLeftCell.Width
        h = .TopLeftCell.Height
        .Width = w * IIf(.Width = w, i, 1)    '图片宽 = 单元格宽 * '缩放系数
        .Height = h * IIf(.Width = w, i, 1)
        .ZOrder 0    '使形状置于顶层
    End With
End Sub

movinger

1.漏掉对图片宽纵比的控制
2.第二个高度变化影响了宽度

Sub test()
    Dim w, h, i
    i = 2    '缩放系数
    With ActiveSheet.Shapes(Application.Caller)
        w = .TopLeftCell.Width
        h = .TopLeftCell.Height
        .LockAspectRatio = False
        .Width = w * IIf(.Width = w, i, 1)    '图片宽 = 单元格宽 * '缩放系数
        .Height = h * .Width / w 'IIf(.Width = w, i, 1)
        .ZOrder 0    '使形状置于顶层
    End With
End Sub

爱疯

movinger 发表于 2019-2-10 19:37
1.漏掉对图片宽纵比的控制
2.第二个高度变化影响了宽度

举例3.rar (904.17 KB, 下载次数: 109)

2019-2-10 22:19 上传

点击文件名下载附件

谢谢movinger ！

学习了，对于1楼
当设图片宽时，用的是图片旧宽和单元格宽比较，执行完后图片宽变为新宽
当设图片高时，用的是图片新宽和单元格宽比较，所以出错，是吗


'图片缩放
Private Sub On_Click()
    Dim w, h, i
    i = 2
    With ActiveSheet.Shapes(Application.Caller)
        w = .TopLeftCell.Width
        h = .TopLeftCell.Height
        If .Width = w Then
            .Width = w * i
            .Height = h * i
        Else
            .Width = w
            .Height = h
        End If
        .ZOrder 0    '使形状置于顶层
    End With
End Sub




当A:C的宽度一样，好像不出错。
但为什么出错，我还是没找到原因。

movinger

爱疯 发表于 2019-2-10 22:29
谢谢movinger ！

学习了，对于1楼

图片默认的宽纵比是锁住的，要将其解锁
.LockAspectRatio = False

taller

爱疯 发表于 2019-2-10 22:29
谢谢movinger ！

学习了，对于1楼

这个是Excel的Bug，图片放大时，图片会出现些许的移位

1. Private Sub On_Click()
   
2.     Dim w, h, i, tlCell
   
3.     i = 2
   
4.     With ActiveSheet.Shapes(Application.Caller)
   
5.         Set tlCell = .TopLeftCell
   
6.         w = tlCell.Width
   
7.         h = tlCell.Height
   
8.         If .Width = w Then
   
9.             .Width = w * i
   
10.             .Height = h * i
    
11.         Else
    
12.             .Width = w
    
13.             .Height = h
    
14.         End If
    
15.         .Top = tlCell.Top
    
16.         .Left = tlCell.Left
    
17.         .ZOrder 0    '使形状置于顶层
    
18.     End With
    
19. End Sub
    

复制代码

taller

参考文件

1.zip (22.85 KB, 下载次数: 27)

2019-2-11 00:37 上传

点击文件名下载附件

爱疯

movinger 发表于 2019-2-10 23:44
图片默认的宽纵比是锁住的，要将其解锁
.LockAspectRatio = False

谢谢movinger ！

帮助说，如果调整大小时可以分别更改形状的高度和宽度，则此属性为 False
对于1楼问题，因为不是分别更改高宽，所以锁定属性应该不影响结果，我觉得应该是5楼说的原因。

爱疯

taller 发表于 2019-2-11 00:36
这个是Excel的Bug，图片放大时，图片会出现些许的移位

谢谢taller ！
学习了，我感觉可能是精确造成的问题


1）图片的 l t w h 属性值
2）图片与图片之间
3）图片与单元格之间

ivccav

taller 发表于 2019-2-11 00:36
这个是Excel的Bug，图片放大时，图片会出现些许的移位

说话太不负责任了吧，这是Excel的bug？各种单位的转换和四舍五入，结果肯定会有小量误差。这种类型的"bug"，我遇到过不少，反正一出现问题，自己找不到原因，就是微软的bug，哈哈。

taller

ivccav 发表于 2019-2-11 15:52
说话太不负责任了吧，这是Excel的bug？各种单位的转换和四舍五入，结果肯定会有小量误差。这种类型的"bug ...

你不妨给个解释吧