图片导出并重命名+压缩文件，就大神修改下代码

caiqizhong21

图片导出并重命名+批量导入图片，论坛老师们好，这两个代码都是论坛老师写的，我想和起来一起用，导出按钮单独，一个个插入图片能使用，但和AA按钮一起 导出图片文件夹里就是空了，麻烦大神修改下代码

quqiyuan

caiqizhong21

感谢老师完美解决

caiqizhong21

quqiyuan 发表于 2024-7-25 20:53

膜拜大神！！！谢谢老师

gwjkkkkk

Option Explicit
Sub TEST6()
    Dim ar(), br$(), i&, strPath$, strFileName$, strPut$, strPicName$
   
    strPut = InputBox("请设置导出图片的尺寸" & Chr(13) & "输入格式： 宽*高" & "   例如 800*710", "!!!", "800*700")
    If strPut = "" Then Exit Sub
   
    Application.ScreenUpdating = False
   
    br = Split(strPut, "*")
    strPath = ThisWorkbook.Path & "\导出的图片\"
    If Dir(strPath, vbDirectory) = "" Then MkDir strPath
   
    With [A1].CurrentRegion
        ar = .Value
        For i = 2 To UBound(ar)
            If Len(ar(i, 1)) Then
                strPicName = hasPic(.Cells(i, 2))
                If Len(strPicName) Then
                    ActiveSheet.Shapes(strPicName).CopyPicture
                    With ActiveSheet.ChartObjects.Add(0, 0, br(0), br(1))
                        strFileName = strPath & ar(i, 1) & ".png"
                        With .Chart
                            .Parent.Select
                            .Paste
                            .Export FileName:=strFileName
                        End With
                        .Delete
                    End With
                End If
            End If
        Next i
    End With
   
    Application.ScreenUpdating = True
    Beep
End Sub
Function hasPic(Rng As Range) As String
    Dim shp As Shape
    For Each shp In Rng.Parent.Shapes
        If shp.Type = 11 Then
            If Abs((shp.Left + shp.Width / 2) - (Rng.Left + Rng.Width / 2)) < (shp.Width + Rng.Width) / 2 And _
               Abs((shp.Top + shp.Height / 2) - (Rng.Top + Rng.Height / 2)) < (shp.Height + Rng.Height) / 2 Then
                hasPic = shp.Name
                Exit Function
            End If
        End If
    Next
End Function

gwjkkkkk

。。。。。。。。。。。。。。