如何将pdf文件中的每个图像文件名替换为其图像？打印所有 WhatsApp 聊天内容，包括媒体

Question

我需要使用 VBA 将图像添加到从 WhatsApp 聊天导出的文本中的帮助；将媒体包含在适当的位置。在帮助下，我取得了进展，但遇到了 Word 文档（粘贴导出聊天记录）中出现的额外文本未被 VBA 识别的情况。

字行示例为“附件？00000004-PHOTO-2024-10-16-15-39-21.jpg” 但在文件夹中，文件名是“00000004-PHOTO-2024-10-16-15-39-21.jpg 如何将Word文本与文件夹完整路径名匹配？

代码如下

Option Explicit
Sub InsertImagesAllDocuments(TextPlaceHolder As String)
'Sub InsertImagesAllDocuments()
'https://stackoverflow.com/questions/20552141/microsoft-word-macro-vba-replace-text-with-image-in-document-header
Dim n, C As Integer
n = Application.Documents.count
C = 1

Dim r As Range

Windows(C).Activate

Do
Dim imageFullPath As String
Dim FIndText As String
imageFullPath = TextPlaceHolder '"C:\Users\sunny\OneDrive\ruby\dispute\00000004-PHOTO-2024-10-16-15-39-21.jpg"
'FIndText = "TextPlaceholder"
FIndText = imageFullPath
    With Selection
    .HomeKey Unit:=wdStory

    With .Find
        .ClearFormatting
        .Text = FIndText
        ' Loop until Word can no longer
        ' find the search string, inserting the specified image at each location
        Do While .Execute
            With Selection
                .MoveRight
                With .InlineShapes
                    .AddPicture FileName:=imageFullPath, LinkToFile:=False, SaveWithDocument:=True
                End With
            End With
        Loop

    End With
End With
    C = C + 1
    On Error Resume Next
    Windows(C).Activate

Loop Until C > n



 End Sub

Sub FindBracketedText()
'http://www.vbaexpress.com/forum/showthread.php?881-Solved-Finding-Text-Within-Square-Brackets
Dim msg As String

With Selection

.HomeKey wdStory

With .Find

.ClearFormatting
.Format = False

.Text = "\<*.jpg\>"
.Replacement.Text = ""
.MatchWildcards = True

.Forward = True
.Wrap = wdFindStop

.MatchCase = False
.MatchWholeWord = False
.MatchAllWordForms = False
.MatchSoundsLike = False

.Execute

End With

Do

msg = msg & Mid$(Selection, 2, Len(Selection) - 2) & vbNewLine
.Find.Execute
    Dim TrimMsg As String
    TrimMsg = cleanMyString(msg)
    Debug.Print TrimMsg
    InsertImagesAllDocuments TrimMsg
Loop While .Find.Found


End With

MsgBox msg

End Sub

Function cleanMyString(sInput)
'https://stackoverflow.com/questions/24048400/function-to-trim-leading-and-trailing-whitespace-in-vba
    ' Remove leading and trailing spaces
    sInput = Trim(sInput)
    'Remove other characters that you dont want
    sInput = Replace(sInput, Chr(10), "")
    sInput = Replace(sInput, Chr(13), "")
    sInput = Replace(sInput, Chr(9), "")
    cleanMyString = sInput
End Function

图片：

导出文本：

代码已粘贴到帖子中

Answer 1

这似乎对我有用：

Option Explicit

Sub InsertImagesAllDocuments()
    
    Dim imgPath As String, colImages As Collection, f, doc As Document
    
    'where your files are (include the \ at the end)
    imgPath = "C:\Users\sunny\OneDrive\ruby\dispute\"
    
    'collect all available jpg filenames from `imgPath`
    Set colImages = New Collection
    f = Dir(imgPath & "*.jpg", vbNormal)
    Do While Len(f) > 0
        colImages.Add f 'add the file name
        f = Dir()
    Loop
    Debug.Print "Found " & colImages.Count & " jpg files"

    
    For Each doc In Application.Documents 'loop over open documents
        For Each f In colImages           'loop over found image filenames
            FindFileReference doc, CStr(f), imgPath 'replace if found
        Next f
    Next doc

End Sub

'Scan document for filename `f` and insert picture after any found
'  instances.  Note image names can't be substrings of other image names...
'  Eg:  "file 001.jpg" and "myfile001.jpg" since the first will also match the second
Sub FindFileReference(doc As Document, f As String, fPath As String)
    Dim rng As Range
    Set rng = doc.Range
    With rng.Find
        .ClearFormatting
        .Text = "\<*" & f & "\>"
        .Replacement.Text = ""
        .MatchWildcards = True
        .Forward = True
        .Wrap = wdFindStop
        .MatchCase = False
        Do While .Execute
            'after Execute, `rng` is now the found text
            rng.Collapse direction:=wdCollapseEnd
            rng.InlineShapes.AddPicture FileName:=fPath & f, _
                      LinkToFile:=False, SaveWithDocument:=True
        Loop
    End With
End Sub