一次全部導入圖片自動根據(jù)單元格高度

joyark

1.在A2至A40輸入圖片名稱
2.圖片放在圖片文件夾內(nèi)
3.一次全部導入
4.圖片自動根據(jù)單元格高度
Sub 圖片導入()
    '將圖片導入。
    '圖片按照原比例存儲，按照原比例存儲
    On Error Resume Next
    Dim R&
    Dim Pic As Object
    '先刪除所有可能存在的圖片
    For Each Pic In Sheet1.Shapes
        If Pic.Name <> Sheet1.Shapes("按鈕 97").Name Then
            Pic.Delete
        End If
    Next
    For R = 2 To Range("A65536").End(xlUp).Row
        '插入圖片
        Set Pic = Sheet1.Pictures.Insert(ThisWorkbook.Path & "\圖片\" & Cells(R, 1) & ".jpg")
        '鎖定高寬比
        Pic.ShapeRange.LockAspectRatio = True
        '看高寬比。如果圖片高寬比高，那么調(diào)整到單元格高度，否則調(diào)整到單元格寬度
        '我們看到的右鍵格式菜單里的東西都是針對ShapeRange而言的，所以要用ShapeRange來設定
        With Pic.ShapeRange
            '如果圖片高寬比比單元格大，說明圖片太高，只需調(diào)整圖片高度
            If .Height / .Width > Cells(R, 4).Height / Cells(R, 4).Width Then
                .Height = Cells(R, 4).Height
                '調(diào)整位置
                .Top = Cells(R, 4).Top
                .Left = Cells(R, 4).Left + (Cells(R, 4).Width - .Width) / 2
            '如果圖片高寬比比單元格小，說明圖片太寬，只需調(diào)整圖片寬度
            Else
                .Width = Cells(R, 4).Width
                '調(diào)整位置
                .Left = Cells(R, 4).Left
                .Top = Cells(R, 4).Top + (Cells(R, 4).Height - .Height) / 2
            End If
        End With
    Next R
End Sub

huangli0356

沙發(fā)..

xiahou

學習

wuwu200222

學習