简易电子章制作小模块(VBA)

  Sub 图章() Application.DisplayAlerts = False Application.ScreenUpdating = False On Error Resume Next Application.Worksheets.Add Cells.ColumnWidth = 8.4 Cells.RowHeight = 14.2 ActiveSheet.Shapes.AddShape(msoShapeOval, 220, 150, 100, 100). _ Select Selection.ShapeRange.Fill.Visible = msoFalse ActiveSheet.Shapes("Oval 1").Select Selection.ShapeRange.LINE.ForeColor.SchemeColor = 10 SQL1 = InputBox("请输入部门名称", , "财务部") sql2 = InputBox("请输入日期", , CStr(Format(Date, "yyyy-mm-dd"))) sql3 = InputBox("请输入姓名", , "王贺") Range("E14").NumberFormatLocal = "yyyy-mm-dd" For x = 1 To 3 If x = 1 Then Range("E12:F13").Select: SQL = SQL1: sz = 15 If x = 2 Then Range("E14:F15").Select: SQL = sql2: sz = 12 If x = 3 Then Range("E16:F17").Select: SQL = sql3: sz = 22 With Selection .Merge .HorizontalAlignment = xlCenter .VerticalAlignment = xlCenter .FormulaR1C1 = SQL End With With Selection.Font .Bold = True .name = "宋体" .Size = sz .Strikethrough = False .Superscript = False .Subscript = False .OutlineFont = False .Shadow = False .Underline = xlUnderlineStyleNone .ColorIndex = 3 End With Next Selection.Merge Selection.HorizontalAlignment = xlCenter Selection.VerticalAlignment = xlCenter ActiveSheet.Shapes.AddLine(222, 190, 319, 190).Select Selection.ShapeRange.LINE.ForeColor.SchemeColor = 10 Selection.ShapeRange.LINE.Visible = msoTrue Selection.ShapeRange.LINE.Weight = 3# Selection.ShapeRange.LINE.Visible = msoTrue Selection.ShapeRange.LINE.Style = msoLineSingle ActiveSheet.Shapes("Oval 1").Select Selection.ShapeRange.LINE.Weight = 3# Selection.ShapeRange.LINE.Visible = msoTrue Selection.ShapeRange.LINE.Style = msoLineSingle ActiveSheet.Shapes.AddLine(222, 210, 319, 210).Select Selection.ShapeRange.LINE.ForeColor.SchemeColor = 10 Selection.ShapeRange.LINE.Visible = msoTrue Selection.ShapeRange.LINE.Weight = 3# Selection.ShapeRange.LINE.Visible = msoTrue Selection.ShapeRange.LINE.Style = msoLineSingle ActiveSheet.Shapes("Oval 1").Select Selection.ShapeRange.LINE.Weight = 3# Selection.ShapeRange.LINE.Visible = msoTrue Selection.ShapeRange.LINE.Style = msoLineSingle ActiveWindow.DisplayGridlines = False For x = 1 To 10 Range("E11:F18").Select Selection.CopyPicture Appearance:=xlScreen, Format:=xlPicture 'If X < 8 Then Y = X + 3 Else Y = X - 3: X = X + 3 y = x + 3 Cells(2 * x, y).Select ActiveSheet.Paste DX = x * 0.1 Selection.ShapeRange.ScaleWidth DX, msoFalse, msoScaleFromTopLeft Selection.ShapeRange.ScaleHeight DX, msoFalse, msoScaleFromTopLeft ' Selection.Formula = "$E$11:$F$18" Next Cells(14, 7).Select On Error GoTo 0 Application.DisplayAlerts = True Application.ScreenUpdating = True End Sub

 

 

 

 

工作中经常要求在电子文件上加盖电子章，在VBA里做了个小模块，很方便的制作电子章。