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

413191246se

    谢谢 肖表哥 朋友 提出中肯、很有见地的意见！
    但限于水平、时间、精力，我想到此为止吧！
    一直以来，我都是录制宏，直到 2011年6月才开始懂得进入 VBE 中编辑宏，渐渐地会编辑一点宏代码。虽然努力了好几年，但水平仍然很低，与论坛像 loauat/sylun/守柔版主/其他版主/高人 各位朋友无法比，实事求是地说，算是会了 VBA 一点皮毛。此宏就算是抛砖引玉，做个探索体验而已。
    下面我还是继续把精力放到 Word2003 通用模板 的制作上，及提高 VBA 应用水平上，多学习学习。

    在此不仅感谢 肖表哥，还有其他朋友，还有 loquat，此宏的合作者，还有 tangqingfu 兄，我辜负了他，没有给他做出答复（印章开口的问题）。

loquat

楼主太折杀小弟了，小弟水平很一般，实在不敢和上述前辈高人相提并论啊
有关vba起步，我从2012年8月份才开始接触，从录制宏开始，到现在也算是入门了，在公司写了几套纯vba自动化应用。
所花费的时间也多，那时候还是单身，一个人宅的时间基本都在研究，现在结婚生子了，基本没时间研究代码
看到楼主的这个宏，试用之后感觉很不错，想到几个点略作优化，纯粹就代码改代码，我本身并没有研究过印章相关规范，与楼主发布一系列模板和开源代码意图一也，仅作交流之用，希望能活跃气氛
楼主发布开源的精神很值得尊敬

xwdys

印章开口是什么东东？
建议：
1.通用模板做成在文档中任何位置都可生成印章。
2.尽可能还是在word2007及以上版本上做吧，毕竟word2003老了

413191246se

谢谢楼上朋友关注！
    1、印章开口指的是印章正文（环形文字）环绕的程度，这不是规范用语，只是我个人口头用语，本宏产生的印章，没有给出印章开口的值，只给出了满圆（整圆环绕）的大约值。
    2、此宏印章现在可落在光标所在页面。
    3、本人单位大多数电脑还是用 XP/Office2003，所以我也就不用更高版本，以随大流，有利于方便工作。

***在此向 loquat 朋友致歉！仅在一楼提出感谢，并未在宏中署上大名，因为我想，我绝大多数宏也不署名，谁用都可以，免费使用，共同分享才好，所以，我就武断地不给 loquat 署上大名了，这里提出感谢并致歉！(loquat 兄虽然入门比我短，我录制宏很多年，但直到2011年6月才懵懂地才知道编辑VBA，但领悟力比我高很多，我认为 loquat 兄是 守版/sylun/。。。等那样的高人！）
***向关注此宏的 tangqingfu 兄表示歉意！没有就他提出的印章开口问题给出默认值，我想此宏仅是作为探索体验而已，哪位朋友想深入研究，可以自行探索。
***谢谢关注本宏的所有朋友，谢谢大家！

loquat

53楼朋友的问题
1。应该只需要一个小修改，activedocument改为activedocument。range(aLngStart，aLngEng)
2。这个宏好像本来就可以通用吧

xwdys

谢谢解答，明白印章开口了。在公司名称前后插入全角空格，好象可解决开口问题？

xwdys

loquat 发表于 2015-8-16 22:25
53楼朋友的问题
1。应该只需要一个小修改，activedocument改为activedocument。range(aLngStart，aLngEng) ...

loquat：你好！我没说清楚，sorry.我所想的通用宏包括：印章大小、颜色、字体、字号、是否需要五角星、印章编号……等等.

413191246se

    我看网上说，电子印章严格来说，要到公安局备案呢！咱们用宏来模拟制作一个电子印章，就是在不严格的情况下，适用于有些单位给别的单位发的电子文档而已，我觉得只是作为一种象征罢了，不具有真正的法律效力。
xwdys 朋友请看下面一段《艺术字》代码（电子印章宏第一个图形）：
        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
*** 在上述代码中，倒数第三句代码 .Adjustments(1)=r(j-3)，现在是数组值，可以赋值给它为230或240，印章正文就是开口的了，但我个人认为开口印章不好看，不如满圆好。——但同时，这个值有时与字数和上面代码的正数第二句代码又有关系！.TextEffect.Tracking = t(j - 3)值，比如12个字的印章，它的值是2，如果字数不同，它的值不同，与前面说的 .Adjustments(1)=230 有联系！所以说，比较麻烦，有兴趣的朋友可以自行调节试验。

cuteword

仅仅分析了那个数组问题，用公式替代，不知道效果是否好些，供楼主参考。2007或者以上版本中代码有问题。只能在doc格式文档中插入。
略改进了一个小位置：将艺术字放在圈的上面，方便对艺术字的编辑。
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
    Dim B2 As Integer
'    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 .AddShape(msoShapeOval, 201.6!, 85!, 180!, 180!) '圆周
            .Fill.Transparency = 1!
            .Line.Weight = 3.5
            .Line.Style = msoLineThickThin
            arr(2) = .Name
        End With
        
'        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

       B2 = j - 2
        With .AddTextEffect(msoTextEffect3, i, "宋体", 12!, msoFalse, msoFalse, 219.75!, 103!)  '艺术字
            .TextEffect.Tracking = -1.5330927443 * Log(B2) + 5.7446883077
            .ScaleHeight 12, msoFalse, msoScaleFromTopLeft
            .ScaleWidth 0.000000207 * B2 ^ 6 - 0.0000210444 * B2 ^ 5 + 0.000858918 * B2 ^ 4 - 0.0180685488 * B2 ^ 3 + 0.2102186579 * B2 ^ 2 - 1.3689925448 * B2 + 5.0548985512, msoFalse, msoScaleFromTopLeft
            .Adjustments(1) = 14.2583547577 * Log(B2) + 226.1179984978
            arr(1) = .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

loquat

cuteword 发表于 2015-8-23 12:20
仅仅分析了那个数组问题，用公式替代，不知道效果是否好些，供楼主参考。2007或者以上版本中代码有问题。只 ...

您是用的什么方法得到了这么复杂的公式？
Excel规划求解？