有多个word文档需要插入图片

ytmpgght

lisongmei 发表于 2024-4-3 17:41
现学现卖写了个，，，格式默认是嵌入型，不知道怎么改，哈哈。将就参考一下

Sub test()

谢谢您给予的帮助，谢谢！

ytmpgght

wanghan519 发表于 2024-4-3 17:48
InlineShapes没有环绕这个属性，不如直接用shapes添加图片，就可以指定衬与文字下方

感谢您给予提示，让我们在学习的道路上少走弯路。

闻启学

wanghan519 发表于 2024-4-3 17:48
InlineShapes没有环绕这个属性，不如直接用shapes添加图片，就可以指定衬与文字下方

这个要转换的

gwjkkkkk

Option Explicit
Sub test()
    Dim Items1 As FileDialogSelectedItems, Items2 As FileDialogSelectedItems
    Dim strPath$, i&, Pic As Shape
   
    With Application.FileDialog(1)
        With .Filters
            .Clear
            .Add "PIC Files", "*.png,*.jpg,*.gif"
        End With
        .Title = "请选择一个图片文件"
        .AllowMultiSelect = False
        .InitialFileName = strPath
        If .Show Then Set Items1 = .SelectedItems Else Exit Sub
    End With
   
    With Application.FileDialog(1)
        With .Filters
            .Clear
            .Add "PIC Files", "*.doc*"
        End With
        .Title = "请选择需导入的文件"
        .AllowMultiSelect = True
        .InitialFileName = strPath
        If .Show Then Set Items2 = .SelectedItems Else Exit Sub
    End With
   
    For i = 1 To Items2.Count
        If Items2(i) <> ThisDocument.FullName Then
            With Documents.Open(Items2(i))
                For Each Pic In .Shapes
                    If Pic.Type = 13 Then Pic.Delete
                Next
                With .Content.Find
                    .Text = "请贵司"
                    .Forward = True
                    .Execute
                    If .Found = True Then
                        .Parent.Select
                        With Selection
                            .EndKey unit:=wdLine
                            .MoveDown unit:=wdLine
                            With .InlineShapes.AddPicture(Items1(1), , True)
                                .Select
                                .LockAspectRatio = True
                                .Width = 4.5 * 96 / 2.54
                                Selection.ShapeRange.WrapFormat.Type = 5
                            End With
                        End With
                    End If
                End With
                .Close True
            End With
        End If
    Next i
End Sub

gwjkkkkk

请参考附件。。。

ytmpgght

gwjkkkkk 发表于 2024-4-3 21:35
请参考附件。。。

感谢老师提供帮助，您的方案已经完美解决我目前的需求。非常感谢