麻烦大神能帮我写一个EXCEL VBA宏批量导出A列图片并按B列命名

Wei_Ran_

爱疯 发表于 2020-3-27 15:03
Sub test()
    Dim p, i, x, y
    p = ThisWorkbook.Path & "\"

我没有明白修改后面不用再修改的意思，我用新的编码试过，最开始有遗漏的现在导出了几张，但是后面仍然有导漏的，并且从那张开始，后面的全部都没有导出，并且导出的图片分辨率比文件中的图片差了很多，麻烦大神再指教一下，谢谢！

Wei_Ran_

爱疯 发表于 2020-3-27 15:03
Sub test()
    Dim p, i, x, y
    p = ThisWorkbook.Path & "\"

后来连续试了多次，结果图片是可以全部导出，但是出现图片名称命名时错位，这个问题要如何解决呀？

爱疯

Sub test()
    Dim shp As Shape
    Dim m As Integer
    m = 10
    For Each shp In Sheets(1).Shapes
        With shp
            .Top = .Top + m: .Left = .Left + m    '调整
            Call Chart2Pic(shp, .TopLeftCell.Offset(1, 0))
            .Top = .Top - m: .Left = .Left - m    '恢复
        End With
    Next
End Sub


'导出(对象, 文件名)
Sub Chart2Pic(shp As Shape, f As String)
    shp.CopyPicture Appearance:=xlScreen, Format:=xlBitmap                  '将所选对象作为图片复制到剪贴板
    With ActiveSheet.ChartObjects.Add(0, 0, shp.Width, shp.Height).Chart    '创建嵌入式图表
        .Paste                                                              '将剪贴板中的图表数据粘贴到指定的图表中
        .Export Filename:=ThisWorkbook.Path & "\" & f & ".jpg"              '以图形格式导出图表
        .Parent.Delete
    End With
End Sub




说明：
每个图片无论是否准确放入单元格（可能有的图片微微往左或往上，超出原来指定的单元格，肉眼很难发现）
1）调整。即 往右往下 移动10磅，这就几乎可保证 .TopLeftCell 正确
2）保存图片文件
3）恢复。

Wei_Ran_

爱疯 发表于 2020-3-30 09:23
Sub test()
    Dim shp As Shape
    Dim m As Integer

您好，感谢大神帮助，现在用最后这个编码，图片已经可以全部横向批量按照对应名称导出，美中不足是导出的图片分辨率大大降低，再次按文件名匹配图片上来时，图片放大基本上都看不清楚了，请问能否将原文件中的图片不降低分辨率的情况下批量导出呢？

爱疯

不明白"再次"是什么意思?


xlScreen 可换为 xlPrinter
xlBitmap 可换为 xlPicture
但我感觉换不换，效果差不多。
我不知道其它的，更好效果的方法了

Wei_Ran_

爱疯 发表于 2020-3-30 17:46
不明白"再次"是什么意思?

“再次”是指，我将批量导出好的图片文件，按照名称，通过VBA将图片批量导入表格后，图片的显示分辨率很低。

感谢大神的回复指导，谢谢啦！

爱疯

建议单独发帖，更易被关注，也许其他朋友有更好的方法。
另外附件中，也有导入代码，以便测试。