如何用VBA在word指定位置插入印章图片

8p16a5f

请教各位高手，我有几十份名册word版的，每一份名册有几十页，且每一页根据该类学生人数的多少，要盖章的位置是不一样的，实现的效果如下：

因此我的思路是：

1、找到“盖章”两个字
2、在该处插入印章图片
3、将图片转换为形状

前两步正常实现了，但第三步出问题了，一旦将图片转换为形状，图片就跑到上面去了，用top和left属性也找不到精确控制的方法。
这个问题困扰了好几天，甚至找chatGPT帮忙都搞不定，所以请各位大神伸出援手，感谢。

这是我已经部分完成的代码：

1. Sub 插入图片()
   
2.     '找到“盖章”并在该位置插入印章图片
   
3.     For i = 1 To 2:
   
4.         With Selection.Find

复制代码

守候_CJ

Word VBA综合练习：数组+函数+查找+图片插入+转形状+简单定位
一、代码

1. Sub 查找文字插入印章(doc As Document, findText As String, Optional MatchWildCards = True)
   
2.     Dim arr() As Range '存入查找到的“盖章”的位置
   
3.     Dim i As Long: i = 0
   
4.     Dim j As Long
   
5.     Dim fw As Range
   
6.     'Dim 继续查 As Boolean
   
7.    
   
8.     Set fw = ThisDocument.Range
   
9.    
   
10.     With fw.Find
    
11.         .ClearFormatting
    
12.         .Forward = True
    
13.         .MatchWildCards = MatchWildCards
    
14.         .Text = findText
    
15.         .Wrap = wdFindStop
    
16.         Do While .Execute
    
17.             i = i + 1
    
18.             ReDim Preserve arr(1 To i)
    
19.             j = Int((fw.Start + fw.End) / 2)
    
20.             Set arr(i) = doc.Range(j, j)
    
21.         Loop
    
22.     End With
    
23.    
    
24.     Dim isp As InlineShape
    
25.     Dim sp As Shape
    
26.     For i = UBound(arr) To LBound(arr) Step -1
    
27.         arr(i).Select
    
28.         Set isp = doc.InlineShapes.AddPicture(doc.Path & "\印章.png", False, True, arr(i))
    
29.         isp.ConvertToShape
    
30.         Set sp = doc.Shapes(doc.Shapes.Count)
    
31.         With sp
    
32.             .WrapFormat.Type = wdWrapFront
    
33.             .Top = .Top - .Height / 2
    
34.             .Left = .Left - .Width / 2
    
35.         End With
    
36.     Next i
    
37.    
    
38.     Erase arr
    
39.     Set doc = Nothing
    
40.     Set fw = Nothing
    
41.     Set isp = Nothing
    
42.     Set sp = Nothing
    
43. End Sub
    
44. 
    
45. Sub 主程序()
    
46.     Dim t0 As Single: t0 = Timer
    
47.     Application.ScreenUpdating = False
    
48.    
    
49.     查找文字插入印章 ActiveDocument, "盖章"
    
50.    
    
51.     Application.ScreenUpdating = True
    
52.     MsgBox "完成    " & "用时" & Timer - t0 & "秒！"
    
53. End Sub

复制代码

二、图示

三、更多Office VBA问题

欢迎查看我的主页多个专栏：守候 - 知乎 (zhihu.com)

https://www.zhihu.com/people/shou-hou-ysys/columns

413191246se

略。。。。

/ty自由/ty

大神厉害。

413191246se

守候老师 的代码测试通过！老师 好厉害！（楼主 请记得将代码拷贝到 VBE 中“Project（学生名册）”下面的“ThisDocument”（双击）里面才行。）

8p16a5f

感谢守候老师解决了困扰我多日的难题。

8p16a5f

413191246se 发表于 2023-3-3 00:14
守候老师 的代码测试通过！老师 好厉害！（楼主 请记得将代码拷贝到 VBE 中“Project（学生名册）”下面的 ...

感谢，我试试

守候_CJ

守候_CJ 发表于 2023-3-2 00:12
Word VBA综合练习：数组+函数+查找+图片插入+转形状+简单定位
一、代码
二、图示

把
Set fw = ThisDocument.Range
改成
Set fw = doc.Range
才能灵活调用函数

守候_CJ

8p16a5f 发表于 2023-3-3 10:05
感谢守候老师解决了困扰我多日的难题。

我的评论注意下，修改了函数才能灵活调用

wdpfox

守候_CJ 发表于 2023-3-2 00:12
Word VBA综合练习：数组+函数+查找+图片插入+转形状+简单定位
一、代码
二、图示

守候老师，代码有颜色是什么扩展实现的？