Stampのまとめ

Excelに日付印を模したオートシェイプを押印する、クラスモジュールを
作成した。そこで、現時点の最終形をこちらに載せておく。
※不定期に更新の可能性あり。

使い方は、新規に作成したクラスモジュールに、これを丸ごとコピー＆
ペーストしていただければＯＫ。
※下記のサンプルでは、このクラスモジュールを「Stamp」としている。

◆ソースコード（クリックで展開）◆

Option Explicit

' 日付印を作成するセル。
Dim TargetRange As Range

' シート左上から指定セル上辺までの距離。
Dim T As Double

'シート左上から指定セル左辺までの距離。
Dim L As Double

' H(1)：指定セルの高さ。
' H(2)：中央の日付を挟むように描画される水平線間の距離。
' H(3)：部署名の上辺から、氏名の下辺までの距離。
Dim H(3) As Double

' 指定セルの幅。
Dim W As Double

' 円の原点。
Dim Ox As Double
Dim Oy As Double

' 円の直径。
Dim D As Double

' 円の半径。
Dim R As Double

' 指定セルの高さおよび幅のうち小さい方と、円の直径の比率。
' ※指定セル内に収めるために設定。
' ※ρ１=1のとき、円は指定セルの幅または高さのうち、狭い方に内接する。
Public ρ1 As Double

' 直径Dに対するH(2)の比率。
Public ρ2 As Double

' 直径Dに対するH(3)の比率。
Public ρ3 As Double

' 各描画の始点。
Dim Sx(5) As Double
Dim Sy(5) As Double

' 各描画の終点。
Dim Ex(5) As Double
Dim Ey(5) As Double

' 描画線の幅。
Public LineWeight As Double

' 指定色。
Public StampColor As Long

' 部署名。
Public StampPart As String

' 氏名。
Public StampName As String

' フォント名。
Public FontName As String

' 各描画したオートシェイプ。
Dim Shape(5) As Excel.Shape

' 各描画したオートシェイプの名前。
' ※最後にグループ化の際に使用する。
Dim ShapeNames(1 To 5) As String

Public StampObject As Shape

Private Sub Class_Initialize()

    ' 初期値設定。
    ' ※この後のタイミングで、日付印作成前に変更可能。
    ρ1 = 0.9
    ρ2 = 0.35
    ρ3 = 0.9
    
    LineWeight = 1.5
    
End Sub

' 描画前の設定。
' この設定で、描画に必要な座標値などを得る。
Public Sub init(target_range As Range, _
                Optional stamp_color As Long = vbBlack, _
                Optional stamp_part As String = "部署名", _
                Optional stamp_name As String = "氏名", _
                Optional font_name As String = "メイリオ", _
                Optional fit_to_cell As Boolean = True)

    If target_range Is Nothing Then
        Set TargetRange = Selection(1)
    ElseIf target_range.MergeCells Then
        Set TargetRange = target_range
    ElseIf target_range.Count >= 2 Then
        Set TargetRange = target_range.Range("A1")
    Else
        Set TargetRange = target_range
    End If

    T = TargetRange.Top
    H(0) = TargetRange.Height
    L = TargetRange.Left
    W = TargetRange.Width
    
    D = WorksheetFunction.Min(H(0), W) * ρ1
    R = D / 2
    
    H(2) = D * ρ2
    H(3) = D * ρ3
    
    Ox = L + W / 2
    Oy = T + H(0) / 2
    
    Sx(1) = Ox - R
    Sy(1) = Oy - R
    Ex(1) = Ox + R
    Ey(1) = Oy + R
    
    Sx(2) = Ox - (R ^ 2 - (H(2) / 2) ^ 2) ^ 0.5
    Sy(2) = Oy - H(2) / 2
    Ex(2) = Ox + (R ^ 2 - (H(2) / 2) ^ 2) ^ 0.5
    Ey(2) = Sy(2)
    
    Sx(3) = Sx(2)
    Sy(3) = Oy + H(2) / 2
    Ex(3) = Ex(2)
    Ey(3) = Sy(3)
    
    Sx(4) = Ox - (R ^ 2 - (H(3) / 2) ^ 2) ^ 0.5
    Sy(4) = Oy - H(3) / 2
    Ex(4) = Ox + (R ^ 2 - (H(3) / 2) ^ 2) ^ 0.5
    Ey(4) = Ey(2)
    
    Sx(5) = Sx(4)
    Sy(5) = Sy(3)
    Ex(5) = Ex(4)
    Ey(5) = Oy + H(3) / 2

    StampColor = stamp_color
    StampPart = stamp_part
    StampName = stamp_name
    FontName = font_name
    
End Sub

' 日付印作成。
Public Sub DrawStamp(Optional picture_flag As Boolean = False)

    ' 円作成。
    DrawCircel
    
    ' 水平線作成。
    DrawLine
    
    ' 部署名および氏名をセットするための□作成。
    DrawSquare
    
    ' 作成したものをグループ化。
    Set StampObject = ActiveSheet.Shapes.Range(ShapeNames).Group
    
    ' 画像として貼り付け。
    If picture_flag Then
        StampObject.CopyPicture
        ActiveSheet.Paste
        StampObject.Delete
    End If
    
End Sub

' 円作成。
Private Sub DrawCircel()

    ' 円描画。
    Set Shape(1) = ActiveSheet.Shapes.AddShape(msoShapeOval, Sx(1), Sy(1), D, D)
    
        With Shape(1)
            
            ' 線色設定。
            .Line.ForeColor.RGB = StampColor
            
            ' 線幅設定。
            .Line.Weight = LineWeight
            
            ' 塗り潰し設定。塗り潰さない。
            .Fill.Visible = msoFalse
        End With
        
        With Shape(1).TextFrame2
        
            ' 今日の日付をセット。
            .TextRange.Characters.Text = Format(Date, "'yy.mm.dd")
            
            ' 文字色設定。
            .TextRange.Font.Fill.ForeColor.RGB = StampColor
            
            ' 文字の折り返し設定。折り返さない。
            .WordWrap = msoFalse
            
            ' 文字位置設定。中心に配置する。
            .VerticalAnchor = msoAnchorMiddle
            .TextRange.ParagraphFormat.Alignment = msoAlignCenter
            
            ' 上下左右の余白を０にする。
            .MarginLeft = 0
            .MarginRight = 0
            .MarginTop = 0
            .MarginBottom = 0
        End With
        
        ' 文字サイズを、円のサイズに合わせてフィットさせる。
        TextToFitShape Shape(1)
        
        ' フィットの際に円の位置がずれる場合があるため、
        ' 指定セルの中心と円の中心を合わせる。
        FitCenter TargetRange, Shape(1)
        
        ShapeNames(1) = Shape(1).Name
End Sub

' 水平線作成。
Private Sub DrawLine()

    Dim i As Long
        ' Shape(2)　上の線。
        ' Shape(3)　下の線。
        For i = 2 To 3
        
            ' 水平線を描画。
            Set Shape(i) = ActiveSheet.Shapes.AddConnector(msoConnectorStraight, Sx(i), Sy(i), Ex(i), Ey(i))
            With Shape(i).Line
                
                ' 始点の矢印解除。念のため。
                .BeginArrowheadStyle = msoArrowheadNone
                
                ' 終点の矢印解除。念のため。
                .EndArrowheadStyle = msoArrowheadNone
                
                ' 線を表示。
                .Visible = msoTrue
                
                ' 線幅設定。全体的な見た目が重たくならないよう、円の線幅の半分にした。
                .Weight = LineWeight / 2
                
                ' 線色設定。
                .ForeColor.RGB = StampColor
            End With
            
            ShapeNames(i) = Shape(i).Name
        Next
        
End Sub

' 部署名および氏名をセットするための□作成。
Private Sub DrawSquare()
    
    Dim i As Long
    
        ' Shape(4)　上の「部署名」用。
        ' Shape(5)　下の「氏名」用。
        For i = 4 To 5
        
            ' 四角を描画。
            Set Shape(i) = ActiveSheet.Shapes.AddTextbox(msoShapeRectangle, Sx(i), Sy(i), Ex(i) - Sx(i), Ey(i) - Sy(i))
            
            With Shape(i)
            
                ' 線を表示しない。見た目のため。
                .Line.Visible = msoFalse
                
                ' 塗りつぶししない。円の線を欠けさせないため。
                .Fill.Visible = msoFalse
            End With
            
            With Shape(i).TextFrame2
            
                ' 文字の折り返し設定。折り返さない。
                .WordWrap = msoFalse
                
                ' 文字位置設定。中心に配置する。
                .VerticalAnchor = msoAnchorMiddle
                .HorizontalAnchor = msoAnchorCenter
                
                ' 上下左右の余白を０にする。
                .MarginLeft = 0
                .MarginRight = 0
                .MarginTop = 0
                .MarginBottom = 0
                
                ' 文字セット。
                ' 部署名は、氏名に比べて長くなりがちなので、文字サイズを少し小さくした。
                ' TextToFitShapeを使用すると、見た目に小さくなりすぎるため、日付文字の
                ' ｎ倍という設定方法とする。
                Select Case i
                    Case 4
                        .TextRange.Characters.Text = StampPart
                        .TextRange.Font.Size = Shape(1).TextFrame2.TextRange.Font.Size * 0.8
                    Case 5
                        .TextRange.Characters.Text = StampName
                        .TextRange.Font.Size = Shape(1).TextFrame2.TextRange.Font.Size * 0.9
                End Select
                
                ' フォント名を設定。
                .TextRange.Font.NameComplexScript = FontName
                .TextRange.Font.NameFarEast = FontName
                .TextRange.Font.Name = FontName
                
                ' 文字色設定。
                .TextRange.Font.Fill.ForeColor.RGB = StampColor
                
                ' 見た目で文字が弱かったので、太字にする。
                .TextRange.Font.Bold = msoTrue
            End With
            
            ' 水平方向の文字はみ出しを可とする。
            Shape(i).TextFrame.HorizontalOverflow = xlOartHorizontalOverflowOverflow
            
            ' 垂直方向の文字はみ出しを可とする。
            Shape(i).TextFrame.VerticalOverflow = xlOartVerticalOverflowOverflow
            
            ShapeNames(i) = Shape(i).Name
        Next
        
End Sub

Function TextToFitShape(target_shape As Excel.Shape) As Double
    ' テキストの有無確認。無い場合は、Functionを終了する。
        If target_shape.TextFrame2.TextRange.Characters.Text = vbNullString Then
            Exit Function
        End If

    ' オートシェイプのサイズ取得。
    Dim H(1) As Double: H(0) = target_shape.Height
    Dim W(1) As Double: W(0) = target_shape.Width
    
    ' オートシェイプを一旦、文字サイズに合わせてサイズ変更。
        target_shape.TextFrame2.AutoSize = msoAutoSizeShapeToFitText
        
    ' 変更後のサイズ取得。
        H(1) = target_shape.Height
        W(1) = target_shape.Width
    
    ' オートシェイプの縦と横、各々の縮小（もしくは拡大）率のうち、
    ' 小さい方を取得（大きい方だと、オートシェイプから食み出る）。
    Dim ρ As Double
        ρ = WorksheetFunction.Min(H(0) / H(1), W(0) / W(1))
    
    ' もとのフォントサイズにρを掛け、目安のフォントサイズを得る。
    Dim FontSize As Double
        FontSize = target_shape.TextFrame2.TextRange.Font.Size * ρ
        
    Dim i As Long
        Do
            ' フォントサイズ仮決め。
            target_shape.TextFrame2.TextRange.Font.Size = FontSize
            
            ' 改めて、オートシェイプを文字サイズに合わせてサイズ変更。
            target_shape.TextFrame2.AutoSize = msoAutoSizeShapeToFitText
            
            ' 変更後のサイズを得る。
            H(1) = target_shape.Height
            W(1) = target_shape.Width
            
            ' 縦と横どちらか一方でも元のサイズを越えたら、そこで終了。
            If H(1) > H(0) Or W(1) > W(0) Then
                Exit Do
            
            ' そうでなければ、まだピッタリではない。フォントサイズを１増加。
            Else
                FontSize = FontSize + 0.1
            End If
            
            ' 無限ループ防止。
            i = i + 1: If i >= 100 Then Exit Do
        Loop
        
        ' サイズを越えてから抜けたので、１引いて丁度のサイズにする。
        FontSize = FontSize - 0.1
        
        ' オートサイズ解除。
        target_shape.TextFrame2.AutoSize = msoAutoSizeNone
        
        ' オートシェイプを最初の大きさに戻す。
        target_shape.Height = H(0)
        target_shape.Width = W(0)
        
        ' フォントサイズを最終値に変更。
        target_shape.TextFrame2.TextRange.Font.Size = FontSize
        
        ' 戻り値としてフォントサイズを返す。
        TextToFitShape = FontSize
End Function

Function FitCenter(target_range As Range, target_shape As Excel.Shape) As Excel.Shape
    Dim W As Double
        W = target_shape.Width
    Dim H As Double
        H = target_shape.Height
    Dim T As Double
        T = target_range.Top + (target_range.Height - H) / 2
    Dim L As Double
        L = target_range.Left + (target_range.Width - W) / 2
        
        target_shape.Top = T
        target_shape.Left = L
        
    Set FitCenter = target_shape
End Function

サンプルマクロがこちら。
※使い方の詳細や引数の説明については、クラスモジュール内のコメント参照。

Sub 押印()

    Dim Stamp As VBAProject.Stamp
    Set Stamp = New VBAProject.Stamp
        Stamp.init Selection, vbBlue, "Ａ営業所", "山本"
        Stamp.DrawStamp True
        
End Sub

参考まで。