电子印章（宏）最终体验版 v5.24

413191246se · 发表于 2015-7-25 22:18

本帖最后由 413191246se 于 2015-8-15 13:55 编辑

* 特殊感谢：佛山小老鼠版主（详细参阅了他的《电子印章》制作帖）！
* 特殊感谢：本论坛高人 loquat 朋友（修改代码，使此宏通用于所有文档）！
* 通过录制宏，精简优化，初步达到实用阶段，结束了 Word 无此宏历史！
* 由于未实际打印，纯属纸上谈兵，仅作为探索体验而已，此宏可免费使用！
* 实际使用时，可在落款处点击一下鼠标，再运行此宏，移动方向键即可（印章落在当前页）。
* 按住 CTRL 键可以精细调节印章位置。按住 ALT 键沿对角线方向可以精细调节大小。
*《电子印章》（宏）演示图片：（宏仅生成红色印章，其它颜色须自己设置）

*《电子印章》宏--最终体验版 v5.24 代码：

Sub 电子印章()
If Documents.Count = 0 Then Documents.Add
Dim i$, j&, a$, f$, x!, s, t, r, arr(1 To 4) As String
ipt:
i = InputBox("印章正文（3-30字）和附言（2-6字）可以一起输入，但必须以中文逗号，分隔！", "电子印章", "辽宁省朝阳市通用模板公司，业务专用章")
If i = "" Then Exit Sub
a = InStrRev(i, "，")
If a Then f = Mid(i, a + 1): i = Left(i, a - 1) Else f = "财务专用章"
j = Len(i)
If j < 3 Or j > 30 Or Len(f) < 2 Or Len(f) > 6 Then GoTo ipt
If Len(f) = 5 Then
x = 258.4!
ElseIf Len(f) = 4 Then x = 264.5!
ElseIf Len(f) = 3 Then x = 263.5!: f = Left(f, 1) & " " & Mid(f, 2, 1) & " " & Right(f, 1)
ElseIf Len(f) = 2 Then x = 270.5!: f = Left(f, 1) & " " & Right(f, 1)
ElseIf Len(f) = 6 Then x = 251.5!
End If
s = Array(3.9!, 3!, 2.4!, 1.98!, 1.7!, 1.48!, 1.33!, 1.19!, 1.08!, 1!, 0.92!, 0.86!, 0.8!, 0.75!, 0.7!, 0.67!, 0.63!, 0.6!, 0.57!, 0.55!, 0.52!, 0.5!, 0.48!, 0.46!, 0.45!, 0.43!, 0.41!, 0.4!)
t = Array(5!, 5!, 4.9!, 3.9!, 3.5!, 3.1!, 2.8!, 2.5!, 2.3!, 2!, 1.8!, 1.7!, 1.6!, 1.5!, 1.4!, 1.3!, 1.32!, 1.27!, 1.2!, 1.1!, 1.1!, 1.05!, 1!, 0.97!, 0.93!, 0.88!, 0.85!, 0.8!)
r = Array(220!, 235!, 243!, 247!, 251!, 252!, 255!, 257!, 258.5!, 260.5!, 262!, 264!, 264.5!, 265.5!, 266.5!, 267!, 268!, 269!, 269!, 269!, 269!, 269!, 269.5!, 269.5!, 269.5!, 269.5!, 269.9!, 269.9!)
With ActiveDocument.Shapes
With .AddTextEffect(msoTextEffect3, i, "宋体", 12!, msoFalse, msoFalse, 219.75!, 103!) '艺术字
.TextEffect.Tracking = t(j - 3)
.ScaleHeight 12, msoFalse, msoScaleFromTopLeft
.ScaleWidth s(j - 3), msoFalse, msoScaleFromTopLeft
.Adjustments(1) = r(j - 3)
arr(1) = .Name
End With
With .AddShape(msoShapeOval, 201.6!, 85!, 180!, 180!) '圆周
.Fill.Transparency = 1!
.Line.Weight = 3.5
.Line.Style = msoLineThickThin
arr(2) = .Name
End With
With .AddShape(msoShape5pointStar, 264!, 147.8!, 54.9!, 47.6!) '五角星
.Line.Weight = 0.25
arr(3) = .Name
End With
With .AddTextEffect(msoTextEffect3, f, "宋体", 13!, msoTrue, msoFalse, x, 206!) '附言
.TextEffect.PresetShape = msoTextEffectShapePlainText
.Fill.Visible = msoTrue
.Line.Weight = 0.25
arr(4) = .Name
End With
With .Range(Array(arr(1), arr(2), arr(3), arr(4))).Group '组合
.Fill.ForeColor.RGB = RGB(255, 0, 0)
.Line.ForeColor.RGB = RGB(255, 0, 0)
.LockAspectRatio = msoTrue
.ScaleWidth 0.6, msoFalse, msoScaleFromTopLeft
.ScaleHeight 0.6, msoFalse, msoScaleFromTopLeft
.IncrementTop 92.6!
.IncrementLeft 119.4!
.ZOrder msoSendBehindText
.Select
End With
End With
End Sub

复制代码

oylw · 发表于 2015-7-26 10:31

好麻烦呀！！

loquat · 发表于 2015-7-26 17:37

希望楼主能将相关数据部分做一个开发的参数出来。例如我要做一个更大或者更小的印章，需要自己去摸索大小，这样不利于下次通用。

loquat · 发表于 2015-7-26 17:38

12#是不是应该是!

413191246se · 发表于 2015-7-26 18:22

谢谢 loquat 关注！——其实图形这一部分，我也不会多少，真的是摸索，像昨晚我调整了半天文本框位置，反复修改参数。目前是12字正好，如果不是12字的印章，恐怕未必成正圆，宽度值需要探索。
——我看佛山小老鼠版主的帖子中，无人用宏，没成想竟然成功！用宏一步到位制作印章，很方便。

413191246se · 发表于 2015-7-26 18:24

回2楼：麻烦过后，是方便，先吃苦，后得甜，苦尽甘来，值得。

413191246se · 发表于 2015-7-26 18:26

***请各位朋友，多多关注第2次更新的代码，第1次全部是录制宏（建议不必再下载），第2次已经精简了，效果相同。

413191246se · 发表于 2015-7-27 14:36

请各位朋友参阅《电子印章v3.2宏》，谢谢！

413191246se · 发表于 2015-7-28 20:10

更新，更新，更新！不顶不更新！

413191246se · 发表于 2015-7-28 21:20

本帖最后由 413191246se 于 2015-7-29 12:10 编辑

（略）。。。。。。

		自动登录	找回密码
密码			免费注册

[分享] 电子印章（宏）最终体验版 v5.24

评分