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

cuteword · 发表于 2015-8-23 19:11

第一眼看到这个宏的时候还是if else then的形式，觉得那些数据有一定规律（即存在一条光滑单调曲线来描述这种规律），后来看到数组形式的数据，有比较大的把握其中有规律，就发表了一下看法（见44楼）。因为楼主（见45楼）认为没有规律，所以自己基于楼主的数据通过拟合得到的曲线函数形式，以证实自己的想法，没有深究。
拟合得到曲线，可以突破数组数量的限制，当然字数也不能太少。
印章的要求应该很多，样式也很多，我具体不清楚，所以现在没有去研究这个东西。

413191246se · 发表于 2015-8-23 20:40

谢谢龚教授/先生和 loquat 的关注、回复！（我最近竟然未发现此帖有新回复。）
当初，S/T/R 其实我都是估算值，目测估算，看着像圆就可以了，并没有什么科学规律，但也许存在着规律，这个我不知道。龚教授用函数来探索规律，更是高端，我一点也不懂。
不知道两位用过《金格电子印章》那个免费版本没有？生成 GIF 图片，只有 276KB 的 EXE，我觉得很好，打入一个字，马上放到正确位置；打几个字就马上就放到其位，不知道是用什么程序编程的，怎么这么灵敏？但它是 GIF 图片，我觉得不如图形清晰，因为有上级单位给我单位有个文档就是用了电子文件头和电子印章，我寻思要是我单位给下级单位发文的话如果想要这两个，我没有，就不好了，正好《电子印章》是个话题，没看到有谁有这个宏，我就开天辟地地推出了这个宏，经 loquat 代码修改，变得通用在每个文档中，其实我的初衷是做比成样，差不多就行了，要是论科学，我还是觉得金格那个电子印章做得好，但是它不如我的宏小巧，要求不高的单位可以用它，最大特点就是方便！——真正有法律效力的电子印章，好像要经公安局备份、承认呢，所以，我这个宏就叫体验版了。
由于龚先生的代码太高端，我无法掌控（其实就是看不懂），所以，不想更新了，请龚先生见谅！就作为龚先生的一次学术探索吧！谢谢龚先生！另外，也谢谢 loquat，没有他，就没有这么好的宏。

loquat · 发表于 2015-8-23 22:51

cuteword 发表于 2015-8-23 19:11
第一眼看到这个宏的时候还是if else then的形式，觉得那些数据有一定规律（即存在一条光滑单调曲线来描述这 ...

怕就怕基于给定数据拟合的结果估计只能满足给定的数据结果

weiyingde · 发表于 2015-11-2 16:35

能否对代码进行修改，在Excel和PPt环境下也能生成印章呢？

413191246se · 发表于 2015-11-2 16:58

谢谢楼上朋友关注！因平时只用 Word 2003来办公，连 Excel 都几乎不用，更不用说 PPT 了，所以，对EXCEL/PPT 的 VBA 没有研究。如果有需要，可以在 Word 2003 中生成，再复制到 EXCEL/PPT 中。

weiyingde · 发表于 2015-11-2 18:55

EXCEL VBA 和word VBA差别不大，基本相同，我将activedocument换成activesheet没有效果，不知为何？
我正在制作学生成绩考评系统，包括批量生成成绩单，批量生成奖状，全部在excel环境下，一键生成，如果可以实现的话，我就不必实现制作印章了，可以将此过程略作修改集成到批量制作系统，那将是一件很美的差事。希望楼主给与支持。先谢了

weiyingde · 发表于 2015-11-2 18:59

loquat先生，向你求救，能否在将此代码略作修改，在EXCEL环境和ppt环境下，也能使用？
等你的回复了。

413191246se · 发表于 2015-11-3 17:19

weiyingde 朋友：我略改了一下对象（即WORD中当前活动文档为ActiveDocument，而在EXCEL中为ActiveBookSheet），下面是在 EXCEL 2003 中可用的《电子印章》宏：（其中，倒数第8/9两句代码中的 0.6 为缩放倍数，如果嫌印章图形小，就将 0.6 变大，如变为 0.8 或 1 等----但使用此宏前确保有活动工作簿！）：

Sub 电子印章_Excel()
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 ActiveSheet.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

复制代码

413191246se · 发表于 2015-11-4 11:13

weiyingde 朋友：因为OFFICE各个部件都是相通的，所以，绘图功能是相通的，只须改动对象即可！下面是 PPT下的《电子印章》宏：（你有时间可以按F8逐步调试---确保有打开的文档再应用）

Sub 电子印章_PPT()
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 ActiveWindow.Selection.SlideRange.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 = 6
.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

复制代码

loquat · 发表于 2015-11-5 17:38

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

用Excel拟合了一下
s = 0.00000021i6 - 0.00002353i5 + 0.00108178i4 - 0.02581479i3 + 0.34097722i2 - 2.45589843i + 8.79273602
R2 = 0.99976853
t = -0.0000005i6 + 0.0000481i5 - 0.0020226i4 + 0.0416843i3 - 0.4187612i2 + 1.5145338i + 3.3655615
R2 = 0.9947420
r = -0.000006i6 + 0.000644i5 - 0.027939i4 + 0.613368i3 - 7.218464i2 + 44.959586i + 136.616909
R2 = 0.997571

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

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