画像をファイルオブジェクトとして一括挿入

Question

私は、多くの証拠がテキストに要約され、必ずしも見る必要はないがオプションとして利用可能である必要がある何百もの付随するスクリーンショットによってサポートされているレポートを書いています。

したがって、これを実現するには、Wordがデフォルトで行うのと同じ方法で、画像ファイルを画像ではなくオブジェクトとして一括挿入/埋め込みします。 HTML、PDFなどのファイル用。このように、ユーザーがファイルを表示したい場合は、ファイルをダブルクリックするだけで、デフォルトのアプリで開くことができます。

基本的に、私は最終結果を次のようにしたいと思います：

ただし、これを自動的に行う方法がわかりません。

• Insertタブ→Textグループ→Objectボタン→Create from Fileタブでは、複数のファイルを選択できません。
• コピーアンドペーストは通常​​、それらを画像として挿入します。
• 特別にコピーアンドペースト（CTRL + ALT + V）→Paste→2番目/下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

これの良い副作用は、ファイルがアルファベット順に並べられているのに対し、通常の方法を使用して一括インポートした場合はそうではないことです。