使用Excel VBA調整大小和更改多個圖片的格式

我有一張excel工作表，其中包含大量不同尺寸和格式的圖片。我想使用excel VBA遍歷工作表中的所有圖片，並將每張圖片設置爲相同的寬度（214），並在調整大小後將圖片類型更改爲JPEG（以減小文件大小）。我的圖片位於不同的單元格中，我不希望圖片位置發生變化（即停留在同一個單元格中）。我是VBA新手，嘗試了以下方法 - 但它不起作用。調試器停在我試圖剪切圖片的那一行。使用Excel VBA調整大小和更改多個圖片的格式

Sub Macro6() 

Dim p As Object 

Dim iCnt As Integer 

    For Each p In ActiveSheet.Shapes 
     p.Width = 217.44 
     p.Cut 
     p.PasteSpecial Format:="Picture (JPEG)", Link:=False 
     iCnt = iCnt + 1 
    Next p 
End Sub

來源

2014-08-30 James

這不是Excel不喜歡的切割部分 - 它是粘貼的部分。 Paste和PasteSpecial是您使用工作表對象（您正在粘貼到的位置）而不是圖像（您正在粘貼的對象）調用的方法。我不知道你是否想縮小寬度並保持高度不變，或者如果你想均勻地縮放兩個尺寸。如果要均勻地同時調整，試試這個：

Sub Macro6() 
Dim p As Object 

Dim iCnt As Integer 
Dim s As Double 
Dim r As Range 

For Each p In ActiveSheet.Shapes 
    s = 214/p.Width 
    Set r = p.TopLeftCell 
    p.Width = 214 
    p.Height = p.Height * s 
    p.Cut 
    r.Select 
    ActiveSheet.PasteSpecial Format:="Picture (JPEG)", Link:=False 
    Application.CutCopyMode = False 
    iCnt = iCnt + 1 
Next p 
End Sub

如果你只是試圖縮小寬度和離開的高度相同，試試這個：

Sub Macro6() 
Dim p As Object 

Dim iCnt As Integer 
Dim r As Range 

For Each p In ActiveSheet.Shapes 
    Set r = p.TopLeftCell 
    p.Width = 214 
    p.Cut 
    r.Select 
    ActiveSheet.PasteSpecial Format:="Picture (JPEG)", Link:=False 
    Application.CutCopyMode = False 
    iCnt = iCnt + 1 
Next p 
End Sub

你的照片的位置如果他們原本就在一個單元的角落，應該保持完全一樣。否則，這將使圖像的左上角與最近的單元角對齊。粘貼後Application.CutCopyMode = False是很好的做法。它告訴Excel擦除剪貼板並返回正常操作，而不是等待您再次粘貼。希望這可以幫助。

來源

2014-08-30 19:34:41

太棒了。謝謝您的幫助！！！！我實際上有一些橫向模式的圖片和其他肖像模式的圖片，我想縮小以適應現有的單元大小 - 所以我使用了您建議的For Each構造，並添加了if，then，else構造來確定圖片是否在縱向或橫向，並相應地重新調整比例（基於風景圖片的寬度或基於肖像的高度）。由於某些單元格有多個小圖片，因此我使用.top＆.left屬性代替TopLeftCell。 – James 2014-08-31 22:35:13

感謝您回答我的問題！以下是我根據您的建議最終使用的代碼。該程序花了幾分鐘的時間運行（文件中有超過5000張圖片 - 哇！）。然而，值得等待，因爲它縮小了一半的文件大小。

Sub all_pics_to_jpeg() 

Application.ScreenUpdating = False 

Application.Calculation = xlCalculationManual 

Dim mypic As Shape 

Dim picleft As Double 

Dim pictop As Double 

For Each mypic In ActiveSheet.Shapes 

    mypic.LockAspectRatio = msoTrue 

    If mypic.Width > mypic.Height Then 
    mypic.Width = 217.44 
    Else: mypic.Height = 157.68 
    End If 

    picleft = mypic.Left 
    pictop = mypic.Top 

    With mypic 
     .Cut 
     ActiveSheet.PasteSpecial Format:="Picture (JPEG)", Link:=False, _ 
     DisplayAsIcon:=False 
     Application.CutCopyMode = False 
     Selection.Left = picleft 
     Selection.Top = pictop 
    End With 

Next mypic 

Application.ScreenUpdating = True 

Application.Calculation = xlCalculationAutomatic 

End Sub

來源

2014-08-31 22:48:28 James

使用Excel VBA調整大小和更改多個圖片的格式

回答

相關問題