批量插入图像作为文件对象

Question

我正在写一份报告，其中大量证据都以文字形式总结，并附有数百张截图支持，这些截图不一定需要被看到，但需要作为一种选择提供。

因此，为了实现这一点，我想批量插入/嵌入图像文件作为对象，而不是图片，就像 Word 默认处理 HTML、PDF 等文件一样。这样，如果用户想要查看文件，他们只需双击它们即可在默认应用程序中打开它们。

基本上，我希望最终结果是这样的：

但是，我找不到自动执行此操作的方法：

• Insert选项卡 →Text组 →Object按钮 →Create from File选项卡不允许选择多个文件。
• 复制粘贴通常会将它们作为图片插入。
• 特殊复制粘贴（CTRL + ALT + V）→ Paste→ 第二个/底部Files→Display as icon将它们作为图片插入，尽管它不应该这样做。

我可以手动完成，但这非常耗时，因为每个操作都必须单独完成，Word 永远不会记住最后使用的路径，Word 永远不会记住最后选择的图标，等等。

Answer 1

我创建了以下 VBA 代码来实现我想要的功能：

Public lastPath As String

Sub InsertFolderContents()
    ' This mode is used to pick a folder and have all files inserted
    Dim counter_filesInserted As Integer
    counter_filesInserted = 1 ' Even though no files have been inserted yet, it's easier to not have to think in 0-based indexes

    Dim fileExplorer As FileDialog
    Dim folder_Path As String

    Set fileExplorer = Application.FileDialog(msoFileDialogFolderPicker)
    With fileExplorer
        .InitialFileName = lastPath

        If .Show = -1 Then ' ".Show" actually causes the dialogue to open
            folder_Path = .SelectedItems.Item(1) & Application.PathSeparator ' "Application.PathSeparator" is required to be appended otherwise the later concatenated path is invalid
            lastPath = folder_Path
        Else
            folder_Path = "NONE"
        End If
    End With

    Dim Files As String
    Files = Dir(folder_Path)

    ' For some reason, calling InsertFiles from within Do While completely breaks "Files = Dir" so need to build array of files THEN loop through them to call InsertFiles

    Dim counter_fileList As Integer

    Dim DirectoryListArray() As String
    ReDim DirectoryListArray(1000)

    Do While Files <> ""
        DirectoryListArray(counter_fileList) = Files
        Files = Dir
        counter_fileList = counter_fileList + 1
    Loop

    ReDim Preserve DirectoryListArray(counter_fileList - 1)

    For counter_fileList = 0 To UBound(DirectoryListArray)
        Dim file_Name_Original As String
        file_Name_Original = DirectoryListArray(counter_fileList)
        Dim file_Path As String
        file_Path = folder_Path & file_Name_Original

        InsertFiles file_Path, counter_filesInserted
    Next counter_fileList
End Sub


Sub InsertMultipleFiles()
    ' This mode is used to pick specific files to have inserted

    Dim counter_filesInserted As Integer
    counter_filesInserted = 1 ' Even though no files have been inserted yet, it's easier to not have to think in 0-based indexes

    Dim fileExplorer As FileDialog
    Dim folder_Path As String

    Set fileExplorer = Application.FileDialog(msoFileDialogFilePicker)
    With fileExplorer
        .InitialFileName = lastPath
        .AllowMultiSelect = True

        If .Show = -1 Then ' ".Show" actually causes the dialogue to open
            folder_Path = Left(.SelectedItems.Item(1), InStrRev(.SelectedItems.Item(1), "\"))
            lastPath = folder_Path
        Else
            folder_Path = "NONE"
        End If

        Dim file_Path As Variant
        For Each file_Path In .SelectedItems
            InsertFiles file_Path, counter_filesInserted
        Next
    End With
End Sub

Function InsertFiles(file_Path, counter_filesInserted)
    Dim file_Name_Original As String
    Dim file_Ext As String
    Dim file_Inserted As Boolean
    Dim regex As Object

    file_Name_Original = Dir(file_Path)

    file_Ext = Right(file_Path, Len(file_Path) - InStrRev(file_Path, "."))

    file_Inserted = False

    ' My report standalone files are named "<section number> <section title> - " so this regex strips those out for readability but doesn't affect files that aren't named that way
    Set regex = CreateObject("VBScript.RegExp")
    regex.Pattern = "\d{1,2}.\d{1,2}(.\d{1,2})?[\w\s]+ - "
    regex.IgnoreCase = True
    regex.Global = True
    file_Name_Shortened = regex.Replace(file_Name_Original, "")

    ' The IconIndex number is literally just what number icon is inside that file -1 (as it's a 0-based index). An easy way to determine this is to use Word's "Change icon" function.

    If file_Ext = "png" Or file_Ext = "jpg" Then
        Selection.InlineShapes.AddOLEObject _
        FileName:=file_Path, _
        LinkToFile:=False, _
        DisplayAsIcon:=True, _
        IconFileName:="C:\Program Files (x86)\Internet Explorer\iexplore.exe", _
        IconIndex:=13, _
        IconLabel:=file_Name_Shortened

        file_Inserted = True
    ElseIf file_Ext = "html" Then
        Selection.InlineShapes.AddOLEObject _
        FileName:=file_Path, _
        LinkToFile:=False, _
        DisplayAsIcon:=True, _
        IconFileName:="C:\Program Files (x86)\Internet Explorer\iexplore.exe", _
        IconIndex:=1, _
        IconLabel:=file_Name_Shortened

        file_Inserted = True
    ElseIf file_Ext = "pdf" Then
        Selection.InlineShapes.AddOLEObject _
        FileName:=file_Path, _
        LinkToFile:=False, _
        DisplayAsIcon:=True, _
        IconFileName:="C:\Windows\Installer\{AC76BA86-7AD7-1033-7B44-AC0F074E4100}\PDFFile_8.ico", _
        IconIndex:=1, _
        IconLabel:=file_Name_Shortened

        file_Inserted = True
    ElseIf file_Ext = "csv" Or file_Ext Like "xls*" Then
        Selection.InlineShapes.AddOLEObject _
        FileName:=file_Path, _
        LinkToFile:=False, _
        DisplayAsIcon:=True, _
        IconFileName:="C:\Windows\Installer\{90160000-000F-0000-0000-0000000FF1CE}\xlicons.exe", _
        IconIndex:=1, _
        IconLabel:=file_Name_Shortened

        file_Inserted = True
    ElseIf file_Ext Like "doc*" Then
        Selection.InlineShapes.AddOLEObject _
        FileName:=file_Path, _
        LinkToFile:=False, _
        DisplayAsIcon:=True, _
        IconFileName:="C:\Windows\Installer\{90160000-000F-0000-0000-0000000FF1CE}\wordicon.exe", _
        IconIndex:=13, _
        IconLabel:=file_Name_Shortened

        file_Inserted = True
    End If

    If file_Inserted = True Then
        ' Inserted file objects look untidy without a tab for space between them but you have to not do this every 4th otherwise it looks weird.
        If (counter_filesInserted Mod 4) <> 0 Or counter_filesInserted = 0 Then
                Selection.TypeText Text:=vbTab
        End If

        counter_filesInserted = counter_filesInserted + 1
    End If
End Function

这样做的一个很好的副作用是文件按字母顺序排列，而如果使用常规方法批量导入则不是按字母顺序排列的。