求Excel VBA代码：生成电子印章

weiyingde

t13564865256友，别这样说，看你前面的帮助，知道你有功力，静下来，可能对你不难。

weiyingde

在VBA中操作图形对象，我还没有接触，不知道自己对这方面是不是有悟性，很难说，只有深入钻研之后，才能回答之问题，但，我知道，这个一定能实现。

weiyingde

对于有这方面基础的EH友来说，不能，要我做，肯定要从操作图形最基础的知识学起，肯定要些时日，肯定要遇到一些技术的难题。知识目前的任务和探究要搁浅了。

weiyingde

看来，我的静静等待呀，要么等学会了杀猪，再吃猪肉！！
苦呀，急呀！！
大侠安在哉？！

lujkhua

建议你搜索本论坛或百度，多得很了！学会搜索也是一种技能！{:soso_e144:}

1. http://club.excelhome.net/thread-693686-1-1.html

复制代码

weiyingde

lujkhua 发表于 2015-11-6 20:31
建议你搜索本论坛或百度，多得很了！学会搜索也是一种技能！

你误解了，手工操作这个我早会，我要的是自动按要求生成印章，插在自动批量生成的奖状之中，而非人为操作的。
希望用VBA代码按要求。
见8楼的附件。

lujkhua

电子印章一般是在Word中用VBA代码生成。Excel中不是很普遍(我也是搬运别人的{:soso_e133:})

1. Sub 电子印章()
   
2.     If Documents.Count = 0 Then Documents.Add
   
3.     Dim i$, j&, a$, f$, x!, s, t, r, arr(1 To 4) As String
   
4. ipt:
   
5.     i = InputBox("印章正文(3-30字)和附言(2-6字)可以一起输入，但必须以中文逗号，分隔！", "电子印章", "广元电镀工业有限公司，业务专用章")
   
6.     If i = "" Then Exit Sub
   
7.     a = InStrRev(i, "，")
   
8.     If a Then f = Mid(i, a + 1): i = Left(i, a - 1) Else f = "财务专用章"
   
9.     j = Len(i)
   
10.     If j < 3 Or j > 30 Or Len(f) < 2 Or Len(f) > 6 Then GoTo ipt
    
11.     If Len(f) = 5 Then
    
12.         x = 258.4!
    
13.     ElseIf Len(f) = 4 Then x = 264.5!
    
14.     ElseIf Len(f) = 3 Then x = 263.5!: f = Left(f, 1) & " " & Mid(f, 2, 1) & " " & Right(f, 1)
    
15.     ElseIf Len(f) = 2 Then x = 270.5!: f = Left(f, 1) & "  " & Right(f, 1)
    
16.     ElseIf Len(f) = 6 Then x = 251.5!
    
17.     End If
    
18.     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!)
    
19.     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!)
    
20.     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!)
    
21.     With ActiveDocument.Shapes
    
22.         With .AddTextEffect(msoTextEffect3, i, "宋体", 12!, msoFalse, msoFalse, 219.75!, 103!)
    
23.             .TextEffect.Tracking = t(j - 3)
    
24.             .ScaleHeight 12, msoFalse, msoScaleFromTopLeft
    
25.             .ScaleWidth s(j - 3), msoFalse, msoScaleFromTopLeft
    
26.             .Adjustments(1) = r(j - 3)
    
27.             arr(1) = .Name
    
28.         End With
    
29.         With .AddShape(msoShapeOval, 201.6!, 85!, 180!, 180!)
    
30.             .Fill.Transparency = 1!
    
31.             .Line.Weight = 3.5
    
32.             .Line.Style = msoLineThickThin
    
33.             arr(2) = .Name
    
34.         End With
    
35.         With .AddShape(msoShape5pointStar, 264!, 147.8!, 54.9!, 47.6!)
    
36.             .Line.Weight = 0.25
    
37.             arr(3) = .Name
    
38.         End With
    
39.         With .AddTextEffect(msoTextEffect3, f, "宋体", 13!, msoTrue, msoFalse, x, 206!)
    
40.             .TextEffect.PresetShape = msoTextEffectShapePlainText
    
41.             .Fill.Visible = msoTrue
    
42.             .Line.Weight = 0.25
    
43.             arr(4) = .Name
    
44.         End With
    
45.     End With
    
46. End Sub

复制代码

huang1314wei

excel做出来是这个效果，你满意我再放代码

huang1314wei

算了，不管你满意不满意，我代码放出来吧，其实不难，所用到的属性都是通过录制宏得到的，我从来不怎么记这么多属性

1. Sub text()
   
2.     Dim i%, MyShape As Shape, m, n, y, x
   
3.     Application.ScreenUpdating = False
   
4.     For i = 3 To 5
   
5.         With Range("D" & i)
   
6.             m = .Top
   
7.             n = .Left
   
8.             y = .Width
   
9.             x = .Height
   
10.         End With
    
11.         Sheet1.Shapes.AddShape(msoShapeOval, n, m, y, x).Select
    
12.         With Selection
    
13.             .ShapeRange.Line.ForeColor.RGB = RGB(192, 0, 0)
    
14.             .ShapeRange.Fill.ForeColor.ObjectThemeColor = msoThemeColorBackground1
    
15.             .ShapeRange.TextFrame2.TextRange.text = Range("A" & i).text
    
16.             .ShapeRange.TextFrame2.TextRange.Font.Fill.ForeColor.RGB = RGB(192, 0, 0)
    
17.             .ShapeRange.TextFrame2.TextRange.Font.Bold = True
    
18.             .ShapeRange.TextEffect.PresetShape = msoTextEffectShapeArchUpCurve
    
19.         End With
    
20.         For Each MyShape In Sheet1.Shapes
    
21.             If MyShape.TopLeftCell.Address = Range("C" & i).Address Then
    
22.                 MyShape.Copy
    
23.                 Exit For
    
24.             End If
    
25.         Next
    
26.         Sheet1.Paste
    
27.         With Selection
    
28.             .ShapeRange.ZOrder msoBringToFront
    
29.             .ShapeRange.LockAspectRatio = False
    
30.             .Top = m + 15
    
31.             .Left = n + 15
    
32.             .Width = y - 30
    
33.             .Height = x - 30
    
34.         End With
    
35.         Sheet1.Shapes.AddTextbox(msoTextOrientationHorizontal, n + 15, m + y - 20, y - 30, 20).Select
    
36.         With Selection
    
37.             .ShapeRange.TextFrame2.TextRange.text = Range("B" & i).Value
    
38.             .ShapeRange.Fill.Visible = msoFalse
    
39.             .ShapeRange.Line.Visible = msoFalse
    
40.             With .ShapeRange.TextFrame2.TextRange.Font
    
41.                  .Bold = True
    
42.                  .Fill.ForeColor.ObjectThemeColor = msoThemeColorDark1 '
    
43.                  .Fill.ForeColor.RGB = RGB(192, 0, 0)
    
44.                  .Size = 11
    
45.             End With
    
46.          End With
    
47.     Next
    
48.     Range("E5").Select
    
49.     Application.ScreenUpdating = True
    
50. End Sub

复制代码

huang1314wei

请注意，不同电脑的分辨率原因，可能生成的shape位置有偏差，请自行
更改m,n,y,x的值，达到适配自己电脑的结果
附件参考：

VBA生成图章NO1.rar (191.16 KB, 下载次数: 449)

2015-11-7 22:05 上传

点击文件名下载附件