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

loquat

按楼主的思路，将6句中的5句颜色设置精简为1句
不过估计这个修改有可能会在某些情况下出现BUG

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

复制代码

413191246se

谢谢 loquat ！——请看看最新版本 v5.2（1楼），我觉得很不错！（但五角星旋转后似乎不太好看。）红色一条语句，如果放大后，似乎不妥。请帮忙检查检查，能否再精简一下代码，现在我看已经 98 行了，越少越好。
还有印章正文 + 附言栏，我是用逗号分隔的，用什么方法更好呢？

loquat

1.     If i Like "*，*" Then
   
2.         Dim k As Long, m As Long
   
3.         For m = 1 To Len(i)
   
4.             k = k + 1: If Mid(i, m, 1) = "，" Then Exit For
   
5.         Next m
   
6.         f = Right(i, Len(i) - k): i = Left(i, k - 1)
   
7.     Else
   
8.         f = "财务专用章"
   
9.     End If

复制代码

建议这样写：

1.     aIndex = InStrRev(i, "，")
   
2.     If aIndex Then
   
3.         f = Mid(i, aIndex + 1) '取分隔符右边的内容
   
4.     Else
   
5.         f = "财务专用章"       '无分隔符时，填写默认附言
   
6.     End If

复制代码

loquat

    If Len(f) = 5 Then
        x = 258.4
    ElseIf Len(f) = 4 Then
        x = 264.5
    ElseIf Len(f) = 3 Then
        x = 263.5: If Len(f) = 3 Then f = Left(f, 1) & " " & Mid(f, 2, 1) & " " & Right(f, 1)
    ElseIf Len(f) = 2 Then
        x = 270.5: If Len(f) = 2 Then f = Left(f, 1) & "  " & Right(f, 1)
    ElseIf Len(f) = 6 Then
        x = 251.5
    Else
        k = 0: f = 0: GoTo InputMark
    End If

这里也有重复的判断，删掉。。。

1.     If Len(i) < 3 Or Len(i) > 30 Then k = 0: f = 0: GoTo InputMark
   
2.     If Len(f) = 5 Then
   
3.         x = 258.4
   
4.     ElseIf Len(f) = 4 Then x = 264.5
   
5.     ElseIf Len(f) = 3 Then x = 263.5: f = Left(f, 1) & " " & Mid(f, 2, 1) & " " & Right(f, 1)
   
6.     ElseIf Len(f) = 2 Then x = 270.5: f = Left(f, 1) & "  " & Right(f, 1)
   
7.     ElseIf Len(f) = 6 Then x = 251.5
   
8.     Else: k = 0: f = 0: GoTo InputMark
   
9.     End If
   
10.     j = Len(i)
    
11.     If j = 5 Then

复制代码

loquat

楼主最近更新得很快

413191246se

顶以更新！！！

我心依旧流云

感谢楼主！
辛勤奉献{:soso_e100:}

loquat

1. (Len(i) < 3 Or Len(i) > 30) Or (Len(f) < 2 Or Len(f) > 6)

复制代码

这里使用两个外括号，似乎没有意义。

413191246se

谢谢！是的，我混同于 and 用法了！

413191246se

顶以更新！！！