导出图表的图片

朱付安

我的需求是导出B列的图片，并以A列对应的名称命名，导出的文件图片保存到桌面，谢谢

欧陈养

参考一下

quqiyuan

供参考吧
D列合并单元格取消
图片保存到桌面，文件夹叫图片，没有的话会创建，有就不管，这个你可以自己修改，代码能自动获取桌面的位置

ykcbf1100

学一个。。。
更新一下，保存到桌面

ykcbf1100

学习一下。。。

1. Sub ykcbf()   '//2024.5.31   图片导出
   
2.     Application.ScreenUpdating = False
   
3.     p = CreateObject("Wscript.Shell").SpecialFolders("Desktop") & ""
   
4.     With Sheets("Sheet1")
   
5.         Set pic = .ChartObjects.Add(0, 0, 1, 1)
   
6.         For Each shp In .Shapes
   
7.             Set Rng = shp.TopLeftCell
   
8.             If Rng.Column = 3 Then
   
9.                 With pic
   
10.                     .Width = shp.Width
    
11.                     .Height = shp.Height
    
12.                     shp.CopyPicture
    
13.                     .Chart.ChartArea.Fill.Visible = False
    
14.                     .Chart.ChartArea.Border.LineStyle = xlLineStyleNone
    
15.                     .Select
    
16.                     .Chart.Paste
    
17.                     .Chart.Export p & Rng.Offset(, -2) & ".jpg"
    
18.                 End With
    
19.             End If
    
20.         Next
    
21.     End With
    
22.     pic.Delete
    
23.     Application.ScreenUpdating = True
    
24.     MsgBox "OK！"
    
25. End Sub
    
26. 
    

复制代码

quqiyuan

代码参考

Sub test()
tm = Timer
Dim shp As Shape, chtObj As ChartObject
Set fso = CreateObject("scripting.filesystemobject")
With Sheet1
    Set chtObj = .ChartObjects.Add(0, 0, 1, 1)
    Set oWShell = CreateObject("WScript.Shell")
        sDesktopPath = oWShell.SpecialFolders("Desktop")
        sDesktopPath = sDesktopPath & "\图片\"
        If Not fso.FolderExists(sDesktopPath) Then fso.createfolder (sDesktopPath)
    For Each shp In .Shapes
        If shp.TopLeftCell.Column = 4 Then
            With chtObj
                .Width = shp.Width: .Height = shp.Height
                shp.CopyPicture
                .Chart.ChartArea.Fill.Visible = False
                .Chart.ChartArea.Border.LineStyle = xlLineStyleNone
                .Select
                .Chart.Paste
                .Chart.Export sDesktopPath & shp.TopLeftCell.Offset(0, -3) & ".jpg"
            End With
        End If
    Next
End With
chtObj.Delete
Beep
MsgBox "共耗时：" & Timer - tm & "秒！！"
End Sub

朱付安

谢谢各位老师

朱付安

quqiyuan 发表于 2024-5-31 15:40
供参考吧
D列合并单元格取消
图片保存到桌面，文件夹叫图片，没有的话会创建，有就不管，这个你可以自己 ...

老师，最后保存图片是，弹出保存对话框，我不想要直接保存到桌面，谢谢

quqiyuan

朱付安 发表于 2024-5-31 19:27
老师，最后保存图片是，弹出保存对话框，我不想要直接保存到桌面，谢谢

供参考