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

wkxxxr

做得这个地步已经很好了！赞一个。感觉一般在“业务专用章”底下的文字留空白，就是首尾文字之间留空，不知道能否做出来，就更完美。

413191246se

谢谢楼上朋友关注！一我没明白你的意思，二是本着简单、实用的原则，本宏决定定稿了，将收录在下一版本通用模板中，学有余力的朋友们可以自行探索。

wkxxxr

413191246se 发表于 2015-7-29 12:12
谢谢楼上朋友关注！一我没明白你的意思，二是本着简单、实用的原则，本宏决定定稿了，将收录在下一版本通用 ...

v5已经完美，保留开口。字号好像调整不了，做出来的字有点小

tangqingfu

谢谢413191246se兄的分享，期待更智能化、通用……

413191246se

谢谢 tangqingfu 兄关注！确实水平很低，需要大家批评指正，一直努力编程中……

谢谢 wkxxxr 朋友关注！——不大会用窗体，更不会用进度条和调节按钮来做出美观实用专业的窗体来，本着简单实用的原则用宏将就对付。以12字为例，可以将代码中：Case 12: s = 1: t = 2: r = 260 这一行的 t=2 变成 1.7 或 1.5 来试试，t=艺术字稀疏值，越小字越大（不过个人认为，电子印章毕竟是电子的，不必和真实的印章相符，美观、相像就可以了）。

loquat

对楼主的研究精神由衷地赞佩
对楼主的这份代码产生了兴趣，有空再站在楼主的肩膀上继续修改

413191246se

谢谢楼上夸奖！很乐意看到大家钻研实用 VBA 宏来造福大家，方便工作。我编程的代码，与 守柔版主、sylun 朋友这些高手是无法比拟的，但作为 VBA 小菜鸟，能发一份光就发一份光，所以我赞赏自由传播、免费共享代码精神。（此宏要是用窗体来做，参数不少，目前各个控件我不大会，以前看 VB5/6 的书籍时会一点点。）

loquat

感谢楼主为我们提供了这么好的代码
直接在楼主的代码基础上做了修改
1.最大程度减少对象读写操作，提高效率
2.执行代码时关系屏幕刷新，提高效率
3.部分地方采用了比较通用的写法
下一步的更新方向应该是将各个形状的大小尺寸做成参数，让用户自定义大小。

1. Sub 电子印章_v5.1_loquat()
   
2.     Application.ScreenUpdating = False
   
3.     Dim i As String, s As Single, t As Single, r As Single, aLength&
   
4.     Dim arr(1 To 4) As String
   
5.     i = InputBox("请输入印章正文！（有效汉字位数：3-30）", "电子印章", "辽宁省朝阳市通用模板公司")
   
6.     If i = "" Then Exit Sub
   
7.     aLength = Len(i)
   
8.     'Selection.ParagraphFormat.Alignment = wdAlignParagraphCenter  '不必要的格式处理，可以删掉
   
9.     Application.Options.AutoCreateNewDrawings = False
   
10.     If Len(i) = 30 Then   '使用If语句替代Select语句，理论上效率会高一点点
    
11.         s = 0.4: t = 0.8: r = 269.9  '根据经验设定Tracing, ScaleWidth, Adjustments的值
    
12.     ElseIf aLength = 29 Then s = 0.41: t = 0.85: r = 269.9
    
13.     ElseIf aLength = 28 Then s = 0.43: t = 0.9: r = 269.5
    
14.     ElseIf aLength = 27 Then s = 0.45: t = 1: r = 269.5
    
15.     ElseIf aLength = 26 Then s = 0.46: t = 1: r = 269.5
    
16.     ElseIf aLength = 25 Then s = 0.48: t = 1: r = 269.5
    
17.     ElseIf aLength = 24 Then s = 0.5: t = 1.1: r = 269
    
18.     ElseIf aLength = 23 Then s = 0.52: t = 1.1: r = 269
    
19.     ElseIf aLength = 22 Then s = 0.55: t = 1.1: r = 269
    
20.     ElseIf aLength = 21 Then s = 0.57: t = 1: r = 269
    
21.     ElseIf aLength = 20 Then s = 0.6: t = 1.1: r = 269
    
22.     ElseIf aLength = 19 Then s = 0.63: t = 1.2: r = 268
    
23.     ElseIf aLength = 18 Then s = 0.67: t = 1.3: r = 267
    
24.     ElseIf aLength = 17 Then s = 0.7: t = 1.4: r = 266.5
    
25.     ElseIf aLength = 16 Then s = 0.75: t = 1.5: r = 265.5
    
26.     ElseIf aLength = 15 Then s = 0.8: t = 1.6: r = 264.5
    
27.     ElseIf aLength = 14 Then s = 0.86: t = 1.7: r = 264
    
28.     ElseIf aLength = 13 Then s = 0.92: t = 1.8: r = 262
    
29.     ElseIf aLength = 12 Then s = 1: t = 2: r = 260
    
30.     ElseIf aLength = 11 Then s = 1.08: t = 2.3: r = 258.5
    
31.     ElseIf aLength = 10 Then s = 1.19: t = 2.5: r = 257
    
32.     ElseIf aLength = 9 Then s = 1.33: t = 2.8: r = 255
    
33.     ElseIf aLength = 8 Then s = 1.48: t = 3.1: r = 252
    
34.     ElseIf aLength = 7 Then s = 1.7: t = 3.5: r = 251
    
35.     ElseIf aLength = 6 Then s = 1.98: t = 3.9: r = 247
    
36.     ElseIf aLength = 5 Then s = 2.4: t = 4.9: r = 243
    
37.     ElseIf aLength = 4 Then s = 3: t = 5: r = 235
    
38.     ElseIf aLength = 3 Then s = 3.9: t = 5: r = 220
    
39.     Else
    
40.         MsgBox "印章有效汉字位数：3-30！", vbOKOnly + vbCritical, "电子印章"
    
41.     End If
    
42.     With ActiveDocument
    
43.         With .Shapes.AddTextEffect(msoTextEffect3, i, "宋体", 12!, msoFalse, msoFalse, 219.75, 103!)  '去掉Select语句和Selection语句，大幅提高效率
    
44.             '艺术字（s=宽度缩放,t=稀疏，r=满圆）
    
45.             .TextEffect.Tracking = t
    
46.             .ScaleHeight 12, msoFalse, msoScaleFromTopLeft
    
47.             .ScaleWidth s, msoFalse, msoScaleFromTopLeft
    
48.             .Fill.ForeColor.RGB = RGB(255, 0, 0)
    
49.             .Line.Weight = 0.25 '清晰
    
50.             .Line.ForeColor.RGB = RGB(255, 0, 0)
    
51.             .Adjustments(1) = r
    
52.             arr(1) = .Name
    
53.         End With
    
54.         With .Shapes.AddShape(msoShapeOval, 201.6!, 85!, 180!, 180!) '圆周
    
55.             .Fill.ForeColor.RGB = RGB(255, 255, 255)
    
56.             .Fill.Transparency = 1!
    
57.             .Line.Weight = 3.5
    
58.             .Line.Style = msoLineThickThin
    
59.             .Line.ForeColor.RGB = RGB(255, 0, 0)
    
60.             arr(2) = .Name
    
61.         End With
    
62.         With .Shapes.AddShape(msoShape5pointStar, 264.3, 147.8, 54.9, 47.6) '五角星
    
63.             .Fill.ForeColor.RGB = RGB(255, 0, 0)
    
64.             .Line.Weight = 0.25
    
65.             .Line.ForeColor.RGB = RGB(255, 0, 0)
    
66.             arr(3) = .Name
    
67.         End With
    
68.         With .Shapes.AddShape(msoShapeRectangle, 259!, 197!, 66!, 24!)  '附言
    
69.             arr(4) = .Name
    
70.             .Line.Visible = msoFalse
    
71.             .LockAspectRatio = msoTrue
    
72.             With .TextFrame
    
73.                 .MarginLeft = 0
    
74.                 .MarginRight = 0
    
75.                 .MarginTop = 0
    
76.                 .MarginBottom = 0
    
77.                 With .TextRange
    
78.                     .Text = "业务专用章"
    
79.                     .ParagraphFormat.Alignment = wdAlignParagraphCenter
    
80.                     .Font.Color = wdColorRed
    
81.                     .Font.Bold = True
    
82.                     .Font.Size = 7.5
    
83.                 End With
    
84.             End With
    
85.         End With
    
86.         With .Shapes.Range(Array(arr(1), arr(2), arr(3), arr(4))).Group    '这里应该使用通用写法，否则代码将只能在新建文档中执行，且只能执行一次
    
87.             .LockAspectRatio = msoTrue  '组合
    
88.             .ScaleWidth 0.5, msoFalse, msoScaleFromTopLeft '缩放
    
89.             .ScaleHeight 0.5, msoFalse, msoScaleFromTopLeft
    
90.         End With
    
91.     End With
    
92.     Application.ScreenUpdating = True
    
93. End Sub

复制代码

loquat

相关参数都是Single格式，写成Double（#）对效率会有一定的影响

413191246se

顶之以更新！（代码中屏幕刷新我屏蔽了，不太懂这个，懂的朋友请自行打开。）