WORD 里面可以根据关键字把图片插入到相应位置吗

FRANKEXCELVB

求助老师:  WORD文档里面,可以根据关键字把相对应的图片(图片文件名就是关键字)插入到对应的文字描述下面吗?  图片太多啦, 手工一个一个插入太费劲, VBA能实现吗>

batmanbbs

。。。。。。。。。

3190496160

理论上肯定是可行的，但是，最关键要明白两点：
1、要寻找的关键字是哪些？
2、插入图片的位置，跟关键字所在的位置有没有规律性，如果有，是什么？

quqiyuan

参与一下，仅供参考，。。
代码抓住两个个关键字：图片名称，"TARIFF CODE:"（经观察，这个在每个需要插入图片的上方都有）
经测试，运行正常

quqiyuan

代码如下。。。
Sub test()
    Dim doc As Document
    Dim firstRange As Range, secondRange As Range
    Dim isFound As Boolean
    Set doc = ThisDocument
    folderPath = doc.Path & "\"
    filepath = Dir(folderPath & "*.jpg")
    Do While filepath <> ""
        Set firstRange = doc.Content
        ' 查找第一个关键字
        With firstRange.Find
            .Text = Split(filepath, ".jpg")(0)
            .Forward = True
            .Wrap = wdFindStop
            isFound = .Execute
        End With
        If isFound Then
            Set secondRange = doc.Range(Start:=firstRange.End, End:=doc.Content.End)
            With secondRange.Find
                .Text = "TARIFF CODE:"
                .Forward = True
                .Wrap = wdFindStop
                If .Execute Then
                    Debug.Print "找到" & "TARIFF CODE: " & "位置：" & secondRange.Start
                    Set Rng = doc.Range(Start:=secondRange.End, End:=doc.Content.End)
                    With Rng.Find
                        .Text = vbCr
                        .Forward = True
                        .Wrap = wdFindStop
                        If .Execute Then
                            Rng.Collapse Direction:=wdCollapseEnd
                            With Rng.InlineShapes.AddPicture(folderPath & filepath, , 1)
                                .Width = 200
                                .Height = 200
                                .LockAspectRatio = True
                                .Select
                            End With
                            Selection.MoveRight Unit:=wdCharacter, Count:=1
                            Selection.TypeParagraph
                        End If
                    End With
                Else
                    MsgBox "TARIFF CODE:" & " 不存在！！！"
                End If
            End With
        Else
            MsgBox Split(filepath, ".jpg")(0) & " 文件不存在！！！"
        End If
        filepath = Dir
    Loop
    Beep
End Sub

quqiyuan

代码如下。。。
Sub test()
    Dim doc As Document
    Dim firstRange As Range, secondRange As Range
    Dim isFound As Boolean
    Set doc = ThisDocument
    folderPath = doc.Path & "\"
    filepath = Dir(folderPath & "*.jpg")
    Do While filepath <> ""
        Set firstRange = doc.Content
        ' 查找第一个关键字
        With firstRange.Find
            .Text = Split(filepath, ".jpg")(0)
            .Forward = True
            .Wrap = wdFindStop
            isFound = .Execute
        End With
        If isFound Then
            Set secondRange = doc.Range(Start:=firstRange.End, End:=doc.Content.End)
            With secondRange.Find
                .Text = "TARIFF CODE:"
                .Forward = True
                .Wrap = wdFindStop
                If .Execute Then
                    Debug.Print "找到" & "TARIFF CODE: " & "位置：" & secondRange.Start
                    Set Rng = doc.Range(Start:=secondRange.End, End:=doc.Content.End)
                    With Rng.Find
                        .Text = vbCr
                        .Forward = True
                        .Wrap = wdFindStop
                        If .Execute Then
                            Rng.Collapse Direction:=wdCollapseEnd
                            With Rng.InlineShapes.AddPicture(folderPath & filepath, , 1)
                                .Width = 200
                                .Height = 200
                                .LockAspectRatio = True
                                .Select
                            End With
                            Selection.MoveRight Unit:=wdCharacter, Count:=1
                            Selection.TypeParagraph
                        End If
                    End With
                Else
                    MsgBox "TARIFF CODE:" & " 不存在！！！"
                End If
            End With
        Else
            MsgBox Split(filepath, ".jpg")(0) & " 文件不存在！！！"
        End If
        filepath = Dir
    Loop
    Beep
End Sub

FRANKEXCELVB

quqiyuan 发表于 2025-4-6 11:57
代码如下。。。
Sub test()
    Dim doc As Document

太棒啦, 谢谢老师, 能否在图片底下把图片名也带上呢, 这样便于核对和矫正, 怕图片和描述不符

FRANKEXCELVB

3190496160 发表于 2025-4-6 10:45
理论上肯定是可行的，但是，最关键要明白两点：
1、要寻找的关键字是哪些？
2、插入图片的位置，跟关键字 ...

老师, 1. 关键字就是 客号 - 对应着每个图片的文件名; 2. 插入的图片就在每个产品的 TARIFF CODE 下方, 插入图片后, 并带上图片的文件名, 这样好核对插入的图片是否和货描相符.

quqiyuan

FRANKEXCELVB 发表于 2025-4-6 13:56
太棒啦, 谢谢老师, 能否在图片底下把图片名也带上呢, 这样便于核对和矫正, 怕图片和描述不符

我试试看，因为对word VBA不是很熟悉。也在摸索之中。

FRANKEXCELVB

quqiyuan 发表于 2025-4-6 15:06
我试试看，因为对word VBA不是很熟悉。也在摸索之中。

老师很厉害啦, 有的PO有近200个货号, 手工挨个加图片, 一个PO要搞一个晚上, 这样的话, 省事多了;
还有能否做成一个插件, 能加载到WORD里面, 要不不同的PO文件, 还得分别添加模块才能运行您的代码, 奢求了哈