日付印を作成 ③ 線を引いて名前を入れる

先日から時代の流れ（脱ハンコ）に逆らって、Excelで日付印の描画に
挑戦している。前回は円を描き、その中央に日付を入れてみた。
infoment.hatenablog.com

今日も、前回の続きから。

日付印の作成は、以下の手順で行う。

1. 必要な座標などを全て最初に計算する。
2. 円の描画と文字セット
3. 水平線を描画
4. テキストボックス（または相当品）の描画と文字セット
5. グループ化

前回は、1. と 2. を行った。今日は、３～５まで行う。
なお、以下は全て「Stamp」という名前のクラスモジュールに記載している。

水平線を描画

描画用の始点と終点座標は取得済みのため、線の描画自体はあっさりしている。
むしろ線幅や色、両端形状の指定などの処理が多い。

' 水平線作成。
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

日付印作成

ここまでの結果を、前回の「日付印作成用サブプロシージャ」に追加する。
ついでにここで、作成したもののグループ化も行う。

' 日付印作成。
Public Sub DrawStamp()

    ' 円作成。
    DrawCircel
    
    ' 水平線作成。
    DrawLine

    ' 部署名および氏名をセットするための□作成。
    DrawSquare

    ' 作成したものをグループ化。
    ActiveSheet.Shapes.Range(ShapeNames).Group
    
End Sub

結果の確認

それでは、標準モジュールに作成した以下で、結果を確認してみよう。

Sub 日付印()

    Dim Stamp As VBAProject.Stamp
    Set Stamp = New VBAProject.Stamp
        Stamp.init Selection
        
End Sub

期待した結果を得ることができた。
次回に続きます。

参考まで。