ExcelHome技术论坛

 找回密码
 免费注册

QQ登录

只需一步,快速开始

快捷登录

搜索
EH技术汇-专业的职场技能充电站 妙哉!函数段子手趣味讲函数 Excel服务器-会Excel,做管理系统 Excel Home精品图文教程库
HR薪酬管理数字化实战 Excel 2021函数公式学习大典 Excel数据透视表实战秘技 打造核心竞争力的职场宝典
300集Office 2010微视频教程 数据工作者的案头书 免费直播课集锦 ExcelHome出品 - VBA代码宝免费下载
用ChatGPT与VBA一键搞定Excel WPS表格从入门到精通 Excel VBA经典代码实践指南
楼主: 413191246se

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

[复制链接]

TA的精华主题

TA的得分主题

发表于 2015-8-2 22:50 | 显示全部楼层
本帖最后由 loquat 于 2015-8-2 22:51 编辑

按楼主的思路,将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
复制代码



TA的精华主题

TA的得分主题

 楼主| 发表于 2015-8-3 14:12 | 显示全部楼层
本帖最后由 413191246se 于 2015-8-3 14:15 编辑

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

TA的精华主题

TA的得分主题

发表于 2015-8-3 16:18 | 显示全部楼层
  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
复制代码

TA的精华主题

TA的得分主题

发表于 2015-8-3 16:23 | 显示全部楼层
[广告] VBA代码宝 - VBA编程加强工具 · VBA代码随查随用  · 内置多项VBA编程加强工具       ★ 免费下载 ★      ★使用手册
    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
复制代码

评分

1

查看全部评分

TA的精华主题

TA的得分主题

发表于 2015-8-3 16:25 | 显示全部楼层

TA的精华主题

TA的得分主题

 楼主| 发表于 2015-8-3 22:46 | 显示全部楼层

TA的精华主题

TA的得分主题

发表于 2015-8-5 06:50 | 显示全部楼层
感谢楼主!
辛勤奉献{:soso_e100:}

TA的精华主题

TA的得分主题

发表于 2015-8-5 10:38 | 显示全部楼层
[广告] VBA代码宝 - VBA编程加强工具 · VBA代码随查随用  · 内置多项VBA编程加强工具       ★ 免费下载 ★      ★使用手册
  1. (Len(i) < 3 Or Len(i) > 30) Or (Len(f) < 2 Or Len(f) > 6)
复制代码

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

TA的精华主题

TA的得分主题

 楼主| 发表于 2015-8-5 14:51 | 显示全部楼层
[广告] VBA代码宝 - VBA编程加强工具 · VBA代码随查随用  · 内置多项VBA编程加强工具       ★ 免费下载 ★      ★使用手册
谢谢!是的,我混同于 and 用法了!

TA的精华主题

TA的得分主题

 楼主| 发表于 2015-8-9 11:58 | 显示全部楼层
[广告] VBA代码宝 - VBA编程加强工具 · VBA代码随查随用  · 内置多项VBA编程加强工具       ★ 免费下载 ★      ★使用手册
顶以更新!!!
您需要登录后才可以回帖 登录 | 免费注册

本版积分规则

手机版|关于我们|联系我们|ExcelHome

GMT+8, 2024-3-29 17:26 , Processed in 0.065820 second(s), 11 queries , Gzip On, Redis On.

Powered by Discuz! X3.4

© 1999-2023 Wooffice Inc.

沪公网安备 31011702000001号 沪ICP备11019229号-2

本论坛言论纯属发表者个人意见,任何违反国家相关法律的言论,本站将协助国家相关部门追究发言者责任!     本站特聘法律顾问:李志群律师

快速回复 返回顶部 返回列表