Excel几百张图片要重命名导出?别傻傻截图了,10秒自动化搞定!

Option Explicit#If VBA7 Then    Public Declare PtrSafe Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As Long)#Else    Public Declare Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As Long)#End IfSub BatchExportImages_Custom()    Dim ws As Worksheet    Dim shp As Shape    Dim chrt As ChartObject    Dim folderPath As String    Dim fileName As String    Dim validName As String    Dim cellVal As String    Dim originalWidth As Double    Dim originalHeight As Double    Dim targetWidth As Double    Dim newWidth As Double    Dim newHeight As Double    Dim count As Integer    Dim colIndex As Integer    Dim exportPath As String    Dim userInput As String    Set ws = ActiveSheet    With Application.FileDialog(msoFileDialogFolderPicker)        .Title = "请选择图片保存的文件夹"        If .Show = -1 Then            folderPath = .SelectedItems(1) & "\"        Else            MsgBox "未选择文件夹，操作已取消。"            Exit Sub        End If    End With    userInput = InputBox("请输入导出图片的宽度（像素）：", "设置图片宽度", "600")    ' 校验输入是否为数字，如果不是则默认600    If IsNumeric(userInput) And Val(userInput) > 0 Then        targetWidth = Val(userInput)    Else        MsgBox "输入无效，将使用默认宽度 600"        targetWidth = 600    End If    count = 0    For Each shp In ws.Shapes        ' 检查形状类型 (排除下拉框、OLE对象等，只处理图片)        If shp.Type = msoPicture Or shp.Type = msoLinkedPicture Then            ' 获取图片左上角所在的列            colIndex = shp.TopLeftCell.Column            ' 确保不是第一列 (A列没有左侧单元格)            If colIndex > 1 Then                ' 获取命名 (左侧单元格)                cellVal = shp.TopLeftCell.Offset(0, -1).Value                validName = CleanFileName(cellVal)                If validName = "" Then validName = "Image_" & shp.ID                originalWidth = shp.Width                originalHeight = shp.Height                shp.LockAspectRatio = msoTrue                shp.Width = targetWidth ' 使用用户输入的宽度                newWidth = shp.Width                newHeight = shp.Height                shp.CopyPicture Appearance:=xlScreen, Format:=xlBitmap                ' 创建临时图表容器                Set chrt = ws.ChartObjects.Add(0, 0, newWidth, newHeight)                With chrt                    ' 去除图表边框和背景                    .Border.LineStyle = 0                    .Chart.ChartArea.Format.Line.Visible = msoFalse                    .Chart.ChartArea.Format.Fill.Visible = msoFalse                    .Chart.PlotArea.Format.Line.Visible = msoFalse                    .Chart.PlotArea.Format.Fill.Visible = msoFalse                    .Activate                    .Chart.Paste                    ws.Cells(1, 1).Select                End With                DoEvents                exportPath = folderPath & validName & ".jpg"                On Error Resume Next                ' 如果文件已存在，会直接覆盖                chrt.Chart.Export fileName:=exportPath, FilterName:="JPG"                On Error GoTo 0                chrt.Delete                shp.Width = originalWidth                count = count + 1            End If        End If    Next shp    Application.ScreenUpdating = True    MsgBox "导出完成！" & vbCrLf & "共导出: " & count & " 张" & vbCrLf & "尺寸宽度: " & targetWidth & vbCrLf & "位置: " & folderPath    ' 打开目标文件夹    Shell "explorer.exe " & folderPath, vbNormalFocusEnd Sub

cellVal = shp.TopLeftCell.Offset(0, -1).Value