[已解决]代码疑难，高手看哈

白云无尽9987

n.rar (9.04 KB, 下载次数: 21)

2015-5-22 18:42 上传

点击文件名下载附件

最佳答案

月排行榜 / 总排行榜

xdragon

2015-5-23 14:03

1. Sub main()
   
2.     Dim Rng As Range, Desktop As String
   
3.     If TypeName(Selection) <> "Range" Then MsgBox "必须选择单元格！", , "提示": Exit Sub
   
4.     If Selection.Areas.Count > 1 Then MsgBox "只能选择一个区域！", , "提示": Exit Sub
   
5.     Set Rng = Range("A2:B5")
   
6.     Desktop = CreateObject("WScript.Shell").SpecialFolders("Desktop")
   
7.     Rng.CopyPicture Appearance:=xlScreen, Format:=xlBitmap
   
8.     ActiveSheet.Pictures.Paste.Select
   
9.     With Selection
   
10.         .Copy
    
11.         With ActiveSheet.ChartObjects.Add(0, 0, Selection.Width, Selection.Height).Chart
    
12.             .Paste
    
13.             .Export Desktop & "" & Range("A1") & ".jpg"
    
14.             .Parent.Delete
    
15.         End With
    
16.         .Delete
    
17.     End With
    
18. '    Shell "explorer.exe " & Desktop, vbMaximizedFocus  '打开文件夹
    
19. End Sub

复制代码

跳转到最佳答案楼层

xdragon

1. Sub main()
   
2.     Dim Ads As String, Desktop As String
   
3.     If TypeName(Selection) <> "Range" Then MsgBox "必须选择单元格！", , "提示": Exit Sub
   
4.     If Selection.Areas.Count > 1 Then MsgBox "只能选择一个区域！", , "提示": Exit Sub
   
5.     Ads = VBA.Replace(VBA.Replace(Selection.Address, ":", "-"), "$", "")
   
6.     Desktop = CreateObject("WScript.Shell").SpecialFolders("Desktop")
   
7.     Selection.CopyPicture Appearance:=xlScreen, Format:=xlBitmap
   
8.     ActiveSheet.Pictures.Paste.Select
   
9.     With Selection
   
10.         .Copy
    
11.         With ActiveSheet.ChartObjects.Add(0, 0, Selection.Width, Selection.Height).Chart
    
12.             .Paste
    
13.             .Export Desktop & "" & Ads & ".jpg"
    
14.             .Parent.Delete
    
15.         End With
    
16.         .Delete
    
17.     End With
    
18. '    Shell "explorer.exe " & Desktop, vbMaximizedFocus  '打开文件夹
    
19. End Sub
    

复制代码

不知道你的区域会不会改，所以我是根据选中的单元格来确定导出图片的范围的。如果你要改成固定的，你把selection.address 改成你想要的单元格就可以了。

白云无尽9987

xdragon 发表于 2015-5-22 23:57
不知道你的区域会不会改，所以我是根据选中的单元格来确定导出图片的范围的。如果你要改成固定的，你把sele ...

高手高手高高手！！！啊，太感谢了！！！

白云无尽9987

xdragon 发表于 2015-5-22 23:57
不知道你的区域会不会改，所以我是根据选中的单元格来确定导出图片的范围的。如果你要改成固定的，你把sele ...

改成固定区域A2:B5,怎么改？——不要笑喷啊，我什么也不懂的，劳烦！

xdragon

1. Sub main()
   
2.     Dim Rng As Range, Desktop As String
   
3.     If TypeName(Selection) <> "Range" Then MsgBox "必须选择单元格！", , "提示": Exit Sub
   
4.     If Selection.Areas.Count > 1 Then MsgBox "只能选择一个区域！", , "提示": Exit Sub
   
5.     Set Rng = Range("A2:B5") '如果需要更改区域只需要更改这里的就可以了。
   
6.     Desktop = CreateObject("WScript.Shell").SpecialFolders("Desktop")
   
7.     Rng.CopyPicture Appearance:=xlScreen, Format:=xlBitmap
   
8.     ActiveSheet.Pictures.Paste.Select
   
9.     With Selection
   
10.         .Copy
    
11.         With ActiveSheet.ChartObjects.Add(0, 0, Selection.Width, Selection.Height).Chart
    
12.             .Paste
    
13.             .Export Desktop & "" & VBA.Replace(VBA.Replace(Rng.Address, ":", "-"), "$", "") & ".jpg"
    
14.             .Parent.Delete
    
15.         End With
    
16.         .Delete
    
17.     End With
    
18. '    Shell "explorer.exe " & Desktop, vbMaximizedFocus  '打开文件夹
    
19. End Sub
    

复制代码

白云无尽9987

xdragon 发表于 2015-5-23 12:33

②、③完美解决，①还没有做到————请问能以单元格A1里的内容为文件名吗？！~谢谢！

xdragon

1. Sub main()
   
2.     Dim Rng As Range, Desktop As String
   
3.     If TypeName(Selection) <> "Range" Then MsgBox "必须选择单元格！", , "提示": Exit Sub
   
4.     If Selection.Areas.Count > 1 Then MsgBox "只能选择一个区域！", , "提示": Exit Sub
   
5.     Set Rng = Range("A2:B5")
   
6.     Desktop = CreateObject("WScript.Shell").SpecialFolders("Desktop")
   
7.     Rng.CopyPicture Appearance:=xlScreen, Format:=xlBitmap
   
8.     ActiveSheet.Pictures.Paste.Select
   
9.     With Selection
   
10.         .Copy
    
11.         With ActiveSheet.ChartObjects.Add(0, 0, Selection.Width, Selection.Height).Chart
    
12.             .Paste
    
13.             .Export Desktop & "" & Range("A1") & ".jpg"
    
14.             .Parent.Delete
    
15.         End With
    
16.         .Delete
    
17.     End With
    
18. '    Shell "explorer.exe " & Desktop, vbMaximizedFocus  '打开文件夹
    
19. End Sub

复制代码

白云无尽9987

xdragon 发表于 2015-5-23 14:03

感激不尽！{:021:}