日付印を作成　② 各座標を初期設定する

Excel VBA 作ってみた

先日から時代の流れに逆らって、Excelで日付印の描画に挑戦している。
前回は、各座標を求める計算を一通り行った。これについて幾つか間違いが
あったため、まず修正したものを再掲する。
f:id:Infoment:20210827224158p:plain

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

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

そこで今日は、円の描画と文字セットまでを行ってみよう。

以降は全て、クラスモジュール「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
初期化

ユーザーが任意に微調整したい（であろう）パラメーターは、とりあえず
こちらで設定しておく。日付印を描画する前に、追加で変更（上書き）可。

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
円の描画と文字セット。

円を描画して、文字をセット。さらに

  1. 線色、線幅、塗り潰しなどについて設定。
  2. 文字のセットとフォントサイズの自動調整。

などを行う。なお、フォントサイズの自動調整と、その後に必要となる
円位置の再調整については、先日作成したものを再掲する。

' 円作成。
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

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
日付印作成

ここまでの結果を、日付印作成用サブプロシージャにまとめる。
といっても、この段階ではまだ一行しかない。

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

    ' 円作成。
    DrawCircel
    
End Sub
結果の確認

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

Sub 日付印()

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

f:id:Infoment:20210827230115g:plain

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

参考まで。