专家坐堂-套印问题Foxtable(狐表) - 新一代数据库软件，完美融合Access、Foxpro、Excel、vb.net之优势，人人都能掌握的快速软件开发工具!

以文本方式查看主题

-  Foxtable(狐表)  (http://www.foxtable.com/bbs/index.asp)
--  专家坐堂  (http://www.foxtable.com/bbs/list.asp?boardid=2)
----  套印问题  (http://www.foxtable.com/bbs/dispbbs.asp?boardid=2&id=177518)

--  作者：jhxb8821
--  发布时间：2022/5/25 16:18:00
--  套印问题

老师，麻烦看看下面代码哪里出现问题了？
Dim f1 As String = ProjectPath & "Attachments\\登记表1.doc"\'指定模板文件
Dim f2 As String = ProjectPath & "Reports\\登记表11.doc"\'指定目标文件
Dim App As New MSWord.Application
Dim doc As Object = app.Documents.Open(f1)
Dim item = "【盖章】"
Dim sel = app.Selection
sel .Find.ClearFormatting
sel .Find.Text = item
sel.Find.Execute
Dim obj = sel.Range
Dim s = doc.Shapes.AddPicture("Attachments\\电子印章副本.png", False, True, 300, 0, 100, 100, obj)
s.WrapFormat.Type = MSWord.WdWrapType.wdWrapFront
app.visible = False
doc.SaveAs(Filename:=f2)
app.quit

--  作者：jhxb8821
--  发布时间：2022/5/25 16:36:00
--  套印问题2

下列代码需要解决2个问题，一是印章的位置，希望印章位置不要固定，自动根据内容进行调整，找到“【盖章】”处替换；二是印章叠放次序问题，印章置于底层，自动衬于文字下方。

Dim fl As String = ProjectPath & "test.docx"

Dim fl1 As String = ProjectPath & "test1.docx"

FileSys.CopyFile(fl,fl1,True)

Dim img As String = ProjectPath & "印章1.png"

Dim app As New MSWord.Application

try

    Dim doc = app.Documents.Open(fl)

    app.Selection.Find.Text = "【盖章】"

    app.Selection.Find.Execute

    Dim pic = app.Selection.InlineShapes.AddPicture(filename:=img, linktofile:=False, savewithdocument:=True).ConvertToShape \'插入图形

    With pic

        .WrapFormat.Type = MSWord.WdWrapType.wdWrapFront

        .RelativeHorizontalPosition = MSWord.WdRelativeHorizontalPosition.wdRelativeHorizontalPositionRightMarginArea \'相对于右边距

        .Left = -.Width \'取图片宽度的负数

        .RelativeVerticalPosition = MSWord.WdRelativeVerticalPosition.wdRelativeVerticalPositionBottomMarginArea \'相对于下边距

        .Top = -.Height \'取图片高度的负数

        .LockAspectRatio = True

       .Height = 113.5 \'印章大小正确

    End With

    Doc.SaveAs(Filename:= fl1)

catch ex As exception

    msgbox(ex.message)

    app.Quit

finally

End try

Dim Proc As New Process

Proc.File = fl1
Proc.Start()

--  作者：有点蓝
--  发布时间：2022/5/25 16:57:00
--
https://docs.microsoft.com/zh-cn/office/vba/api/word.wdwraptype

参考：http://www.foxtable.com/bbs/dispbbs.asp?boardid=2&Id=126389

--  作者：jhxb8821
--  发布时间：2022/5/25 17:44:00
--  代码
老师，wdWrapBehind=5还是wdWrapMergeBehind=3，这个代码写在哪里

--  作者：有点蓝
--  发布时间：2022/5/26 8:34:00
--
.WrapFormat.Type = MSWord.WdWrapType.wdWrapBehind

--  作者：jhxb8821
--  发布时间：2022/5/26 9:49:00
--  红色代码出错

Dim app As New MSWord.Application
Try
Dim fileName = ProjectPath & "test.docx"
Dim doc As Object = app.Documents.Open(fileName)
Dim item = "【盖章】" \'被替换的字符
Dim sel = app.Selection
sel .Find.ClearFormatting
With sel .Find
.Text = item
.Replacement.Text = ""
.Forward = True
.Wrap = MSWord.WdFindWrap.wdFindContinue
.Format = False
.MatchCase = False
.MatchWholeWord = False
.MatchByte = True
.MatchWildcards = False
.MatchSoundsLike = False
.MatchAllWordForms = False
.WrapFormat.Type = MSWord.WdWrapType.wdWrapBehind
End With
sel.Find.Execute
Dim img = ProjectPath & "印章1.png"
Dim pic = sel.InlineShapes.AddPicture(img, False, True)
pic.Height = 100 \'图片高
pic.Width = 100 \'图片宽
Doc.save
Catch ex As exception
msgbox(ex.message)
Finally
app.Quit
End Try

错误提示：未找到类型Find的公共成员WrapFormat

--  作者：有点蓝
--  发布时间：2022/5/26 10:15:00
--
Dim pic = sel.InlineShapes.AddPicture(img, False, True)
pic .WrapFormat.Type = MSWord.WdWrapType.wdWrapBehind

--  作者：jhxb8821
--  发布时间：2022/5/26 11:05:00
--  代码

下列代码结果项目卡死，请老师调试一下
Dim app As New MSWord.Application
Try
Dim fileName = ProjectPath & "test.docx"
Dim doc As Object = app.Documents.Open(fileName)
Dim item = "【盖章】" \'被替换的字符
Dim sel = app.Selection
sel .Find.ClearFormatting
With sel .Find
.Text = item
.Replacement.Text = ""
.Forward = True
.Wrap = MSWord.WdFindWrap.wdFindContinue
.Format = False
.MatchCase = False
.MatchWholeWord = False
.MatchByte = True
.MatchWildcards = False
.MatchSoundsLike = False
.MatchAllWordForms = False
End With
sel.Find.Execute
Dim img = ProjectPath & "印章1.png"
Dim pic = sel.InlineShapes.AddPicture(img, False, True)
pic.WrapFormat.Type = MSWord.WdWrapType.wdWrapBehind
pic.Height = 100 \'图片高
pic.Width = 100 \'图片宽
Doc.save
Catch ex As exception
msgbox(ex.message)
Finally
app.Quit
End Try

--  作者：有点蓝
--  发布时间：2022/5/26 11:53:00
--

Dim pic As MSWord.InlineShape = sel.InlineShapes.AddPicture(img)
pic.Height = 100 \'图片高
pic.Width = 100 \'图片宽
Dim p2 = pic.ConvertToShape
p2.WrapFormat.Type = MSWord.WdWrapType.wdWrapBehind
Doc.save

--  作者：jhxb8821
--  发布时间：2022/5/26 12:45:00
--  印章位置微调
蓝老师，现在实现了根据内容多少印章跟随和印章位于文字的下面功能，但发现一个问题，印章偏移较大，能否实现印章位置进行微调？红色代码怎么修改
Dim app As New MSWord.Application
Try
\' Dim fileName = "D:\\问题\\123.docx"
Dim fileName = ProjectPath & "test.docx"
Dim doc As Object = app.Documents.Open(fileName)
Dim item = "【盖章】" \'被替换的字符
Dim sel = app.Selection
sel .Find.ClearFormatting
With sel .Find
.Text = item
.Replacement.Text = ""
.Forward = True
.Wrap = MSWord.WdFindWrap.wdFindContinue
.Format = False
.MatchCase = False
.MatchWholeWord = False
.MatchByte = True
.MatchWildcards = False
.MatchSoundsLike = False
.MatchAllWordForms = False
End With
sel.Find.Execute
\' Dim img = "D:\\问题\\1.png" \'图片路径
Dim img = ProjectPath & "印章1.png"
Dim pic As MSWord.InlineShape = sel.InlineShapes.AddPicture(img)
pic.Height = 100 \'图片高
pic.Width = 100 \'图片宽
\'目前印章位置偏下偏右，希望进行向左和向上进行微调
With pic
.RelativeHorizontalPosition = MSWord.WdRelativeHorizontalPosition.wdRelativeHorizontalPositionRightMarginArea \'相对于右边距
.Left = -.Width + 170 \'取图片宽度的负数 ’调整印章位置
.RelativeVerticalPosition = MSWord.WdRelativeVerticalPosition.wdRelativeVerticalPositionBottomMarginArea \'相对于下边距
.Top = -.Height + 80\'取图片高度的负数 ’调整印章位置
End With

Dim p2 = pic.ConvertToShape
p2.WrapFormat.Type = MSWord.WdWrapType.wdWrapBehind
Doc.save
Catch ex As exception
msgbox(ex.message)
Finally
app.Quit
End Try

[此贴子已经被作者于2022/5/26 12:52:34编辑过]