如何按比例缩放图像

Question

我根据文件路径将图像插入 Excel，然后将它们保存到不同的文件夹中。

当它们保存到文件夹中时，它们不会按比例缩放。理想的尺寸是 600 像素 x 600 像素，但重要的是按比例调整它们的大小。

有没有办法在找不到图像时保持代码运行？目前它停止了，出现一个弹出窗口，我必须单击“确定”。

Sub InsertAndSaveImages()
    Dim ws As Worksheet
    Dim wb As Workbook
    Dim imgFolder As String
    Dim imgName As String
    Dim imgCounter As Integer
    Dim imgCell As Range
    Dim imgPath As String
    Dim imgShape As Shape
    
    ' Set the worksheet where the file paths are stored
    Set ws = ThisWorkbook.Sheets("raw data")  ' Change "Sheet1" to your sheet name
    
    ' Set the workbook (this workbook)
    Set wb = ThisWorkbook
    
    ' Folder path to save images
    imgFolder = wb.Path & "\Images\"
    
    ' Create the images folder if it doesn't exist
    If Dir(imgFolder, vbDirectory) = "" Then
        MkDir imgFolder
    End If
    
    ' Loop through column A to insert and save images
    imgCounter = 1
    For Each imgCell In ws.Range("A1:A" & ws.Cells(ws.Rows.Count, "A").End(xlUp).Row)
        ' Get image path from column A
        imgPath = imgCell.Value
        
        ' Check if image path exists
        If Dir(imgPath) <> "" Then
            ' Extract image name from path
            imgName = Mid(imgPath, InStrRev(imgPath, "\") + 1)
            
            ' Insert image into worksheet
            Set imgShape = ws.Shapes.AddPicture(fileName:=imgPath, _
                                                LinkToFile:=msoFalse, _
                                                SaveWithDocument:=msoTrue, _
                                                Left:=100, _
                                                Top:=100, _
                                                Width:=200, _
                                                Height:=200)
            
            ' Save image to folder
            Call SaveImageToFile(imgShape, imgFolder & imgName)
            
            ' Clean up
            imgShape.Delete
        Else
            MsgBox "Image file not found: " & imgPath, vbExclamation
        End If
        
        imgCounter = imgCounter + 1
    Next imgCell
    
    MsgBox "Images inserted and saved successfully to folder: " & imgFolder, vbInformation
End Sub

Sub SaveImageToFile(imgShape As Shape, SavePath As String)
    Dim chartObj As ChartObject
    
    ' Copy image shape to clipboard
    imgShape.CopyPicture xlScreen, xlBitmap
    
    ' Paste image into chart object
    Set chartObj = ActiveSheet.ChartObjects.Add(0, 0, imgShape.Width, imgShape.Height)
    chartObj.Activate
    ActiveChart.Paste
    
    ' Export chart object as image file
    ActiveChart.Export fileName:=SavePath, Filtername:="jpg"
    
    ' Delete chart object
    chartObj.Delete
End Sub

Answer 1

• 如果使用

  Pictures.Insert

  插入图像，则它将保持其原始尺寸。
• 添加子

  ResizeImg

  将图像大小调整为 600x600。如果图像不是

  square

  （高度与宽度不同），则只有一个尺寸为 600，另一个尺寸小于 600。例如。图片尺寸为300x200，调整大小后最终尺寸为600x400。

Sub InsertAndSaveImages()
    Dim ws As Worksheet
    Dim wb As Workbook
    Dim imgFolder As String
    Dim imgName As String
    Dim imgCounter As Integer
    Dim imgCell As Range
    Dim imgPath As String
    Dim imgShape As Shape
    ' Set the worksheet where the file paths are stored
    Set ws = ThisWorkbook.Sheets("raw data")  ' Change "Sheet1" to your sheet name
    ' Set the workbook (this workbook)
    Set wb = ThisWorkbook
    ' Folder path to save images
    imgFolder = wb.Path & "\Images\"
    ' Create the images folder if it doesn't exist
    If Dir(imgFolder, vbDirectory) = "" Then
        MkDir imgFolder
    End If
    ' Loop through column A to insert and save images
    imgCounter = 1
    For Each imgCell In ws.Range("A1:A" & ws.Cells(ws.Rows.Count, "A").End(xlUp).Row)
        ' Get image path from column A
        imgPath = imgCell.Value
        ' Check if image path exists
        If Dir(imgPath) <> "" Then
            ' Extract image name from path
            imgName = Mid(imgPath, InStrRev(imgPath, "\") + 1)
            ' Insert image into worksheet **
            Set imgShape = ws.Pictures.Insert(imgPath)
            Call ResizeImg(imgShape, 600, 600)
            ' Save image to folder
            Call SaveImageToFile(imgShape, imgFolder & imgName)
            ' Clean up
            imgShape.Delete
        Else
            ' MsgBox "Image file not found: " & imgPath, vbExclamation
            ' Print out missing file in Immediate Window
            Debug.Print "Image file not found: " & imgPath
        End If
        imgCounter = imgCounter + 1
    Next imgCell
    MsgBox "Images inserted and saved successfully to folder: " & imgFolder, vbInformation
End Sub
Sub ResizeImg(imgShape As Shape, ByVal iH As Long, ByVal iW As Long)
    Dim ratioH As Double, ratioW As Double, ratioResize As Double
    If Not imgShape Is Nothing Then
        ratioW = iW / imgShape.Width
        ratioH = iH / imgShape.Height
        ratioResize = IIf(ratioW < ratioH, ratioW, ratioH)
        imgShape.LockAspectRatio = msoTrue
        imgShape.Height = imgShape.Height * ratioResize
    End If
End Sub
Sub SaveImageToFile(imgShape As Shape, SavePath As String)
    Dim chartObj As ChartObject
    ' Copy image shape to clipboard
    imgShape.CopyPicture xlScreen, xlBitmap
    ' Paste image into chart object
    Set chartObj = ActiveSheet.ChartObjects.Add(0, 0, imgShape.Width, imgShape.Height)
    chartObj.Activate
    ActiveChart.Paste
    ' Export chart object as image file
    ActiveChart.Export Filename:=SavePath, Filtername:="jpg"
    ' Delete chart object
    chartObj.Delete
End Sub