EXCEL如何批量导出图片并命名

香川群子

原帖由 晨曦矇眬 于 2010-9-10 17:14 发表
请问版主：如何控制导出图片的大小尺寸？能否麻烦您简要说明一下宏中的主要参数？
并帮忙在附件中录入宏。（宏件中的宏图片在A列，型号在B列）
非常感谢！

Sub 遍历图片并输出()
    OpenFile = Application.GetOpenFilename("请选择任一文件后按确定(*.*),*.*", , "选择任一文件确定图片输出文件夹，或取消获得当前文件所在文件夹。")

    If OpenFile = False Then
        myDir = ThisWorkbook.Path & "\"
    Else
        myDir = Left(OpenFile, InStrRev(OpenFile, "\"))
    End If
   
    k = InputBox("1=列左,2=列右,3=上一行,4=下一行,取消=图片所在单元格或无名称", "选择图片名称位置:", 2)
    If k = 1 Then
        r = 0: c = -1
    ElseIf k = 2 Then
        r = 0: c = 1
    ElseIf k = 3 Then
        r = -1: c = 0
    ElseIf k = 4 Then
        r = 1: c = 0
    End If

    k = MsgBox("Yes=按原尺寸,No=按新设定,Cancel=按现在显示", vbYesNoCancel, "输出图片尺寸大小选择")
    For Each p In ActiveSheet.Shapes
        ph = p.Height
        pw = p.Width
        On Error Resume Next
        pn = p.TopLeftCell.Offset(r, c).Value
        If Err.Number <> 0 Then Err.Clear
        If pn = "" Then n = n + 1: pn = Left(ThisWorkbook.Name, InStrRev(ThisWorkbook.Name, ".") - 1) & Format(n, "000")
        
GetPicName:
        On Error Resume Next
        p.Name = pn & ".jpg"
        If Err.Number <> 0 Then
            Err.Clear
            pn = InputBox("图片名称重复,请重新命名", "图片名称重复", pn)
            GoTo GetPicName
        End If
        
        p.Select
        If k = vbYes Then
            Selection.Copy
            ActiveSheet.PasteSpecial Format:="图片 (JPEG)" '英文版为"Picture (JPEG)"
            Selection.Name = "myPic"
        ElseIf k = vbNo Then
            Selection.ShapeRange.LockAspectRatio = msoFalse
            f = InputBox("放大缩小比率", "图片尺寸设定", 2)
            If IsNumeric(f) And f > 0 Then
                Selection.ShapeRange.Height = ph * f
                Selection.ShapeRange.Width = pw * f
            Else
                Selection.ShapeRange.Height = InputBox("重新设定图片高度", "图片高尺寸设定", ph)
                Selection.ShapeRange.Width = InputBox("重新设定图片宽度", "图片宽尺寸设定", pw)
            End If
        End If
        
        Selection.CopyPicture
        With ActiveSheet.ChartObjects.Add(0, 0, Selection.Width + 5, Selection.Height + 5).Chart
            .Paste
            .Export myDir & p.Name, "JPG"
            .Parent.Delete
        End With
        
        If k = vbYes Then
            ActiveSheet.Shapes("myPic").Delete
        ElseIf k = vbNo Then
            p.Height = ph
            p.Width = pw
        End If
        p.TopLeftCell.Offset(r, c).Select
    Next
   
End Sub

香川群子

原帖由 andyyan 于 2009-9-4 22:47 发表
如何导出B列中的所有图片，并以A列的货号做为图片的名称。非常感谢，问题请看附件。

楼主看我的改进加强版。

Sub PicOutput()
    OpenFile = Application.GetOpenFilename("请选择任一文件后按确定(*.*),*.*", , "选择任一文件确定图片输出文件夹，或取消获得当前文件所在文件夹。")

    If OpenFile = False Then
        myDir = ThisWorkbook.Path & "\"
    Else
        myDir = Left(OpenFile, InStrRev(OpenFile, "\"))
    End If
   
    k = InputBox("1=列左,2=列右,3=上一行,4=下一行,取消=图片所在单元格或无名称", "选择图片名称位置：", 2)
    If k = 1 Then
        r = 0: c = -1
    ElseIf k = 2 Then
        r = 0: c = 1
    ElseIf k = 3 Then
        r = -1: c = 0
    ElseIf k = 4 Then
        r = 1: c = 0
    End If

    k = MsgBox("Yes=按原尺寸,No=按新设定,Cancel=按现在显示", vbYesNoCancel, "输出图片尺寸大小选择")
    For Each p In ActiveSheet.Shapes
        ph = p.Height
        pw = p.Width
        On Error Resume Next
        pn = p.TopLeftCell.Offset(r, c).Value
        If Err.Number <> 0 Then Err.Clear
        If pn = "" Then n = n + 1: pn = Left(ThisWorkbook.Name, InStrRev(ThisWorkbook.Name, ".") - 1) & Format(n, "000")
        
GetPicName:
        On Error Resume Next
        p.Name = pn & ".jpg"
        If Err.Number <> 0 Then
            Err.Clear
            pn = InputBox("图片名称重复,请重新命名", "图片名称重复", pn)
            GoTo GetPicName
        End If
        
        p.Select
        If k = vbYes Then
            Selection.Copy
            ActiveSheet.PasteSpecial Format:="图片 (JPEG)" '英文版为"Picture (JPEG)"
            Selection.Name = "myPic"
        ElseIf k = vbNo Then
            Selection.ShapeRange.LockAspectRatio = msoFalse
            f = InputBox("放大缩小比率", "图片尺寸设定", 2)
            If IsNumeric(f) And f > 0 Then
                Selection.ShapeRange.Height = ph * f
                Selection.ShapeRange.Width = pw * f
            Else
                Selection.ShapeRange.Height = InputBox("重新设定图片高度", "图片高尺寸设定", ph)
                Selection.ShapeRange.Width = InputBox("重新设定图片宽度", "图片宽尺寸设定", pw)
            End If
        End If
        
        Selection.CopyPicture
        With ActiveSheet.ChartObjects.Add(0, 0, Selection.Width + 5, Selection.Height + 5).Chart
            .Paste
            .Export myDir & p.Name, "JPG"
            .Parent.Delete
        End With
        
        If k = vbYes Then
            ActiveSheet.Shapes("myPic").Delete
        ElseIf k = vbNo Then
            p.Height = ph
            p.Width = pw
        End If
        p.TopLeftCell.Offset(, -1).Select
    Next
   
End Sub

lbl016

楼主的问题是导出图片，我现在的问题是想导入图片。请问：怎样批量导入图片，比如将D盘的"图片"文件夹中的图片导入到B列，并且图片的名称与A列的货号相对应名称，应如何设置宏代码。

[ 本帖最后由 lbl016 于 2010-9-12 07:16 编辑 ]

ammyc

收藏学习。

香川群子

原帖由 lbl016 于 2010-9-12 07:13 发表
楼主的问题是导出图片，我现在的问题是想导入图片。请问：怎样批量导入图片，比如将D盘的"图片"文件夹中的图片导入到B列，并且图片的名称与A列的货号相对应名称，应如何设置宏代码。

这个更简单啊。参考：
http://club.excelhome.net/thread-611346-1-1.html

改进版，39种图片格式自动导入图片及名称
Sub 单元格自动插入图片()
    Pf = "ai,"
    Pf = Pf & "bmp,bmz"
    Pf = Pf & "cdr,cgm,"
    Pf = Pf & "dib,dwg,dxf,"
    Pf = Pf & "emf,emz,eps,exf,exif,"
    Pf = Pf & "fpx,"
    Pf = Pf & "gfa,gif,"
    Pf = Pf & "hdr,"
    Pf = Pf & "ico,"
    Pf = Pf & "jfif,jpe,jpeg,jpg,"
    Pf = Pf & "pcd,pct,pcx,pcz,pict,png,psd,"
    Pf = Pf & "raw,rle,"
    Pf = Pf & "svg,"
    Pf = Pf & "tga,tif,tiff,"
    Pf = Pf & "ufo,"
    Pf = Pf & "wdp,wmf,wmz,"
   
    K = InputBox("插入行数，1=按列挿入", "插入行数", 1)
    If K = "" Then Exit Sub

    Dim Rng  As Range: Set Rng = ActiveCell
    OpenFile = Application.GetOpenFilename("Picture Files(*.*),*.*", , "Get Picture from here!")

    If OpenFile = False Then
        myDir = ThisWorkbook.Path & "\"
    Else
        myDir = Left(OpenFile, InStrRev(OpenFile, "\"))
    End If
    Application.ScreenUpdating = False
   
    Filename = Dir(myDir)
   
    Do While Filename <> ""
        If InStr(Pf, LCase(Right(Filename, Len(Filename) - InStrRev(Filename, ".")))) > 0 Then
            Rng.Cells(1 + n \ K, n Mod K + 1).Select
            ActiveCell = Filename 'Left(Filename, InStrRev(Filename, ".") - 1)
            
            ActiveSheet.Pictures.Insert(myDir & Filename).Select
            With Selection
                .Placement = xlMoveAndSize
                .ShapeRange.LockAspectRatio = msoFalse
                .Top = ActiveCell.Top
                .Left = ActiveCell.Left
                .Height = ActiveCell.Height
                .Width = ActiveCell.Width
            End With
            n = n + 1
        End If
        Filename = Dir
    Loop
    Application.ScreenUpdating = True
    Rng.Select
End Sub

lbl016

香川群子老师，能否做到输入一个人的姓名或其他信息就直接从图片库中调入其照片到指定位置。（图片库中照片与其人的姓名或其他信息相对应）

[ 本帖最后由 lbl016 于 2010-9-12 10:24 编辑 ]

晨曦矇眬

香川群子老师，您在22楼及23楼所编VBA确实解决了图片导出问题，但是导出的图片文件名或为“箱子1、箱子2、箱子3”或为“批量导出图片1、批量导出图片2、批量导出图片3”，并没有按照某列自动命名为“YF0002-447-01、YF0002-447-02、YG0013-347-01”，请帮忙解决！~（最好可以临时选择“按B列命名或按A列命名”）
感激不尽！

香川群子

原帖由 晨曦矇眬 于 2010-9-12 11:13 发表
香川群子老师，您在22楼及23楼所编VBA确实解决了图片导出问题，但是导出的图片文件名或为“箱子1、箱子2、箱子3”或为“批量导出图片1、批量导出图片2、批量导出图片3”，并没有按照某列自动命名为“YF0002-447-01、 ...

可以选择的呀。

稍微又改了一下。
自己琢磨一下附件吧。

晨曦矇眬

香川群子老师，您太伟大啦！帮了大忙！

香川群子

Public FilePath As String
Public SubDir As Boolean
Declare Function SHBrowseForFolder Lib "shell32.dll" Alias "SHBrowseForFolderA" (lpBrowseInfo As FolderInfor) As Long
Declare Function SHGetPathFromIDList Lib "shell32.dll" Alias "SHGetPathFromIDListA" (ByVal pidl As Long, ByVal pszPath As String) As Long
Private Declare Function FindWindow Lib "user32" Alias "FindWindowA" (ByVal lpClassName As String, ByVal lpWindowName As String) As Long
Private Declare Function EnableWindow Lib "user32" (ByVal hWnd As Long, ByVal fEnable As Long) As Long
Public Type FolderInfor
    hOwner As Long
    pidlRoot As Long
    pszDisplayName As String
    lpszTitle As String
    ulFlags As Long
    lpfn As Long
    lParam As Long
    iImage As Long
End Type

Function BrowseDir() As String
    Dim iFolder As FolderInfor
    Dim pidl As Long, Flag As Long, iPath As String, Pos As Integer, myPath As String
   
    EnableWindow FindWindow("XLMAIN", Application.Caption), False
    pidl& = SHBrowseForFolder(iFolder)
   
    EnableWindow FindWindow("XLMAIN", Application.Caption), True
    iPath = Space$(512)
   
    Flag = SHGetPathFromIDList(ByVal pidl, ByVal iPath)
    If Flag Then
        Pos = InStr(iPath, Chr$(0))
        BrowseDir = Left(iPath, Pos - 1)
    Else
        BrowseDir = ThisWorkbook.Path
    End If
End Function

这样的话，原来代码中改成

myDir = BrowseDir & "\"

就可以使用上面的代码得到文件夹参数啦。