如何更改代码以便图像按比例缩放

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

我对代码几乎一无所知，无法真正尝试任何事情。我有下面的代码，我使用它根据文件路径将图像插入到 Excel 中，然后将它们保存到不同的文件夹中。问题是当它们保存到文件夹中时，它们没有按比例缩放。理想的尺寸为 600 像素 x 600 像素，但重要的是按比例调整它们的大小。有没有办法让代码在找不到图像的情况下继续运行？目前，当它找不到一个弹出窗口时，它会停止，我必须单击“确定”才能继续运行

Answer 1

With .ShapeRange
    .LockAspectRatio = msoTrue
    .Width = 600
    .Height = 600
End With

应该可以。