恳请大神们帮忙提供一个让图片自动适应单元格的解决方案

qiongmei6

我希望在图片表格内求得一个代码，当图片插入表格内，他自动按表格大小不改变纵横比例填入到a1:a2,目前的图片最终结果a1：a2就是我希望表格插入图片表格内中的样子，现在我都是用手工来调整，能否用vba一键模式来调整呢，谢谢各位大神的帮忙

liulang0808

https://club.excelhome.net/threa ... tml?_dsign=15791c27供参考

gwjkkkkk

Option Explicit
Sub test()
    Dim ar, Items As FileDialogSelectedItems, strPath$, dNum#, dNum1#, shp As Shape
   
    strPath = ThisWorkbook.Path & "\"
    With Application.FileDialog(1)
        With .Filters
            .Clear
            .Add "Excel Files", "*.bmp;*.jpg;*.png"
        End With
        .AllowMultiSelect = False
        .InitialFileName = strPath
        If .Show Then Set Items = .SelectedItems Else Exit Sub
    End With
   
    For Each shp In ActiveSheet.Shapes
        If shp.Type = 11 Then shp.Delete
    Next
   
    dNum = [A1].MergeArea.Width / [A1].MergeArea.Height
    ar = GetPic(Items(1))
   
    [A1].Select
    ActiveSheet.Pictures.Insert(Items(1)).Select
    With Selection
        .ShapeRange.LockAspectRatio = msoTrue
        .Placement = xlMoveAndSize
        If dNum < ar(0) / ar(1) Then
            .Width = ActiveCell.MergeArea.Width - 6
        Else
            .Height = ActiveCell.MergeArea.Height - 6
        End If
        .Left = ActiveCell.Left + 3
        .Top = ActiveCell.MergeArea.Top + 3
    End With
   
    Beep
End Sub
Function GetPic(ByVal strFileName$) As Long()
    Dim ar&(1)
    Dim Img As Object
    With CreateObject("WIA.ImageFile")
        .LoadFile strFileName
        ar(0) = .Height: ar(1) = .Width
    End With
    GetPic = ar
End Function

gwjkkkkk

参与一下。。。

dragonthree

gwjkkkkk 发表于 2024-6-17 19:21
Option Explicit
Sub test()
    Dim ar, Items As FileDialogSelectedItems, strPath$, dNum#, dNum1#,  ...

学习了，谢谢，GETPIC自定义函数