Excel2010VBA批量插入或导出图片

54mikeho

Excel2010VBA批量插入或导出图片.rar (27.27 KB, 下载次数: 386)

2018-2-26 10:25 上传

点击文件名下载附件
Excel2010VBA批量插入或导出图片

以前用Excel2003做了些处理图片的宏，因一些功能在Excel2010中无法使用，故在2014年重新用Excel2010进行了整理，欢迎指正；

本Excel中的宏在Excel2010中测试表现出色;

运行宏前，要保证EXCEL没有禁用宏。

本Excel有以下功能：

插入图片1

1.点击执行后，会出现文件夹选择窗，请选择你JPG图片所在文件夹(选择“文件夹”而不是选择文件)；

2.宏会自动复制Sheet2到新工作簿，并插入你所选文件夹中的全部JPG图片到B列，对应的图片名自动填到C列；

3.图片的大小会自动适应Sheet2的B3单元格，因此可以在点击执行前调整Sheet2的B3单元格的大小来控制插入图片的大小。

--------

插入图片2

1.点击执行后，会出现文件夹选择窗，请选择你JPG图片所在文件夹(选择“文件夹”而不是选择文件)；

2.宏会自动复制Sheet3到新工作簿，并插入你所选文件夹中的全部JPG图片制作图册，对应的图片名自动填到图片下方；

--------

插入图片3

如果用户自己的Excel文件中有一列是型号，该宏可以插入指定文件夹里以型号命名的JPG图片到另一列；

1.打开本Excel文件，不要关闭；

2.再另外打开你自己需要操作的另一个Excel文件，并保持你要操作的工作表做为当前活动工作表；

3.在你的文件中按Ctrl+I (或在你的文件中手动执行宏，然后选择本EXCEL文件中的宏InsertPic3）；

4.然后会出现文件夹选择窗，请选择你JPG图片所在文件夹(选择“文件夹”而不是选择文件)；

5.在弹出的对话框中指定型号在第几列，图片要插入到第几列，以及从哪一行开始；

6.图片的大小会自动适应你设定的第一行要插入图片的单元格，因此提前调整那个单元格的大小可以控制插入图片的大小。

-------------

删除活动工作表中所有图片     Ctrl+d

删除活动工作表里所有的JPG图片，（不一定是本工作簿中的工作表）；

1.打开本Excel文件，不要关闭；

2.再另外打开你自己需要操作的另一个Excel文件，并保持你要操作的工作表做为当前活动工作表；

3.在你的文件中按Ctrl+d (或在你的文件中手动执行宏，然后选择本EXCEL文件中的宏DelPic）；

-------------

导出活动工作表中被选中的一张JPG图片   Ctrl+e

导出活动工作表中被选中的一张JPG图片，（不一定是本工作簿中的工作表）；

1.打开本Excel文件，不要关闭；

2.再另外打开你自己需要操作的另一个Excel文件，并保持你要操作的工作表做为当前活动工作表；

3.请选中一张要导出的图片；

4.在你的文件中按Ctrl+e (或在你的文件中手动执行宏，然后选择本EXCEL文件中的宏OutputOnePic）；

5.在弹出的对话框中指定图片要保存的名字；

1.不管图片在Excel中是否被缩放过，导出的图片是按图片的原始尺寸进行保存。

2.在桌面上会自动新建一个"OutputPic"的文件夹，导出的图片将会存在那个文夹里；

3.如果文件夹中已有相同名字的文件，则后面导出的文件会自动加上(v1), (v2), (v3)...

-------------

导出活动工作表中所有JPG图片   Ctrl+f

导出活动工作表中所有JPG图片，并且图片名自动使用指定列中的图片名；

1.打开本Excel文件，不要关闭；

2.再另外打开你自己需要操作的另一个Excel文件，并保持你要操作的工作表做为当前活动工作表；

3.在你的文件中按Ctrl+f (或在你的文件中手动执行宏，然后选择本EXCEL文件中的宏OutputAllPic）；

4.在弹出的对话框中指定图片所在列，图片名所在的列；

1.不管图片在Excel中是否被缩放过，导出的图片是按图片的原始尺寸进行保存；

2.在桌面上会自动新建一个"OutputPic"的文件夹，所有导出的图片将会存在那个文夹里；

3.如果文件夹中已有相同名字的文件，则后面导出的文件会自动加上(v1), (v2), (v3)...

----------------

对指定文件夹中的JPG图片进行重命名   Ctrl+r

利用活动工作表中的所有图片的旧名与新名的对照，对指定文件夹中JPG图片进行重命名；

1.打开本Excel文件，不要关闭；

2.再另外打开你自己需要操作的另一个Excel文件，并保持你要操作的工作表做为当前活动工作表；

3.在你的文件中按Ctrl+r (或在你的文件中手动执行宏，然后选择本EXCEL文件中的宏RenamePic）；

4.在弹出的对话框中指定图片旧名所在列和图片新名所在的列；

1.可以结合插入图片的宏，将所有图片的旧名输入到Excel中，再在另一列中填上新图片名，然后使用该宏。

2.如果顺利运行，会在原来那个文件夹下面新建一个叫“New”的子文件夹，所有重命好名的图片会自动放入子文件夹里；

3.如果文件夹中已有相同名字的文件，则后面的文件会覆盖原来的文件。

54mikeho

前面一个有些小问题导致有些情况下不能运行，重新更新了一下。以这个为准。
Excel2010批量插入图片批量输入图片批量改名.rar (31.69 KB, 下载次数: 511)

2018-3-8 19:31 上传

点击文件名下载附件

249282332

可以开源吗？或者将OutputOnePic贴出来，谢谢，不开源这样分享没意义

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

wyh73693

请问一下，为啥导出的图片是空白的，我的是office2016

careso

请问。我需要多个格式图片要怎么办？

风筝那根线

正在找导出高清图片  谢谢分享

seulove

很赞。。。。。。。

仙人不留果

要死了，cont+D, 填充了一下单元格，保存后忙别的，
再回来图片全没了，我的天，一直在找为什么图片没了，刚刚看到文件里面这个键是删除图片，
一个多月的工作

li2653

谢谢分享谢谢分享