【excel导出图片】并按同行固定列数值命名

马甲大队长

活在理想的世界 发表于 2018-6-25 16:18
这是A方案，至于B方案。。。。自己手动操作一下吧。

谢谢大佬指点，但是我传的这个表只是做个演示，实际文档里面数据是成千的，所以方案B不适用的

活在理想的世界

马甲大队长 发表于 2018-6-26 09:00
谢谢大佬指点，但是我传的这个表只是做个演示，实际文档里面数据是成千的，所以方案B不适用的

b方案适用。
会操作fso对象吗？如果会的话用b方案可实现自动另存，重命名，移动。
需要工作簿，工作表，数组，shape，fso5个对象相互配合，逻辑麻烦一点，但速度快的多。

活在理想的世界

当时给你写a方案是因为方便，不用动脑子就可以写。
b方案让你手动操作是认为没几张图片，而且图片质量会更好，能解决问题。如果手动写代码得在Excel和文件夹直接来回切换和调试，所以懒得写。
其实b方案是更好的方法，是完美解决方案。

活在理想的世界

现在我在外边，还没办法分享。

咸味

活在理想的世界 发表于 2018-6-25 17:06

理想哥！刚刚求助了一个类似的！好好研究一下你的代码先，有空帮看看！

马甲大队长

活在理想的世界 发表于 2018-6-26 09:47
当时给你写a方案是因为方便，不用动脑子就可以写。
b方案让你手动操作是认为没几张图片，而且图片质量会更 ...

http://club.excelhome.net/thread-1414472-1-1.html
我看到这个帖子里面的东西实现了我想要的效果,命名是没问题了,但是!    win10 1803 64位,excel 2016正版,导出图片全是空白,  就下载的帖子里面那个"箱子2"文件导出都是空白,   这个问题有办法解决么==

活在理想的世界

马甲大队长 发表于 2018-7-6 10:26
http://club.excelhome.net/thread-1414472-1-1.html
我看到这个帖子里面的东西实现了我想要的效果,命名 ...

你导出来的是什么图片？批注里面的图片吗？
如果是批注里面的图片那就对了。

否则就有问题。

活在理想的世界

马甲大队长 发表于 2018-7-6 10:26
http://club.excelhome.net/thread-1414472-1-1.html
我看到这个帖子里面的东西实现了我想要的效果,命名 ...

你给我的连接我没看，如果有问题直接在这里跟我沟通好了。

54mikeho

Excel2010VBA批量插入或导出图片
http://club.excelhome.net/thread-1398438-1-1.html
(出处: ExcelHome技术论坛)

54mikeho

Sub OutputAllPic()  '导出活动工作表（不一定是本工作簿中的工作表）里所有的JPG图片到...\桌面\OutputPic\

On Error GoTo ErrLabel

Application.ScreenUpdating = False

Dim theSh As Shell32.Shell
Dim X, Y, Z As Integer
Dim ExptPath, ItmNo As String
     
     X = Val(InputBox("图片在第几列(填数字):", , 2))
     Y = Val(InputBox("型号在第几列(填数字):", , 1))
     
     Const theCUDesktop = 16
     Set theSh = New Shell32.Shell
     
         ExptPath = theSh.Namespace(theCUDesktop).Items.Item.Path & "\OutputPic\"
         
         If Dir(ExptPath, 16) = "" Then   '如果文件夹不存在
            
             MkDir ExptPath  '建立文件夹
         
         End If
         
         Z = 1
         
         Do While True
           
              ExptPath = theSh.Namespace(theCUDesktop).Items.Item.Path & "\OutputPic\" & Z    '当前用户桌面上文件夹"OutputPic\1", "OutputPic\2".....
           
              If Dir(ExptPath, 16) = "" Then   '如果文件夹不存在
            
                 MkDir ExptPath  '建立文件夹
         
                 Exit Do
           
              End If
           
              Z = Z + 1
         Loop


     
For Each shp In ActiveSheet.Shapes
     
     If shp.Type = 11 Or shp.Type = 13 And shp.TopLeftCell.Column = X Then
         
         shp.Select
         
         Dim P As Integer
         
         P = shp.TopLeftCell.Row
                  
         Do While True
                  
             If Cells(P, 1).Top > shp.Top + shp.Height / 2 Then
               
                Exit Do
               
             End If

             P = P + 1
                     
         Loop
         P = P - 1
         
         ItmNo = ActiveSheet.Cells(P, Y)
         ItmNo = Replace(ItmNo, "\", "-")
         ItmNo = Replace(ItmNo, "/", "-")
         ItmNo = Replace(ItmNo, ":", "-")
         ItmNo = Replace(ItmNo, "*", "x")
         ItmNo = Replace(ItmNo, "?", "")
         ItmNo = Replace(ItmNo, """", "in")
         ItmNo = Replace(ItmNo, ">", "")
         ItmNo = Replace(ItmNo, "<", "")
         ItmNo = Replace(ItmNo, "|", "")
         ItmNo = Replace(ItmNo, "+", "Plus")
         ItmNo = Replace(ItmNo, "&", "-")
         ItmNo = Trim(ItmNo)
         
         Z = 1
         
         Do While True
           
           If Z > 1 Then
              ItmNo = ItmNo & "(v" & Z & ")"
           End If
                    
           FileYN = Dir(ExptPath & "\" & ItmNo & ".jpg")
           
           If FileYN = "" Then
              Exit Do
           
           End If
           
           Z = Z + 1
         Loop

         w1 = Selection.Width
         h1 = Selection.Height
         
         Selection.ShapeRange.ScaleWidth 1, msoTrue, msoScaleFromTopLeft
         Selection.ShapeRange.ScaleHeight 1, msoTrue, msoScaleFromTopLeft
         Selection.CopyPicture
         
         w2 = Selection.Width
         h2 = Selection.Height
         
         Selection.Width = w1
         Selection.Height = h1

         With ActiveSheet.ChartObjects.Add(0, 0, w2, h2).Chart
            .Paste
            .Export ExptPath & "\" & ItmNo & ".jpg"
            .Parent.Delete
         End With
         
     End If
     
Next

Application.ScreenUpdating = True

Exit_Label:
     Exit Sub
     
ErrLabel:
     MsgBox Err.Description

End Sub