印鑑画像を作成してExcelに挿入するVBAマクロ

リモートワークが増えてきたことで、押印処理についても電子で決済をすることが増えてきたかと思います。

まあ自分が所属している案件は考え方が古すぎるので、印刷物に印鑑を押すためだけに月末出社するとかいう阿保な行為をしていますが…。

今後、書類の印鑑を電子で済ませるということも増えてきそうです。

個人的には「署名欄に名前を書くだけでよいのでは?」と思うのですが、どうしても印鑑にこだわる人も多いので、ExcelにVBAで印鑑が画像を挿入する方法を考えてみました。

印鑑に記載する名前の取得方法の検討

同じようなことを考えている人は多いようで「印鑑 VBA 作成」などで検索すると、解説サイトが沢山見つかります。

そのほとんどが、PC上に保存されている印鑑の画像をVBAでExcelに挿入するというものです。

しかし、これでは印鑑の画像を各個人ごとに作成して配布するのが手間だと思います。

そこで印鑑の画像を自動生成するところから始めたいのですが、問題は何処から名前を取得するかです。

パッと思いつくところだと以下の3つです。

  • officeのユーザ名から取得する
  • PCの名前から取得する
  • PCのログインユーザ名から取得する
  • PCの名前をもとにADをLDAP検索する
  • PCの名前をもとにOutLookのアドレス帳を検索する

これは、その組織がどのように名前を管理しているかにもよるので、現場ごとに名前の取れそうなところがどこか探すしかないですね。

方法はそれぞれ以下になるかと思います。

officeのユーザ名から取得する

Dim strUserName as String
strUserName  = Application.UserName

PCの名前から取得する

Dim ws As Object
Dim strUserName as String
Set ws = CreateObject("WScript.Network")

strUserName  = ws.ComputerName

Set ws = Nothing

PCのログインユーザ名から取得する

Dim ws As Object
Dim strUserName as String
Set ws = CreateObject("WScript.Network")

strUserName  = ws.UserName

Set ws = Nothing

PCの名前をもとにADをLDAP検索する

以下当たりの記事を参考に…

https://oshiete.goo.ne.jp/qa/9089776.html

PCの名前をもとにOutLookのアドレス帳を検索する

以下当たりの記事を参考に…

※本題ではないので、コードが面倒なところは他のブログの記事を参照にさせてもらいました。

印鑑オブジェクトを作成する

次にVBAで印鑑を作成していきます。まずは、下記のような印鑑の土台になるオブジェクトを作成する関数を作成します。

Sub main()
    '印鑑を挿入するシート
    Const WORK_SHEET_NAME = "Sheet1"

    Dim sh As Worksheet
    Set sh = ThisWorkbook.Worksheets(WORK_SHEET_NAME)
    
    Dim inkan As Shape
    Set inkan = createInkanTemplate(sh)
End Sub

Function createInkanTemplate(sh As Worksheet) As Shape
    '印鑑を挿入するシート
    Const WORK_SHEET_NAME = "Sheet1"
    
    Dim inkan As Shape
    
    '印鑑オブジェクトを作成する
    Set inkan = sh.Shapes.AddShape(msoShapeOval, 1, 1, 85, 85)
    
    '印鑑の淵の色を赤色に変更する
    With inkan.Line
        .Visible = msoTrue
        .ForeColor.RGB = RGB(255, 0, 0)
        .Transparency = 0
        .Weight = 1
    End With
    
    '印鑑の色を塗りつぶす
    With inkan.Fill
        .Visible = msoTrue
        .ForeColor.ObjectThemeColor = msoThemeColorBackground1
        .ForeColor.TintAndShade = 0
        .ForeColor.Brightness = 0
        .Transparency = 0
        .Solid
    End With
    
    '印鑑に影をつける
    inkan.Shadow.Type = msoShadow24
    
    Set createInkanTemplate = inkan

End Function

印鑑の丸の大きさは、「印鑑オブジェクトを作成する」の部分のAddShapeの引数で変更することができます。AddShapeは第3引数が横幅、第4引数が高さになっています。

印鑑の淵の線の太さが気に入らないとかいう場合は、「.Weight = 1」を指定している部分を「.Weight = 1.5」とかにすれば良いです。

これ以外にあまり変更したくなるところはなさそうかなあ。

ちなみに名前とか日付を入れる関数と別にしたのは、ドキュメントによって印鑑のデザインが違っても、この印鑑を作る部分は変わらない(使いまわせる)と思ったからです。


印鑑オブジェクトに名前と日時を挿入する

次に先ほど作成した印鑑のオブジェクトに名前と日付を自動入力して、本物の印鑑のような画像を作成します。以下のようなイメージです。

作成したコードは以下になります。

Sub main()
    '印鑑を挿入するシート
    Const WORK_SHEET_NAME = "Sheet1"

    Dim sh As Worksheet
    Set sh = ThisWorkbook.Worksheets(WORK_SHEET_NAME)
    
    Dim inkan As Shape
    Set inkan = createInkanTemplate(sh)
    Call setName(sh, inkan, "田中", "承")
End Sub

Function createInkanTemplate(sh As Worksheet) As Shape
    '印鑑を挿入するシート
    Const WORK_SHEET_NAME = "Sheet1"
    
    Dim inkan As Shape
    
    '印鑑オブジェクトを作成する
    Set inkan = sh.Shapes.AddShape(msoShapeOval, 1, 1, 85, 85)
    
    '印鑑の淵の色を赤色に変更する
    With inkan.Line
        .Visible = msoTrue
        .ForeColor.RGB = RGB(255, 0, 0)
        .Transparency = 0
        .Weight = 1
    End With
    
    '印鑑の色を塗りつぶす
    With inkan.Fill
        .Visible = msoTrue
        .ForeColor.ObjectThemeColor = msoThemeColorBackground1
        .ForeColor.TintAndShade = 0
        .ForeColor.Brightness = 0
        .Transparency = 0
        .Solid
    End With
    
    '印鑑に影をつける
    inkan.Shadow.Type = msoShadow24
    
    Set createInkanTemplate = inkan

End Function


Sub setName(sh As Worksheet, inkan As Object, strName As String, strTop As String)
    Dim shapeNames(0 To 5) As String
    shapeNames(0) = inkan.Name
    
    '印鑑の名前オブジェクトを作成
    Dim shapeName As Shape
    Set shapeName = CreateTextObj(sh, 55, strName)
    shapeNames(1) = shapeName.Name
    
    '印鑑の日付オブジェクトを作成
    Dim shapeDate As Shape
    Set shapeDate = CreateTextObj(sh, 30, Format(Now, "yyyy.mm.dd"))
    shapeNames(2) = shapeDate.Name
    
    '印鑑の最上部のテキストを作成
    Dim shapeTopText As Shape
    Set shapeTopText = CreateTextObj(sh, 0, strTop)
    shapeNames(3) = shapeTopText.Name
    
    '日付の上線を作成する
    Dim underLine As Object
    Set underLine = sh.Shapes.AddConnector(msoConnectorStraight, 4, 55, 85, 55)
    With underLine.Line
        .Visible = msoTrue
        .ForeColor.RGB = RGB(255, 0, 0)
        .Transparency = 0
        .Weight = 1
    End With
    shapeNames(4) = underLine.Name
    
    '日付の下線を作成する
    Dim topLine As Object
    Set topLine = sh.Shapes.AddConnector(msoConnectorStraight, 4, 30, 85, 30)
    With topLine.Line
        .Visible = msoTrue
        .ForeColor.RGB = RGB(255, 0, 0)
        .Transparency = 0
        .Weight = 1
    End With
    shapeNames(5) = underLine.Name
    
    'グループ化する
   sh.Shapes.Range(shapeNames).Select
   Selection.ShapeRange.Group
End Sub

Private Function CreateTextObj(sh As Worksheet, offset As Integer, strText As String) As Shape
    'オブジェクトを作成
    Set CreateTextObj = sh.Shapes.AddShape(msoShapeRectangle, 0, 0, 85, 30)
    
    'オブジェクトの線を消す
    CreateTextObj.Line.Visible = msoFalse
    'オブジェクトにテキストを入れる
    CreateTextObj.TextFrame2.TextRange.Characters.Text = strText
    CreateTextObj.TextFrame2.TextRange.Font.Size = 14
    
    'オブジェクトの背景消す
    CreateTextObj.Fill.Visible = msoFalse
    
    'オブジェクトのテキストを赤色にする
    With CreateTextObj.TextFrame2.TextRange.Characters(1, Len(strText)).Font.Fill
        .Visible = msoTrue
        .ForeColor.RGB = RGB(255, 0, 0)
        .Transparency = 0
        .Solid
    End With
    
    'オブジェクトのテキストを中央に寄せる
    With CreateTextObj.TextFrame2.TextRange.Characters(1, Len(strText)).ParagraphFormat
        .FirstLineIndent = 0
        .Alignment = msoAlignCenter
    End With
    
    'オブジェクトの位置を調整する
    CreateTextObj.IncrementTop offset
    
End Function

setNameという関数が名前と日付を入力している関数になります。この関数の引数は以下になっています。

第一引数:印鑑を挿入するワークシート

第二引数:印鑑オブジェクト

第三引数:印鑑に印字する名前

第四引数:印鑑の上段に表示する文字列(今回の場合は、”承”)

この第三引数の名前を前述したPCから取得できる名前などにすることで、各個人の固有の印鑑になります。

システム上、名前を取得することがどうしても難しい場合は、

  • 初回にExcelを開いたときに、InputBoxで名前を入力させる
  • 入力させた名前を非表示シートに記載しておく
  • その名前を取得して印鑑の名前に利用する

という方法もありな気がします。

印鑑オブジェクトを所定のセルに移動させる

ここまでで印鑑のオブジェクトを作成することはできたので、印鑑を所定の位置に移動させて終わりになります。

特定のセルに図形オブジェクトを移動させるのは以下のコードになります。

Public Sub setShapeToCell(obj As Shape, r As range)
   obj.Top = r.Top + r.Height / 2 - obj.Height / 2
   obj.Left = r.Left + r.Width / 2 - obj.Width / 2
End Sub

単純にセルの高さと左端にそろえると、図形オブジェクトがセルの左端に行ってしまいます。

今回の印鑑はセルの中央に配置したいので、セルの高さとセルの幅を取得してその半分の位置に移動させます。

しかし、それでも印鑑のオブジェクト自身の大きさ分ずれてしまうので、地震の大きさの半分の値を加算します。

ここまでの、まとめると以下のようになります。

Sub main()
    '印鑑を挿入するシート
    Const WORK_SHEET_NAME = "Sheet1"

    Dim sh As Worksheet
    Set sh = ThisWorkbook.Worksheets(WORK_SHEET_NAME)
    
    Dim inkan As Shape
    Set inkan = createInkanTemplate(sh)
    Call setName(sh, inkan, "田中", "承")
    
    '作成した印鑑をC10に移動させる
    Call setShapeToCell(Selection.ShapeRange(1), range("C10"))
    
End Sub

Function createInkanTemplate(sh As Worksheet) As Shape
    '印鑑を挿入するシート
    Const WORK_SHEET_NAME = "Sheet1"
    
    Dim inkan As Shape
    
    '印鑑オブジェクトを作成する
    Set inkan = sh.Shapes.AddShape(msoShapeOval, 1, 1, 85, 85)
    
    '印鑑の淵の色を赤色に変更する
    With inkan.Line
        .Visible = msoTrue
        .ForeColor.RGB = RGB(255, 0, 0)
        .Transparency = 0
        .Weight = 1
    End With
    
    '印鑑の色を塗りつぶす
    With inkan.Fill
        .Visible = msoTrue
        .ForeColor.ObjectThemeColor = msoThemeColorBackground1
        .ForeColor.TintAndShade = 0
        .ForeColor.Brightness = 0
        .Transparency = 0
        .Solid
    End With
    
    '印鑑に影をつける
    inkan.Shadow.Type = msoShadow24
    
    Set createInkanTemplate = inkan

End Function


Sub setName(sh As Worksheet, inkan As Object, strName As String, strTop As String)
    Dim shapeNames(0 To 5) As String
    shapeNames(0) = inkan.Name
    
    '印鑑の名前オブジェクトを作成
    Dim shapeName As Shape
    Set shapeName = CreateTextObj(sh, 55, strName)
    shapeNames(1) = shapeName.Name
    
    '印鑑の日付オブジェクトを作成
    Dim shapeDate As Shape
    Set shapeDate = CreateTextObj(sh, 30, Format(Now, "yyyy.mm.dd"))
    shapeNames(2) = shapeDate.Name
    
    '印鑑の最上部のテキストを作成
    Dim shapeTopText As Shape
    Set shapeTopText = CreateTextObj(sh, 0, strTop)
    shapeNames(3) = shapeTopText.Name
    
    '日付の上線を作成する
    Dim underLine As Object
    Set underLine = sh.Shapes.AddConnector(msoConnectorStraight, 4, 55, 85, 55)
    With underLine.Line
        .Visible = msoTrue
        .ForeColor.RGB = RGB(255, 0, 0)
        .Transparency = 0
        .Weight = 1
    End With
    shapeNames(4) = underLine.Name
    
    '日付の下線を作成する
    Dim topLine As Object
    Set topLine = sh.Shapes.AddConnector(msoConnectorStraight, 4, 30, 85, 30)
    With topLine.Line
        .Visible = msoTrue
        .ForeColor.RGB = RGB(255, 0, 0)
        .Transparency = 0
        .Weight = 1
    End With
    shapeNames(5) = underLine.Name
    
    'グループ化する
   sh.Shapes.range(shapeNames).Select
   Selection.ShapeRange.Group
End Sub

Private Function CreateTextObj(sh As Worksheet, offset As Integer, strText As String) As Shape
    'オブジェクトを作成
    Set CreateTextObj = sh.Shapes.AddShape(msoShapeRectangle, 0, 0, 85, 30)
    
    'オブジェクトの線を消す
    CreateTextObj.Line.Visible = msoFalse
    'オブジェクトにテキストを入れる
    CreateTextObj.TextFrame2.TextRange.Characters.Text = strText
    CreateTextObj.TextFrame2.TextRange.Font.Size = 14
    
    'オブジェクトの背景消す
    CreateTextObj.Fill.Visible = msoFalse
    
    'オブジェクトのテキストを赤色にする
    With CreateTextObj.TextFrame2.TextRange.Characters(1, Len(strText)).Font.Fill
        .Visible = msoTrue
        .ForeColor.RGB = RGB(255, 0, 0)
        .Transparency = 0
        .Solid
    End With
    
    'オブジェクトのテキストを中央に寄せる
    With CreateTextObj.TextFrame2.TextRange.Characters(1, Len(strText)).ParagraphFormat
        .FirstLineIndent = 0
        .Alignment = msoAlignCenter
    End With
    
    'オブジェクトの位置を調整する
    CreateTextObj.IncrementTop offset
    
End Function

Public Sub setShapeToCell(obj As Shape, r As range)
   obj.Top = r.Top + r.Height / 2 - obj.Height / 2
   obj.Left = r.Left + r.Width / 2 - obj.Width / 2
End Sub

印鑑オブジェクトの課題

課題としては、印鑑のオブジェクトのグループ化を解除されて無理やり名前を変更される可能性があるということですね。

少しExcelを触ったことがある人の場合は、画像のグループ化解除の操作もできると思うので、解除して名前を書き換えるということが可能になります。

その場合は、印鑑のオブジェクトをパスワード保護して、VBAプロジェクトのパスワードかけるしかないですかねえ。


コメントを残す

メールアドレスが公開されることはありません。

日本語が含まれない投稿は無視されますのでご注意ください。(スパム対策)