（純代碼）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 【重磅！一鍵生成印章】（更新）