リモートワークが増えてきたことで、押印処理についても電子で決済をすることが増えてきたかと思います。
まあ自分が所属している案件は考え方が古すぎるので、印刷物に印鑑を押すためだけに月末出社するとかいう阿保な行為をしていますが…。
今後、書類の印鑑を電子で済ませるということも増えてきそうです。
個人的には「署名欄に名前を書くだけでよいのでは?」と思うのですが、どうしても印鑑にこだわる人も多いので、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 topLine As Object
Set topLine = sh.Shapes.AddConnector(msoConnectorStraight, 4, 55, 85, 55)
With topLine.Line
.Visible = msoTrue
.ForeColor.RGB = RGB(255, 0, 0)
.Transparency = 0
.Weight = 1
End With
shapeNames(4) = topLine.Name
'日付の下線を作成する
Dim underLine As Object
Set underLine = sh.Shapes.AddConnector(msoConnectorStraight, 4, 30, 85, 30 )
With underLine.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 topLine As Object
Set topLine = sh.Shapes.AddConnector(msoConnectorStraight, 4, 55, 85, 55)
With topLine.Line
.Visible = msoTrue
.ForeColor.RGB = RGB(255, 0, 0)
.Transparency = 0
.Weight = 1
End With
shapeNames(4) = topLine.Name
'日付の下線を作成する
Dim underLine As Object
Set underLine = sh.Shapes.AddConnector(msoConnectorStraight, 4, 30, 85, 30)
With underLine.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プロジェクトのパスワードかけるしかないですかねえ。
素晴らしいですね!
例えばsetNameの第3引数は
ユーザーフォームのtext内容から引用させることは可能なのでしょうか?
ありがとうございます。
例で記載したmainの関数に引数を渡せるようにして、mainの関数をユーザーフォームから呼び出せるようにすればいけそうな気がします。
‘日付の上線を作成する
‘日付の下線を作成する
の所で変数の宣言が逆なのと変数を誤記しているため、オブジェクトのグループ化に失敗しています。
‘日付の上線を作成する
Dim underLine As Object ‘←topLineの誤記
Set underLine = sh.Shapes.AddConnector(msoConnectorStraight, 4, 55, 85, 55) ‘←Set topLineの誤記
With underLine.Line ‘←topLine.Lineの誤記
.Visible = msoTrue
.ForeColor.RGB = RGB(255, 0, 0)
.Transparency = 0
.Weight = 1
End With
shapeNames(4) = underLine.Name ‘←topLine.Nameの誤記
‘日付の下線を作成する
Dim topLine As Object ‘←underLineの誤記
Set topLine = sh.Shapes.AddConnector(msoConnectorStraight, 4, 30, 85, 30) ‘←Set underLineの誤記
With topLine.Line ‘←underLine.Lineの誤記
.Visible = msoTrue
.ForeColor.RGB = RGB(255, 0, 0)
.Transparency = 0
.Weight = 1
End With
shapeNames(5) = underLine.Name
おっしゃるとおり間違えていたので、記事の中のソースを修正しておきました。
ご指摘ありがとうございます!!
マクロの動作的には問題無いのですが、topLineとunderLineの線を引く位置が逆だったので、念のため指摘させていただきます。
‘日付の上線を作成する
Dim topLine As Object
Set topLine = sh.Shapes.AddConnector(msoConnectorStraight, 4, 55, 85, 55) ‘←4, 30, 85, 30 (現状、topLine としてunderLine を引いています)
‘日付の下線を作成する
Dim underLine As Object
Set underLine = sh.Shapes.AddConnector(msoConnectorStraight, 4, 30, 85, 30) ‘←4, 55, 85, 55 (現状、underLineとしてtopLineを引いています)
参考にしてくれる方がいたら、混乱させてしまうかもしれないので、記事修正させていただきました。
ご指摘ありがとうございます!!
配置したコンボボックス1.2.3に
3人の名前を入れた場合のコードを
ご教示下さいm(__)m
ワークシート上にあるActiveX ComboBoxの値を取得して名前を設定する方法は以下のような感じでしょうか。
‘コンボボックスの名前
Const CONBO_NAME1 = “ComboBox1”
Const CONBO_NAME2 = “ComboBox2”
Const CONBO_NAME3 = “ComboBox3”
上記部分にコンボボックスの名前を設定しています。
ComboBoxは、ワークシート上のフォームコントロールのComboBoxとかUserFormのComboBoxとか色々種類があり、それぞれで取得方法が異なるので意図していたものでなかったらすみません。