wps 浮动图片导出导入，vba，导出慢，有崩溃现象。
Option Explicit
Sub 导出1()
On Error GoTo ErrorHandler
Dim ws As Worksheet
Dim pic As Shape
Dim savePath As String
Dim fd As FileDialog
Dim exportCount As Long
Dim failCount As Long
Dim fileName As String
Dim cellAddress As String
Dim chartObj As ChartObject
Dim tempChart As Chart
Dim picWidth As Single, picHeight As Single
Dim content As String
' 1. 选择保存路径
Set fd = Application.FileDialog(msoFileDialogFolderPicker)
fd.Title = "请选择保存图片的文件夹"
fd.InitialFileName = ""
If fd.Show <> -1 Then
MsgBox "未选择保存路径，操作已取消", vbInformation
Exit Sub
End If
savePath = fd.SelectedItems(1) & "\"
' 2. 初始化设置
Set ws = ActiveSheet
Application.ScreenUpdating = False
Application.DisplayAlerts = False
Application.Calculation = xlCalculationManual
Application.EnableEvents = False
exportCount = 0
failCount = 0
content = ActiveSheet.Range("A1").Value
' 3. 遍历形状并导出
For Each pic In ws.Shapes
' 【修改点】仅处理嵌入型图片 (msoPicture)，跳过链接图片 (msoLinkedPicture)
' msoPicture = 13
If pic.Type = msoPicture Then
' 获取图片当前尺寸
pic.LockAspectRatio = msoTrue
pic.Width = 800
picWidth = pic.Width
picHeight = pic.Height
' 获取左上角单元格地址作为文件名一部分
cellAddress = pic.TopLeftCell.Address(False, False)
' 替换地址中的特殊字符，防止文件名非法
'cellAddress = Replace(cellAddress, "!", "_")
'cellAddress = Replace(cellAddress, "$", "")
'cellAddress = Replace(cellAddress, ":", "_")
fileName = savePath & content & cellAddress & ".png"
' 核心导出逻辑：使用局部错误处理以跳过单张失败图片
On Error Resume Next
' 复制图片
pic.Copy
' 创建与图片原始尺寸完全一致的临时图表对象
Set chartObj = ws.ChartObjects.Add(0, 0, picWidth, picHeight)
Set tempChart = chartObj.Chart
' 粘贴到图表
tempChart.Paste
' 关键：确保图表区域没有多余的边距，使导出图片紧凑
With tempChart
.ChartArea.Border.LineStyle = xlNone
.PlotArea.Border.LineStyle = xlNone
.Parent.Left = 0
.Parent.Top = 0
.Parent.Width = picWidth
.Parent.Height = picHeight
End With
' 让系统处理剪贴板和绘图队列，防止冲突
DoEvents
' 导出图片
tempChart.Export fileName:=fileName, FilterName:="PNG"
pic.LockAspectRatio = msoTrue
' pic.Height = 60
' 检查是否出错
If Err.Number <> 0 Then
failCount = failCount + 1
Debug.Print "导出失败: " & fileName & " 错误: " & Err.Description
Err.Clear
Else
exportCount = exportCount + 1
End If
' 删除临时图表
If Not chartObj Is Nothing Then
chartObj.Delete
Set chartObj = Nothing
End If
Set tempChart = Nothing
' 再次 DoEvents 确保删除操作完成
DoEvents
' 恢复全局错误处理
On Error GoTo ErrorHandler
End If
Next pic
' 4. 恢复设置并提示
CleanUp:
Application.ScreenUpdating = True
Application.DisplayAlerts = True
Application.Calculation = xlCalculationAutomatic
Application.EnableEvents = True
Dim msg As String
msg = "处理完成！" & vbCrLf & _
"成功导出: " & exportCount & " 张" & vbCrLf & _
"失败/跳过: " & failCount & " 张" & vbCrLf & _
"保存路径: " & savePath
MsgBox msg, IIf(failCount > 0, vbExclamation, vbInformation)
' 清理对象变量
Set pic = Nothing
Set ws = Nothing
Set fd = Nothing
Exit Sub
ErrorHandler:
' 错误处理：确保即使出错也能恢复 Excel 状态
MsgBox "发生未知错误: " & Err.Description, vbCritical
Resume CleanUp
End Sub
