Question

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

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

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

Answer 1

这会使它们分开但你需要适当地调整它们的大小。注意我更改了测试路径的路径。

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

Answer 2

查看AddPicture方法的文档：

https://msdn.microsoft.com/en-us/vba/excel-vba/articles/shapes-addpicture-method-excel

expression.AddPicture（Filename，LinkToFile，SaveWithDocument，Left，Top，Width，Height）

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

ws.Shapes.AddPicture strCompFilePath, True, True, ws.Range("D" & counter).Left, ws.Range("D" & counter).Top,70,70

Answer 3

这是一个使用复制/粘贴而不是导出/导入的版本 - 包含用于更改行高的行，如果您想要仅限于...：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

Answer 4

我100％确定您可以将图片从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

使用VBA将多个图像转换为Excel

4 个答案: