パスワードで任意の印鑑画像を挿入するExcelVBA

仕事でExcel使ってると、見栄え的に印鑑っぽい画像を使いたいってこと、ありませんか？そういう場面に出くわしたので作ってみたサンプルです。

イメージ

予めB2セルに画像を挿入するよー、ということにしておいて（セル範囲は変えられます）、起動ボタンを押します。

パスワードを聞かれるので、入力すると、

そのパスワードに対応する画像が挿入される、という感じ。あとその日の日付も入れてみました。

パスワード、と言ってもコード画面見ればバレバレなので、確実にその人が押したというものを確約するようなものではありません。（VisualBasicEditorをパスワードロックする、ということはできますが。）誰でも購入できるシャチハタの印鑑を押した、程度の感覚です。

画像の用意

必要な人の分の印鑑画像を作成してください。拡張子は背景透過のpngが良いんじゃないでしょうか。今回、例ではこの3つを作ってみました。

人名の他にも、業種によっては「済」「合格」なんて印もあると便利かもしれませんね。

コード

ではいつものごとくこちらの記事を参考に準備して、このコードをコピペします。

Sub stamp()
  Dim pass As String, rng As Range, shp As Shape, rng_shp As Range
  
  Set rng = Range("B2") '画像挿入するセル範囲
  pass = InputBox("パスワードを入力してください")
  If pass = "" Or pass = "False" Then Exit Sub '空白かキャンセルなら終了
  
  '前画像の削除
  For Each shp In ActiveSheet.Shapes 'アクティブシート状の図形をループ
    Set rng_shp = Range(shp.TopLeftCell, shp.BottomRightCell) '図形の範囲を取得
    If Not Intersect(rng_shp, rng) Is Nothing Then shp.Delete '指定範囲と重なったら図形を削除
  Next
  
  '画像を挿入
  If pass = "sato" Then ActiveSheet.Pictures.Insert("C:\stamp\sato.png").Select
  If pass = "suzuki" Then ActiveSheet.Pictures.Insert("C:\stamp\suzuki.png").Select
  If pass = "sumi" Then ActiveSheet.Pictures.Insert("C:\stamp\sumi.png").Select
  
  '画像の大きさ補正
  With Selection.ShapeRange
    .Width = rng.Width * 0.9 '横幅
    .Height = rng.Height * 0.9 '縦幅
    .Top = rng.Top + 3 '上からの位置
    .Left = rng.Left + 3 '左からの位置
  End With
  
  Range("B3") = Date '本日の日付を入れる
End Sub

動作確認はExcel2013/Win7です。ハイライト部分のセルを、お好みで指定してください。

解説

8～12行目では、指定範囲に既に画像があった場合、それを削除しています。続けて使いたいとき、既にある画像を手で削除しなきゃいけないのが面倒だったのでつけましたw 必要ない場合はこの部分はいりません。

14～17行目が、実際に画像を挿入している部分です。この例ではCドライブに画像ファイルを入れてありますが、場所は任意で構いません。もちろんパスワードと画像ファイル名が同じである必要はありませんで、ここもお好みで設定してください。

19～25行は、挿入した画像の大きさをセルに合わせて変更している部分です。

With Selection.ShapeRange
  .Width = rng.Width '横幅
  .Height = rng.Height '縦幅
  .Top = rng.Top '上からの位置
  .Left = rng.Left '左からの位置
End With

セルにぴったり合わせるならこう書くべきなのですが、あんまりぴったりすぎて枠とくっついちゃうのが微妙に思ったので、ちょっと余白をつけるために0.9掛けしています。

縦横比を無視してセルに合わせたい場合

ちょっと極端な例ですが、縦横比無視でセル範囲に合わせたい場合。（この例ではC4:E7です。）

Sub stamp()
  Dim pass As String, rng As Range, shp As Shape, rng_shp As Range
  
  Set rng = Range("C4:E7") '画像挿入するセル範囲
  pass = InputBox("パスワードを入力してください")
  If pass = "" Or pass = "False" Then Exit Sub '空白かキャンセルなら終了
  
  '前画像の削除
  For Each shp In ActiveSheet.Shapes 'アクティブシート状の図形をループ
    Set rng_shp = Range(shp.TopLeftCell, shp.BottomRightCell) '図形の範囲を取得
    If Not Intersect(rng_shp, rng) Is Nothing Then shp.Delete '指定範囲と重なったら図形を削除
  Next
  
  '画像を挿入
  If pass = "sato" Then ActiveSheet.Pictures.Insert("C:\Tmp\sato.png").Select
  If pass = "suzuki" Then ActiveSheet.Pictures.Insert("C:\Tmp\suzuki.png").Select
  If pass = "sumi" Then ActiveSheet.Pictures.Insert("C:\Tmp\sumi.png").Select
  
  '画像の大きさ補正
  With Selection.ShapeRange
    .LockAspectRatio = msoFalse '縦横比固定を解除
    .Width = rng.Width '横幅
    .Height = rng.Height '縦幅
    .Top = rng.Top '上からの位置
    .Left = rng.Left '左からの位置
  End With
End Sub

4行目でセル範囲を指定して、21行目で縦横比固定を解除してやります。後は同じです。

以上です！どなたかのお役に立てたら光栄ですー！