VBA 如何實現讓所有圖片剛好適應所在單元格大小與表框

Excel疑難千尋千解叢書(三)Excel2010 VBA編程與實踐.pdf

 

 

 

 

 

 

 

 

 

 

 

Sub 讓圖片適應單元格()
    Dim sh As Shape
    Dim sSheet As Worksheet '源工作表
      
    Set sSheet = Worksheets("Sheet1")
    
    For Each sh In sSheet.Shapes
        sh.LockAspectRatio = False
        sh.Left = sh.TopLeftCell.Left
        sh.Top = sh.TopLeftCell.Top
        sh.Width = sh.TopLeftCell.Width
        sh.Height = sh.TopLeftCell.Height
        
    Next sh

End Sub

 

或

Sub setpic1()
    Dim p As Shape, d$
    Dim sSheet As Worksheet '源工作表
    Set sSheet = Worksheets("Sheet1")

    For Each p In sSheet.Shapes
        p.LockAspectRatio = msoFalse
        d = p.TopLeftCell.Address
        p.Height = Range(d).Height
        p.Width = Range(d).Width
        p.Top = Range(d).Top
        p.Left = Range(d).Left
    Next
End Sub

 

缺陷：VBA代碼多次運行時，圖片會移動到其他單元格，不推薦使用

 

---

 

二、插入指定圖片到選中的單元格並適應大小

推薦使用

Sub 插入指定圖片到選中的單元格並適應大小()
    Dim filenames As String
    Dim filefilter1 As String

    filefilter1 = ("所有圖片文件（*.jpg;*.bmp;*.png;*.gif）,*.jpg;*.bmp;*.png;*.gif")
    filenames = Application.GetOpenFilename(filefilter1, , "請選擇一個圖片文件", , MultiSelect:=False)
    
    '沒有選中文件時，做容錯處理
    If filenames = "False" Then
        Exit Sub
    End If
    
    '插入圖片到指定的單元格
    Sheet1.Pictures.Insert(filenames).Select

    '圖片自適應單元格大小
    On Error Resume Next
    Dim picW As Single, picH As Single
    Dim cellW As Single, cellH As Single
    Dim rtoW As Single, rtoH As Single
    
    cellW = ActiveCell.Width
    cellH = ActiveCell.Height
    picW = Selection.ShapeRange.Width
    picH = Selection.ShapeRange.Height
    rtoW = cellW / picW * 0.95
    rtoH = cellH / picH * 0.95
    
    If rtoW < rtoH Then
        Selection.ShapeRange.ScaleWidth rtoW, msoFalse, msoScaleFromTopLeft
    Else
        Selection.ShapeRange.ScaleHeight rtoH, msoFalse, msoScaleFromTopLeft
    End If
    
    picW = Selection.ShapeRange.Width
    picH = Selection.ShapeRange.Height
    Selection.ShapeRange.IncrementLeft (cellW - picW) / 2
    Selection.ShapeRange.IncrementTop (cellH - picH) / 2

End Sub

 

 

來自：

https://blog.csdn.net/yinming4u/article/details/49120933

---

 

三、excel 批量插入圖片且自適應單元格（絕對有效）

https://www.jianshu.com/p/04e462ad4065

 

1.情景展示

工作中，我們可能會遇到這種情況，需要將拍攝的照片批量插入到excel中
，出現的問題在於：
我們不僅需要將其一個一個的插入到對應的單元格中，還需要將其縮放至合適大小。

 

 

工作量很大且繁瑣，有沒有辦法能夠解決這個問題呢？

2.解決方案

實現方式：通過宏命令實現。
第一步：先插入第一張圖片（一般情況下，批量導入的圖片大小是一致的）；
如上圖所示，將圖片調整至合適大小；

 

 

第二步：按照圖片將單元格調至合適大小，刪除該圖片；
選中要插入圖片的單元格，將其大小調整至和剛才圖片的大小一致。

 

 

第三步：鼠標選中要插入第一張圖片的單元格；

 

 

第四步：ALT+F11-->打開VBA編輯器-->插入-->模塊；

 

 

將下列代碼拷貝至彈出的窗口：

Sub 批量插入圖片且自適應單元格()

    Dim fileNames As Variant
    Dim fileName As Variant
    Dim fileFilter As String

    '所有圖片文件后面的括號為中文括號
    fileFilter = ("所有圖片文件（*.jpg;*.bmp;*.png;*.gif）,*.jpg;*.bmp;*.png;*.gif")
    fileNames = Application.GetOpenFilename(fileFilter, , "請選擇要插入的圖片", , MultiSelect:=True)

    '循環次數
    Dim i As Single
    i = 0
    '忽略錯誤繼續執行VBA代碼，避免出現錯誤消息（數組fileNames為空時，會報錯）
    On Error Resume Next
    '循環插入
    For Each fileName In fileNames

        '將圖片插入到活動的工作表中&選中該圖片
        With ActiveSheet.Pictures.Insert(fileName).Select

            '圖片自適應單元格大小
            Dim picW As Single, picH As Single
            Dim cellW As Single, cellH As Single
            Dim rtoW As Single, rtoH As Single
            '鼠標所在單元格的寬度
            cellW = ActiveCell.Width
            '鼠標所在單元格的高度
            cellH = ActiveCell.Height
            '圖片寬度
            picW = Selection.ShapeRange.Width
            '圖片高度
            picH = Selection.ShapeRange.Height
            '重設圖片的寬和高
            rtoW = cellW / picW * 0.95
            rtoH = cellH / picH * 0.95
            If rtoW < rtoH Then
                Selection.ShapeRange.ScaleWidth rtoW, msoFalse, msoScaleFromTopLeft
            Else
                Selection.ShapeRange.ScaleHeight rtoH, msoFalse, msoScaleFromTopLeft
            End If
            picW = Selection.ShapeRange.Width
            picH = Selection.ShapeRange.Height
            '鎖定圖片鎖定縱橫比
            Selection.ShapeRange.LockAspectRatio = msoTrue
            '圖片的位置與大小隨單元格變化而變化
            Selection.Placement = xlMoveAndSize
            '設置該圖片的所在位置
            Selection.ShapeRange.IncrementLeft (cellW - picW) / 2 + cellW * i
            Selection.ShapeRange.IncrementTop (cellH - picH) / 2
        End With
        i = i + 1
    '下一個
    Next fileName

End Sub

 

 

第五步：按F5運行；
選中你要插入的圖片--》打開；

 

 

3.效果展示

 

 

4.擴展說明

4.1 代碼說明

 

 

將圖片設置為橫向排列，代碼如下：

'設置該圖片的所在位置（圖片橫向排列）
Selection.ShapeRange.IncrementLeft (cellW - picW) / 2 + cellW * i
Selection.ShapeRange.IncrementTop (cellH - picH) / 2

將圖片設置為縱向排列，代碼如下：

'設置該圖片的所在位置（圖片縱向排列）
Selection.ShapeRange.IncrementLeft (cellW - picW) / 2
Selection.ShapeRange.IncrementTop (cellH - picH) / 2 + cellH * i

將圖片插入到同一位置，代碼如下：

'設置該圖片的所在位置（圖片位於同一位置）
Selection.ShapeRange.IncrementLeft (cellW - picW) / 2
Selection.ShapeRange.IncrementTop (cellH - picH) / 2

4.2 技巧說明
選中圖片，同時按住Shift鍵和方向鍵，可以實現對圖片的縮小、放大；
選中圖片，同時按住Ctrl鍵和方向鍵，可以實現對圖片的位置的進行微調。