（純代碼）Excel VBA-WE010 【一鍵生成印章】

Sub ccc()
s = Application.InputBox(prompt:="這裡可以調節印章大小喲", Default:=1)
R = 100 * s
x0 = 100 + R
y0 = 50 + R
Pi = Application.WorksheetFunction.Pi() 'VBA 幫助可以查到有內置常數 Pi，但實際沒有，不確定是不是一個Bug
h = 30 * s
w = 30 * s
 
ActiveSheet.Shapes.AddShape(Type:=msoShapeOval, Left:=x0 - R, Top:=y0 - R, Width:=R * 2, Height:=R * 2).Select
Selection.ShapeRange.Line.BackColor.RGB = RGB(255, 0, 0) '有Bug，必須加上BackColor，並且必須在ForeColor前面
Selection.ShapeRange.Line.ForeColor.RGB = RGB(255, 0, 0)
Selection.ShapeRange.Line.Weight = 3 * s
Selection.ShapeRange.Fill.Visible = msoFalse
xx = R * 0.65
ActiveSheet.Shapes.AddShape(Type:=msoShape5pointStar, Left:=x0 - xx / 2, Top:=y0 - xx / 2, Width:=xx, Height:=xx).Select
Selection.ShapeRange.Fill.ForeColor.RGB = RGB(255, 0, 0)
Selection.ShapeRange.Line.Visible = msoFalse
[C1:V1].Formula = "=MID($A1,COLUMN()-2,1)"
[C1:V1] = [C1:V1].Value
[B1].Formula = "=LEN(A1)"
zi = [B1]
pyj = -20 '偏移角
a = (180 - pyj) * Pi / 180
b = pyj * Pi / 180
e = ((b - a) / (zi - 1))
For i = 0 To zi - 1
 l = (R - h * 0.85) * Cos(e * i + a) - w / 2 + x0
 If i = 0 Then l = l - 0.15 * h '後期的微調
 If i = 1 Then l = l - 0.05 * h '後期的微調
 If i = zi - 1 Then l = l + 0.15 * h '後期的微調
 If i = zi - 2 Then l = l + 0.05 * h '後期的微調
 t = y0 - ((R - h * 1) * Sin(e * i + a) + h * 0.85)
 ActiveSheet.Shapes.AddTextbox(Orientation:=msoTextOrientationHorizontal, _
 Left:=l, Top:=t, Width:=w, Height:=h).Select
 ra = (e * i + a) * 180 / Pi
 Selection.ShapeRange.Rotation = 90 - ra
 Selection.ShapeRange.Fill.Visible = msoFalse
 Selection.ShapeRange.Line.Visible = msoFalse
 Selection.Characters.Text = Cells(1, i + 3)
 Selection.HorizontalAlignment = xlCenter
 Selection.VerticalAlignment = xlCenter
 Selection.Font.Size = 240 * s / zi
 Selection.Font.Bold = True
 Selection.Font.Color = RGB(255, 0, 0)
Next
[C2:V2].Formula = "=MID($A2,COLUMN()-2,1)"
[C2:V2] = [C2:V2].Value
[B2].Formula = "=COUNTIF(C2:V2,""<>"")"
h = 45 * s
w = 140 * s
t = y0 + 0.4 * R
l = x0 - w / 2
ActiveSheet.Shapes.AddTextbox(Orientation:=msoTextOrientationHorizontal, _
 Left:=l, Top:=t, Width:=w, Height:=h).Select
Selection.Characters.Text = Cells(2, 1)
Selection.ShapeRange.Fill.Visible = msoFalse
Selection.ShapeRange.Line.Visible = msoFalse
Selection.HorizontalAlignment = xlCenter
Selection.VerticalAlignment = xlTop
Selection.Font.Size = w / ([B2] + 1)
Selection.Font.Bold = True
Selection.Font.Color = RGB(255, 0, 0)
For Each p In ActiveSheet.Shapes
 If p.Type = 17 Or p.Type = 1 Then p.Select Replace:=False
Next
Selection.ShapeRange.Group
End Sub

如需要代碼分析，請查閱：

零基礎學Excel VBA-WE010 【重磅！一鍵生成印章】（更新）