使用VBA将多个图像导入excel

我必须编写一个脚本，解析ppt中的图像并将其转储到excel中。为此，我首先将幻灯片中的所有图像导出到一个文件夹中，然后调用excel应用程序将它们导入工作表。以下代码（我在网上找到）及其修改如下：

Sub ExtractImagesFromPres()

Dim oSldSource As Slide
Dim oShpSource As Shape
Dim Ctr As Integer
Dim ObjExcel As Object
Dim wb As Object
Dim ws As Object
Set ObjExcel = CreateObject("Excel.Application")
Dim sPath As String

sPath = "C:\Users\Aravind_Sampathkumar\Documents\Expor"
Ctr = 0

Set wb = ObjExcel.Workbooks.Open("C:\Users\Aravind_Sampathkumar\Documents\Book1.xlsx")
Set ws = wb.Sheets(1)

'Open oPres.Path & PathSep & "Book1.CSV" For Output As iFile

For Each oSldSource In ActivePresentation.Slides
    For Each oShpSource In oSldSource.Shapes

        If oShpSource.Type = msoPicture Then

        ' Hidden Export method

        Call oShpSource.Export(sPath & "Img" & Format(Ctr, "0000") & ".JPG", ppShapeFormatJPG)


        Ctr = Ctr + 1
        End If

        Next oShpSource
Next oSldSource


Folderpath = "C:\Users\Aravind_Sampathkumar\Documents\Expor"
Set fso = CreateObject("Scripting.FileSystemObject")
NoOfFiles = fso.GetFolder(Folderpath).Files.Count
Set listfiles = fso.GetFolder(Folderpath).Files
counter = 1
For Each fls In listfiles
    strCompFilePath = Folderpath & "\" & Trim(fls.Name)
        If strCompFilePath <> "" Then
            If (InStr(1, strCompFilePath, "jpg", vbTextCompare) > 1 _
            Or InStr(1, strCompFilePath, "jpeg", vbTextCompare) > 1 _
            Or InStr(1, strCompFilePath, "png", vbTextCompare) > 1) Then

            counter = counter + 1
           ' ws.Range("C" & counter).Value = fls.Name
            ws.Range("D" & counter).ColumnWidth = 25
            ws.Range("D" & counter).RowHeight = 100
            ws.Range("D" & counter).Activate
            'Call insert(strCompFilePath, counter)
            ws.Shapes.AddPicture strCompFilePath, True, True, 100,100,70,70
            End If
        End If
Next
'ws.Shapes.AddPicture ("C:\Users\Aravind_Sampathkumar\Documents")
     'With .ShapeRange
      '  .LockAspectRatio = msoTrue
       ' .Width = 100
        '.Height = 100
    'End With
   ' .Left = ws.Cells(i, 20).Left
    '.Top = ws.Cells(i, 20).Top
    '.Placement = 1
    '.PrintObject = True
'End With
End Sub

Sub-extractImagesFrompress（）
将oSldSource设置为幻灯片
暗淡的oShpSource为形状
作为整数的Dim Ctr
作为对象的Dim ObjExcel
作为对象的Dim wb
将ws设置为对象
设置ObjExcel=CreateObject（“Excel.Application”）
像细绳一样暗淡
sPath=“C:\Users\Aravind\u Sampathkumar\Documents\Expor”
Ctr=0
设置wb=ObjExcel.Workbooks.Open（“C:\Users\Aravind\u Sampathkumar\Documents\Book1.xlsx”）
设置ws=wb.Sheets（1）
“打开操作路径和路径sep&“Book1.CSV”作为iFile输出
对于ActivePresentation.Slides中的每个oSldSource
对于oSldSource.Shapes中的每个oShpSource
如果oShpSource.Type=msoPicture，则
"隐藏导出法",
调用oShpSource.Export（sPath和“Img”以及格式（Ctr，“0000”）和.JPG，ppShapeFormatJPG）
Ctr=Ctr+1
如果结束
下一个oShpSource
下一个oSldSource
Folderpath=“C:\Users\Aravind\u Sampathkumar\Documents\Expor”
设置fso=CreateObject（“Scripting.FileSystemObject”）
NoOfFiles=fso.GetFolder（Folderpath）.Files.Count
设置listfiles=fso.GetFolder（Folderpath）.Files
计数器=1
对于列表文件中的每个fls
strCompFilePath=Folderpath&“\”和Trim（fls.Name）
如果strCompFilePath为“”，则
如果（InStr（1，strCompFilePath，“jpg”，vbTextCompare）>1_
或InStr（1，strCompFilePath，“jpeg”，vbTextCompare）>1_
或InStr（1，strCompFilePath，“png”，vbTextCompare）>1）然后
计数器=计数器+1
'ws.Range（“C”和计数器）.Value=fls.Name
ws.Range（“D”和计数器）。ColumnWidth=25
ws.Range（“D”和计数器）。行高=100
ws.Range（“D”和计数器）。激活
'调用插入（strCompFilePath，计数器）
ws.Shapes.AddPicture strCompFilePath，True，True，100100,70,70
如果结束
如果结束
下一个
'ws.Shapes.AddPicture（“C:\Users\Aravind\u Sampathkumar\Documents”）
“用.shaperage
'.LockAspectRatio=msoTrue
'宽度=100
’高度=100
"以
'.Left=ws.Cells（i，20）.Left
'.Top=ws.Cells（i，20）.Top
'.Placement=1
'.PrintObject=True
"以
端接头

---

当我运行它时，图像被转储到excel中，但所有图像在同一单元格中相互重叠。是否有任何方法可以修改它，使图像进入连续行？每行1个图像？

请查看AddPicture方法的文档：

expression.AddPicture（文件名、链接文件、SaveWithDocument、左侧、顶部、宽度、高度）

图片的位置由左参数和上参数控制，而不是在活动单元格中添加图片。您可以使用目标单元格的左属性和上属性作为AddPicture方法的参数：

---

ws.Shapes.AddPicture strCompFilePath，True，True，ws.Range（“D”和counter）。左侧，ws.Range（“D”和counter）。顶部，70,70

这会将它们分开一行，但需要适当调整大小。注意，我更改了测试路径的路径

Option Explicit

Sub ExtractImagesFromPres()

    Dim oSldSource As Slide
    Dim oShpSource As Shape
    Dim Ctr As Integer
    Dim ObjExcel As Object
    Dim wb As Object
    Dim ws As Object
    Set ObjExcel = CreateObject("Excel.Application")
    Dim sPath As String

    sPath = "C:\Users\User\Desktop\TestFolder" '"C:\Users\Aravind_Sampathkumar\Documents\Expor"
    Ctr = 0

    Set wb = ObjExcel.Workbooks.Open("C:\Users\User\Desktop\TestFolder\Test.xlsx") '("C:\Users\Aravind_Sampathkumar\Documents\Book1.xlsx")
    ObjExcel.Visible = True

    Set ws = wb.Sheets(1)

    For Each oSldSource In ActivePresentation.Slides
        For Each oShpSource In oSldSource.Shapes
            If oShpSource.Type = msoPicture Then
                Call oShpSource.Export(sPath & "\" & "Img" & Format(Ctr, "0000") & ".JPG", ppShapeFormatJPG)
                Ctr = Ctr + 1
            End If
        Next oShpSource
    Next oSldSource

    Dim Folderpath As String
    Dim fso As Object
    Dim NoOfFiles As Long
    Dim listfiles As Object
    Dim counter As Long
    Dim fls As Variant
    Dim strCompFilePath As String

    Folderpath = "C:\Users\User\Desktop\TestFolder" '"C:\Users\Aravind_Sampathkumar\Documents\Expor"
    Set fso = CreateObject("Scripting.FileSystemObject")
    NoOfFiles = fso.GetFolder(Folderpath).Files.Count
    Set listfiles = fso.GetFolder(Folderpath).Files

    counter = 1

    For Each fls In listfiles
        strCompFilePath = Folderpath & "\" & Trim(fls.Name)
        If strCompFilePath <> vbNullString Then
            If (InStr(1, strCompFilePath, "jpg", vbTextCompare) > 1 _
                Or InStr(1, strCompFilePath, "jpeg", vbTextCompare) > 1 _
                Or InStr(1, strCompFilePath, "png", vbTextCompare) > 1) Then

                counter = counter + 1
                ' ws.Range("C" & counter).Value = fls.Name
                ws.Range("D" & counter).ColumnWidth = 25
                ws.Range("D" & counter).RowHeight = 100
                ws.Range("D" & counter).Activate
                'Call insert(strCompFilePath, counter)
                With ws.Pictures.Insert(strCompFilePath)
                    .Left = ws.Cells(counter, "D").Left
                    .Top = ws.Cells(counter, "D").Top
                End With
            End If
        End If
    Next
End Sub

选项显式
子提取器ImagesFrompress（）
将oSldSource设置为幻灯片
暗淡的oShpSource为形状
作为整数的Dim Ctr
作为对象的Dim ObjExcel
作为对象的Dim wb
将ws设置为对象
设置ObjExcel=CreateObject（“Excel.Application”）
像细绳一样暗淡
sPath=“C:\Users\User\Desktop\TestFolder”'“C:\Users\Aravind\u Sampathkumar\Documents\Expor”
Ctr=0
设置wb=ObjExcel.Workbooks.Open（“C:\Users\User\Desktop\TestFolder\Test.xlsx”）（“C:\Users\Aravind\u Sampathkumar\Documents\Book1.xlsx”）
ObjExcel.Visible=True
设置ws=wb.Sheets（1）
对于ActivePresentation.Slides中的每个oSldSource
对于oSldSource.Shapes中的每个oShpSource
如果oShpSource.Type=msoPicture，则
调用oShpSource.Export（sPath&“\”&“Img”和Format（Ctr，“0000”）&.JPG，ppShapeFormatJPG）
Ctr=Ctr+1
如果结束
下一个oShpSource
下一个oSldSource
将Folderpath设置为字符串
作为对象的Dim fso
朦胧的午后
将列表文件设置为对象
昏暗的柜台一样长
Dim fls作为变体
将strCompFilePath设置为字符串
Folderpath=“C:\Users\User\Desktop\TestFolder””“C:\Users\Aravind\u Sampathkumar\Documents\Expor”
设置fso=CreateObject（“Scripting.FileSystemObject”）
NoOfFiles=fso.GetFolder（Folderpath）.Files.Count
设置listfiles=fso.GetFolder（Folderpath）.Files
计数器=1
对于列表文件中的每个fls
strCompFilePath=Folderpath&“\”和Trim（fls.Name）
如果strCompFilePath vbNullString，则
如果（InStr（1，strCompFilePath，“jpg”，vbTextCompare）>1_
或InStr（1，strCompFilePath，“jpeg”，vbTextCompare）>1_
或InStr（1，strCompFilePath，“png”，vbTextCompare）>1）然后
计数器=计数器+1
'ws.Range（“C”和计数器）.Value=fls.Name
ws.Range（“D”和计数器）。ColumnWidth=25
ws.Range（“D”和计数器）。行高=100
ws.Range（“D”和计数器）。激活
'调用插入（strCompFilePath，计数器）
使用ws.Pictures.Insert（strCompFilePath）
.Left=ws.Cells（计数器，“D”）。左
.Top=ws.Cells（计数器，“D”）.Top
以
如果结束
如果结束
下一个
端接头

这是一个使用复制/粘贴而不是导出/导入的版本-它确实包含了一行，如果您只想抄录行高，可以更改行高..：P

Sub ExtractImagesFromPres()
    Dim oSldSource As Slide
    Dim oShpSource As Shape
    Dim ObjExcel As Object
    Dim wb As Object
    Dim ws As Object
    Set ObjExcel = CreateObject("Excel.Application")
    Dim lOffset AS Long

    Set wb = ObjExcel.Workbooks.Open("C:\Users\Aravind_Sampathkumar\Documents\Book1.xlsx")
    Set ws = wb.Sheets(1)

    'Open oPres.Path & PathSep & "Book1.CSV" For Output As iFile
    lOffset = 5
    For Each oSldSource In ActivePresentation.Slides
        For Each oShpSource In oSldSource.Shapes
            If oShpSource.Type = msoPicture Then
                oShpSource.Copy
                ws.Paste
                With ws.Shapes(ws.Shapes.Count)
                    .Top = lOffset 
                    .Left = 5
                    .Placement = 3 'xlFreeFloating
                    'This line sets the row height!
                    .TopLeftCell.EntireRow.RowHeight = 10 + .Height
                    lOffset = lOffset + .Height + 10
                End With
            End If
        Next oShpSource
    Next oSldSource

    'Optional Tidy-Up code
    'Set ws = Nothing
    'wb.Save
    'Set wb = Nothing
    'ObjExcel.Quit
    'Set ObjExcel = Nothing
End Sub

---

我百分之百确定你可以将PPT中的图像直接导出到XLS，但我不确定怎么做。但是，由于您可以将这些图像从PPT导出到文件夹中，并且您只需要从那里导入图像的帮助，因此我认为

Sub InsertPics()
Dim fPath As String, fName As String
Dim r As Range, rng As Range

Application.ScreenUpdating = False
fPath = "C:\your_path_here\"
Set rng = Range("A1:A" & Cells(Rows.Count, 1).End(xlUp).Row)
i = 1

For Each r In rng
    fName = Dir(fPath)
    Do While fName <> ""
        If fName = r.Value Then
            With ActiveSheet.Pictures.Insert(fPath & fName)
                .ShapeRange.LockAspectRatio = msoTrue
                Set px = .ShapeRange
                If .ShapeRange.Width > Rows(i).Columns(2).Width Then .ShapeRange.Width = Columns(2).Width
                    With Cells(i, 2)
                        px.Top = .Top
                        px.Left = .Left
                        .RowHeight = px.Height
                    End With
            End With
        End If
        fName = Dir
    Loop
    i = i + 1
Next r
Application.ScreenUpdating = True
End Sub

' Note: you need the file extension, such as ',jpg', or whatever you are using, so you can match on that.


Sub Insert()

    Dim strFolder As String
    Dim strFileName As String
    Dim objPic As Picture
    Dim rngCell As Range

    strFolder = "C:\Users\Public\Pictures\Sample Pictures\" 'change the path accordingly
    If Right(strFolder, 1) <> "\" Then
        strFolder = strFolder & "\"
    End If

    Set rngCell = Range("E1") 'starting cell

    strFileName = Dir(strFolder & "*.jpg", vbNormal) 'filter for .png files

    Do While Len(strFileName) > 0
        Set objPic = ActiveSheet.Pictures.Insert(strFolder & strFileName)
        With objPic
            .Left = rngCell.Left
            .Top = rngCell.Top
            .Height = rngCell.RowHeight
            .Placement = xlMoveAndSize
        End With
        Set rngCell = rngCell.Offset(1, 0)
        strFileName = Dir
    Loop

End Sub