图片自适应单元格大小

朱付安

代码运行后，导出的图片我需到知道图片的大小，调整参数太麻烦，现在我想修改成自适应单元格大小，随着单元格的大小变化而变化

hasyh2008

Sub 设置图片大小随单元格的变化()
    Dim Pic
    For Each Pic In ActiveSheet.Shapes
        Pic.Select
        With Pic
            Selection.Placement = xlMove
            Selection.Placement = xlMoveAndSize
            Selection.ShapeRange.LockAspectRatio = msoFalse
        End With
    Next Pic
End Sub

hasyh2008

朱付安

hasyh2008 发表于 2024-6-30 20:14

老师，可以再我之前的代码上修改吗，运行后出现对象不支持该属性和方法

quqiyuan

我调整后样子是这样，仅供参考。。。

Qs18

Sub qs() '2024/6/30图片自适应单元格大小
    Dim fso As Object, folderPath As String, fileName As String, file As Object
    Dim ws As Worksheet, rw, sp As Shape
    For Each sp In ActiveSheet.Shapes
        If sp.Type <> 8 Then
        sp.Delete
    End If
    Next sp
    Set fso = CreateObject("Scripting.FileSystemObject")
    folderPath = ThisWorkbook.Path & "\花\"
    Set ws = ActiveSheet
    rw = 0
    For Each file In fso.GetFolder(folderPath).Files
        rw = rw + 1
        x = Mid(file, VBA.InStrRev(file, "\") + 1, Len(file) - InStrRev(file, "\") - 4)
        ws.Cells(rw, 1).Value = x
        With ws.Cells(rw, 1).Offset(0, 1)
            Z = .Left
            d = .Top
            k = .Width
            g = .Height
            ws.Shapes.AddPicture file, 1, 1, Z, d, k, g
        End With
    Next file
    Set fso = Nothing
    Set file = Nothing
    Set ws = Nothing
    MsgBox "完成"
End Sub

Qs18

试一下...................

Qs18

试一下...............

朱付安

quqiyuan 发表于 2024-6-30 20:24
我调整后样子是这样，仅供参考。。。

谢谢老师，我试试看，不过我想不管怎样调整单元格大小图片跟着变化大小

quqiyuan

朱付安 发表于 2024-6-30 20:52
谢谢老师，我试试看，不过我想不管怎样调整单元格大小图片跟着变化大小

如果图片放到单元格后还能随单元格大小变化，只能高版本的把图片放进单元格