如何去除批量导出图片顶边与左边的边框

china047

各位老师:

          我在用网上这段批量导出图片到文件夹的代码中,发现所有导出图片的顶边与左边有带有边框, 如何在导出图片时不要这些边框,请老师们帮忙看一下如何更改代码!
批量导出图片到文件夹.rar (1.63 MB, 下载次数: 4)

2021-10-18 15:31 上传

点击文件名下载附件

Sub 导出图片()
        Dim shp As Shape
        Application.ScreenUpdating = False
        Application.DisplayAlerts = False
        On Error Resume Next

        For Each shp In ActiveSheet.Shapes
            'Set Rng = Shp.TopLeftCell  '//Range 对象，它代表位于指定对象左上角下方的单元格
            r = shp.TopLeftCell.Row
            If shp.TopLeftCell.Column = 2 Then '图片在第二列

                mc = ActiveSheet.Cells(r, 1) '货号在第1列

            End If

            shp.Copy

            'With ActiveSheet.ChartObjects.Add(shp.Top + 1, shp.Left + 1, shp.Width, shp.Height).Chart
            With ActiveSheet.ChartObjects.Add(0, 0, shp.Width + 1, shp.Height + 1).Chart
                .Line.Visible = msoFalse
                .Parent.Select
                .Paste
                .Export ThisWorkbook.Path & "\图片\" & mc & ".JPG" '导出为图片径为当前EXCEL位置的图片文件夹 格式，如JPG，GIF
                .Parent.Delete
            End With
        Next
Application.ScreenUpdating = True
Application.DisplayAlerts = True
End Sub

perfect131

用rar方法获取所有图片也不错，参考以下：https://www.excelhome.net/175.html

3190496160

估计是跟office版本有关吧，楼主可以去我的主题里面去找找，有导出单元格中图片的分享帖子

joforn

将你自己代码修改成：

1. 
   
2. Sub µ¼³öͼƬ()
   
3.         Dim shp As Shape
   
4.         Application.ScreenUpdating = False
   
5.         Application.DisplayAlerts = False
   
6.         On Error Resume Next
   
7.         
   
8.         For Each shp In ActiveSheet.Shapes
   
9.             'Set Rng = Shp.TopLeftCell  '//Range ¶ÔÏó£¬Ëü´ú±íλÓÚÖ¸¶¨¶ÔÏó×óÉϽÇÏ·½µÄµ¥Ôª¸ñ
   
10.             r = shp.TopLeftCell.Row
    
11.             If shp.TopLeftCell.Column = 2 Then 'ͼƬÔÚµÚ¶þÁÐ
    
12.                
    
13.                 mc = ActiveSheet.Cells(r, 1) '»õºÅÔÚµÚ1ÁÐ
    
14.            
    
15.             End If
    
16.             
    
17.             shp.Copy
    
18.             If SaveClipboardToPictrue(ThisWorkbook.Path & "\ͼƬ" & mc & ".JPG") Then
    
19.             
    
20.             End If
    
21. '            'With ActiveSheet.ChartObjects.Add(shp.Top + 1, shp.Left + 1, shp.Width, shp.Height).Chart
    
22. '            With ActiveSheet.ChartObjects.Add(0, 0, shp.Width + 1, shp.Height + 1).Chart
    
23. '                .Line.Visible = msoFalse
    
24. '                .Parent.Select
    
25. '                .Paste
    
26. '                .Export ThisWorkbook.Path & "\ͼƬ" & mc & ".JPG" 'µ¼³öΪͼƬ¾¶Îªµ±Ç°EXCELλÖõÄͼƬÎļþ¼Ð ¸ñʽ£¬ÈçJPG£¬GIF
    
27. '                .Parent.Delete
    
28. '            End With
    
29.         Next
    
30. Application.ScreenUpdating = True
    
31. Application.DisplayAlerts = True
    
32. End Sub
    

复制代码

SaveClipboardToPictrue代码在basSaveRangeToPictrue模块中，从https://club.excelhome.net/thread-1565669-1-1.html下载附件，将文件中的basSaveRangeToPictrue导入到你自己的文件中，然后按上面的代码修改好自己的Sub后，运行 导出图片() 过程

joforn

注意：楼上代码段里面的中文被自动转码了，不想改了，如果要用上面的代码的话，自己修改一下吧。

疯狂的肥肉

请您参考！

china047

joforn 发表于 2021-10-18 20:52
将你自己代码修改成：

SaveClipboardToPictrue代码在basSaveRangeToPictrue模块中，从https://club.exce ...

没看懂！

china047

joforn 发表于 2021-10-18 21:03
注意：楼上代码段里面的中文被自动转码了，不想改了，如果要用上面的代码的话，自己修改一下吧。

可以了，多谢joforn