求助把工作表中的图片另存为，并以前一单元格内容命名

lanjz3

Sub savepic()
Dim shp As Shape, i As Integer
With ActiveSheet
For i = 1 To .Shapes.Count
Set shp = .Shapes(i)
shp.Copy
With .ChartObjects.Add(0, 0, shp.Width, shp, Height).Chart
.Paste
.Export "c:\temp\pic" & i&.gdf
.Parent.Delete
End With
Next
End Sub

lanjz3

恳请高手帮忙改下，谢谢了！
新买了本书，正在学习，还没消化，急用代码，感谢！

lanjz3

前一单元格是6~12位的数字加字母，盼~

lanjz3

自己顶一下，谢谢高手来指点下！

phsu

Sub savepic()
    Dim shp As Shape, i As Integer
    With ActiveSheet
        For i = 1 To .Shapes.Count
            Set shp = .Shapes(i)
            shp.Copy
            With .ChartObjects.Add(0, 0, shp.Width, shp.Height).Chart
                .Paste
                .Export "c:\temp\pic" & ActiveSheet.Cells(i, 1) & .gif
                .Parent.Delete
            End With
        Next
    End With
End Sub

lanjz3

谢谢！我用这个代码代入，还是不行。
我不知道我哪里不对，显示：运行时错误“1004” 应用程序定义或对象定义错误

opiona

1. 
   
2. '********************************************
   
3. '**********  北极狐工作室出品  **************
   
4. '**********  QQ：14885553      **************
   
5. '********************************************
   
6. 
   
7. Sub Opiona()
   
8. 
   
9. 'On Error Resume Next    '// 发生错误，自动执行下一句，就是忽略错误
   
10. Application.ScreenUpdating = False '//关闭屏幕刷新
    
11. Application.DisplayAlerts = False '//关闭系统提示
    
12. t = Timer   '//开始时间
    
13. For Each shap In ActiveSheet.Shapes  '//循环所有图片
    
14.     Set Rng = shap.TopLeftCell  '//Range 对象，它代表位于指定对象左上角下方的单元格
    
15.     'MsgBox shap.Name & "--" & Rng.Address
    
16.     shap.Copy  '//复制图片
    
17.        With ActiveSheet.ChartObjects.Add(0, 0, shap.Width, shap.Height).Chart  '//建立一个新图片
    
18.             .Paste  '//将复制的图片放进去
    
19.             .Export ThisWorkbook.Path & "" & Range(Rng.Address).Value & ".JPG"  '//导出为图片格式，如JPG，GIF
    
20.             .Parent.Delete   '//删除自己建立的图片
    
21.         End With
    
22. Next
    
23. Application.ScreenUpdating = True '//恢复屏幕刷新
    
24. Application.DisplayAlerts = True '//恢复系统提示
    
25. MsgBox "一共用时：" & Format(Timer - t, "#0.0000") & " 秒", , "北极狐提示!!"  '//提示所用时间
    
26. End Sub

复制代码

lanjz3

感谢各位亲回复
最终实现了!代码分享下
Sub savepic()
    Dim shp As Shape, i As Integer
    Dim s As String
    With ActiveSheet
        For i = 1 To .Shapes.Count
            Set shp = .Shapes(i)
            shp.Copy
            With .ChartObjects.Add(0, 0, shp.Width, shp.Height).Chart
                s = "c:\pic\" & ActiveSheet.Cells(i + 1, 1) & ".gif" // excel第一行是空行，所以i要加1,C盘下要有pic目录
                .Paste
                .Export "c:\pic\" & ActiveSheet.Cells(i + 1, 1) & ".gif"
                .Parent.Delete
            End With
        Next
    End With
End Sub

lanjz3

开始中间图片有空的，所以不能执行，要把单元格空图片的行删除

哆睿咪fs

lanjz3 发表于 2015-9-12 09:39
感谢各位亲回复
最终实现了!代码分享下
Sub savepic()

为什么我的运行发生自动化错误