EXCEL如何批量导出图片并命名

暖暖娟

灰太狼GG 发表于 2017-5-11 20:41
香老师，为什么我运行宏后转出的图片都是白色？？

我的也是白的，你的解决了吗？

was_zhang

暖暖娟 发表于 2019-12-10 15:08
我的也是白的，你的解决了吗？

我的也是白图

ankua8

香川群子 发表于 2011-5-27 16:37
显然是发生了"D:\picture\"文件夹不存在的错误。

可以在开始时插入验证文件夹是否存在，

香川群子老师：我在运行导出过程，总是会出现这个错误？

运行代码出错

我的代码是这样的：
Sub yy()
    Dim p As Shape, a$
    f = ThisWorkbook.Path & "\???\"
    If Dir(f, vbDirectory) = "" Then MkDir (f)
        
    For Each C In Range([a3], [a65536].End(3))
  '      a = Mid(c.Value, 2)
        a = C.Value
        C(1, 3).CopyPicture
        With ActiveSheet.ChartObjects.Add(0, 0, 38, 26).Chart
            .Paste
            .Export f & a & ".jpg", "jpg"
            .Parent.Delete
        End With
    Next
End Sub
请老师指导一下，如何修改

蕲春小林

香川群子 发表于 2012-6-29 18:47
导太多图片没有意义啊。你放弃这个想法吧。

为什么我导出全是空白呢。

2324

看了好多贴子,终于找到解决导出图片为空白的办法了


".paste上面插入一句.Parent.select就可以解决导出图片空白的问题。"

Sub PicOutput()
    OpenFile = Application.GetOpenFilename("请选择任一文件后按确定(*.*),*.*", , "选择任一文件确定图片输出文件夹，或取消获得当前文件所在文件夹。")

    If OpenFile = False Then
        myDir = ThisWorkbook.Path & "\"
    Else
        myDir = Left(OpenFile, InStrRev(OpenFile, "\"))
    End If
   
    k = InputBox("1=列左,2=列右,3=上一行,4=下一行,取消=图片所在单元格或无名称", "选择图片名称位置：", 2)
    If k = 1 Then
        r = 0: c = -1
    ElseIf k = 2 Then
        r = 0: c = 1
    ElseIf k = 3 Then
        r = -1: c = 0
    ElseIf k = 4 Then
        r = 1: c = 0
    End If

    k = MsgBox("Yes=按原尺寸,No=按新设定,Cancel=按现在显示", vbYesNoCancel, "输出图片尺寸大小选择")
    For Each p In ActiveSheet.Shapes
        ph = p.Height
        pw = p.Width
        On Error Resume Next
        pn = p.TopLeftCell.Offset(r, c).Value
        If Err.Number <> 0 Then Err.Clear
        If pn = "" Then n = n + 1: pn = Left(ThisWorkbook.Name, InStrRev(ThisWorkbook.Name, ".") - 1) & Format(n, "000")
        
GetPicName:
        On Error Resume Next
        p.Name = pn & ".jpg"
        If Err.Number <> 0 Then
            Err.Clear
            pn = InputBox("图片名称重复,请重新命名", "图片名称重复", pn)
            GoTo GetPicName
        End If
        
        p.Select
        If k = vbYes Then
            Selection.Copy
            ActiveSheet.PasteSpecial Format:="图片 (JPEG)" '英文版为"Picture (JPEG)"
            Selection.Name = "myPic"
        ElseIf k = vbNo Then
            Selection.ShapeRange.LockAspectRatio = msoFalse
            f = InputBox("放大缩小比率", "图片尺寸设定", 2)
            If IsNumeric(f) And f > 0 Then
                Selection.ShapeRange.Height = ph * f
                Selection.ShapeRange.Width = pw * f
            Else
                Selection.ShapeRange.Height = InputBox("重新设定图片高度", "图片高尺寸设定", ph)
                Selection.ShapeRange.Width = InputBox("重新设定图片宽度", "图片宽尺寸设定", pw)
            End If
        End If
        
        Selection.CopyPicture
        With ActiveSheet.ChartObjects.Add(0, 0, Selection.Width + 5, Selection.Height + 5).Chart
            .Parent.Select     
            .Paste
            .Export myDir & p.Name, "JPG"
            .Parent.Delete
        End With
        
        If k = vbYes Then
            ActiveSheet.Shapes("myPic").Delete
        ElseIf k = vbNo Then
            p.Height = ph
            p.Width = pw
        End If
        p.TopLeftCell.Offset(, -1).Select
    Next
   
End Sub

fjndss

2324 发表于 2022-11-8 14:41
看了好多贴子,终于找到解决导出图片为空白的办法了

如果图片存在不同的格式
以上的代码，是不是有一部分图片不能按单元格命名吗

peter-chen

学习了，谢谢

Excel2119

值得肯定，留作记录，用时再查。