VBA - 在excel中调整图片大小答案

【问题标题】：VBA - Resizing a picture in excelVBA - 在excel中调整图片大小
【发布时间】：2021-11-25 08:06:24
【问题描述】：

下面的代码将图片从我的表单粘贴到一个活动单元格中。但是，如何将过去的图片调整为excel的大小？

Private Sub CommandButton1_Click()
 TransferToSheet Me.Image1, Plan2, 350
End Sub

Private Sub TransferToSheet(picControl, sht As Worksheet, picWidth As Long)
Const TemporaryFolder = 2
Dim fso, p

Set fso = CreateObject("scripting.filesystemobject")
p = fso.GetSpecialFolder(TemporaryFolder).Path & "\" & fso.gettempname
SavePicture picControl.Picture, p

With picControl.Picture.Insert(p)
.ShapeRange.LockAspectRatio = msoTrue
.Width = picWidth
End With
   
fso.deletefile p
Unload Me

结束子

【问题讨论】：

您是按百分比调整大小还是按固定宽度/高度调整大小
我正在尝试固定宽度/高度。
还有什么是SavePicture？这是您自己的例程还是内置的 VBA 函数？如果是你的，请附上代码
SavePicture 这是一个 VBA 例程。
该错误发生在哪一行？

标签： excel vba image userform transfer

【解决方案1】：

好的 - 我修改了之前的答案以处理图片实际上是 Shape 的事实 - 您可以使用图像的 ShapeRange 调整大小。

Private Sub CommandButton1_Click()
    TransferToSheet Image1, Worksheets("Sheet1"), 350
End Sub


Private Sub TransferToSheet(picControl, sht As Worksheet, picWidth As Long)
    Const TemporaryFolder = 2
    Dim fso, p

    Set fso = CreateObject("Scripting.FileSystemObject")
    p = fso.GetSpecialFolder(TemporaryFolder).Path & "\" & fso.gettempname
    SavePicture picControl.Picture, p ' save to temp file
        
    ' Insert temp file inot new image
    With sht.Pictures.Insert(p)
        ' Resize
        With .ShapeRange
            .LockAspectRatio = msoTrue
            .Width = picWidth
        End With
    End With
    
    ' Delete Temp File
    fso.DeleteFile p
End Sub

【讨论】：

我想我没听懂你在说什么，因为我替换了我的代码……但是，它不起作用。
你为什么不编辑你的问题并展示你的尝试 - 并描述“不工作”尝试将该行放回（见我编辑的答案 - SavePicture picControl.Picture，p
Private Sub TransferToSheet(picControl, sht As Worksheet, picWidth As Long) Const TemporaryFolder = 2 Dim fso, p Set picWidth = 50 Set fso = CreateObject("scripting.filesystemobject") p = fso.GetSpecialFolder(TemporaryFolder).Path & "\" & fso.gettempname SavePicture picControl.Picture, p With picControl.Picture.Insert(p) .ShapeRange.LockAspectRatio = msoTrue .Width = picWidth End With fso.deletefile p Unload Me End Sub
编辑您的问题 - 没有人可以在 cmets 中阅读它
好了，编辑完成了。