古庄　潤（ふるしょう じゅん）

本業はエンジニア。ICに様々な機械をつなぎ，電流やら電圧を測定する。もちろん，これらの測定器もVBAでコントロールし，取り込んだデータもマクロで処理する。人呼んで，マクロの鬼軍曹！

診断(15)
写真を貼り付ける

「先生，壊れたPCはどうなりました？」
「データ・ファイルは，ほぼサルベージできた。でも，OSとアプリケーションはゼロからインストール。おかげでレジストリもすっきり。便秘が治った気分である」
「ほほ～，それは不幸中の幸いですね」
「ところがじゃ，ExcelとWordのカスタマイズしたオプション設定がキレイさっぱり初期化されて，ちょっとご立腹」
「あらま～」
「勝手に段落になったり，見出しになったり，変数の小文字のiが大文字のIになったり」
「それは，Wordの話ですね」
「そうそう，Wordの話なんじゃが，イライラして原稿を書くどころの話じゃない」
「それは，仕事をしたくないというサインですね？」
「鋭い！」
「許しません」
「だめかぁ…」
「次の方ど～ぞ～」

今月の相談
「Excelのワークシートに，写真をたくさん取り込まなければなりません。手作業では，日が暮れてしまいます。合コンに間に合いません。どうか，哀れなOLに便利なマクロをお授けください」

「ほほ～，これはぜひとも助けてあげなければ。ね，先生」
「ゲール君，君は合コンに過敏すぎるぞ」
「いえ，無理難題を押し付けられる立場に共感しているんです」
「そうか，それは，ぜひとも助けてあげなければ…ん？」
「深く考えない。ささ，救いのマクロを」
「そうじゃな。どういうマクロにしようかのう」
「難しいんですか？」
「いや，難しいと言うよりは，ケースバイケースな要因が多すぎるのじゃ」
「ケースバイケース？」

「うむ，最近では，携帯電話の写真でも，いろいろなサイズで撮影できるじゃろ？」
「そうですね。画素数が増えたので，目的に合わせてサイズを選べるようになりました」
「それに，似たような写真が複数ある可能性もある」
「だから？」
「複数の写真を一気に取り込んで，ワークシートに貼り付けると，その後が大変になると思わんか」
「なるほど！ 例えば，私は，右斜め30度の笑顔が一番可愛いんですけど，右斜め35度の笑顔も捨て難い。左斜め18度の笑顔もナイスだし，22度の笑顔もいけてる。で，結局は20枚くらい撮影しちゃうんですが，これをまとめてワークシートに貼り付けると，どれがどれだかわからない，というわけですね」
「どの角度でも一緒だと思うが？」
「何か言いました？」

「いえ，何でもありません。まぁ，そういうことで，写真とその内容がわかる説明文とをセットにして貼り付ければ，わかりやすいじゃろう」
「はい。でも，説明文をいちいち入力するのは面倒だから…写真のファイル名でいいんじゃないですか？」
「ゲール君，ナイスアイデアじゃ。次は，写真を貼り付ける場所（セル）を，どう決定するかじゃな」
「一定間隔でいいんじゃないですか？」
「さっき言ったように，写真のサイズがばらばらの可能性もあるから，一定間隔というわけにはいかん」
「そうでした。だったら，ユーザーに決めさせればいいじゃないですか」
「そうじゃな。ここは汎用性を重視してそうしよう。まずは写真を貼り付ける台紙（Excelブック）を選んで，次に貼り付ける場所（左上のセル）を選ぶ。そして最後に貼り付ける写真のファイルを選んだら，できあがり。写真がたくさんあるということじゃから，無限ループにして，ダイアログボックスで[キャンセル]ボタンをクリックしたらマクロを終了。こんな感じでどうかな？」
「いいですねぇ。早速お願いします」
「では，ちちんぷいぷいの…えい！」

Option Explicit

Sub InsertPicture()
  Dim HINAGATA_BOOK As Workbook
  Dim myBOOK_FILE_NAME As String
  Dim myCELL As Range
  Dim myPICTURE_PATH_FILE_NAME As String
  Dim myPICTURE_FILE_NAME As String
  Dim mySTART_POSITION As Integer
  Dim myPOSITON As Integer

  myBOOK_FILE_NAME = _
    Application.GetOpenFilename("Excel ファイル (*.xls), *.xls", _
    Title:="写真を貼り付けるファイルを選んでください")  '<---(1)

  If myBOOK_FILE_NAME = "False" Then
    Exit Sub  '<---(2)
  End If

  Set HINAGATA_BOOK = Workbooks.Open(myBOOK_FILE_NAME)    '<---(3)

  Do    '<---(4)
    On Error GoTo ERRHANDLER1    '<---(5)
      Set myCELL = _
        Application.InputBox("写真を挿入する左上のセルを選択してください", Type:=8)  '<---(6)
    On Error GoTo 0  '<---(7)
    myCELL.Select  '<---(8)

    myPICTURE_PATH_FILE_NAME = _
      Application.GetOpenFilename("画像 ファイル (*.jpg), *.jpg,全ての ファイル (*.*), *.*", _
      Title:="挿入する写真を選んでください")  '<---(9)

    If myPICTURE_PATH_FILE_NAME = "False" Then
      Exit Sub  '<---(10)
    End If

    myPOSITON = 0  '<---(11)
    Do  '<---(12)
      myPOSITON = InStr(myPOSITON + 1, myPICTURE_PATH_FILE_NAME, "\")  '<---(13)
      If myPOSITON = 0 Then  '<---(14)
        Exit Do
      End If
      mySTART_POSITION = myPOSITON + 1  '<---(15)
    Loop
    myPICTURE_FILE_NAME = _
        Mid(myPICTURE_PATH_FILE_NAME, mySTART_POSITION)  '<---(16)
    myCELL.Offset(-1, 0).Value = myPICTURE_FILE_NAME  '<---(17)

    ActiveSheet.Pictures.Insert(myPICTURE_PATH_FILE_NAME).Select  '<---(18)

    Selection.ShapeRange.Line.Weight = 1.5  '<---(19)
    Selection.ShapeRange.Line.DashStyle = msoLineSolid  '<---(20)
    Selection.ShapeRange.Line.Style = msoLineSingle  '<---(21)
    Selection.ShapeRange.Line.Transparency = 0#  '<---(22)
    Selection.ShapeRange.Line.Visible = msoTrue  '<---(23)
    Selection.ShapeRange.Line.ForeColor.SchemeColor = 3  '<---(24)
    Selection.ShapeRange.Line.BackColor.RGB = RGB(255, 255, 255)  '<---(25)
  Loop

ERRHANDLER1:  '<---(26)
  Set HINAGATA_BOOK = Nothing  '<---(27)
  Set myCELL = Nothing
End Sub
リスト1●ワークシートに写真を貼り付けるマクロ

(1)GetOpenFilenameメソッドで，写真を貼り付ける台紙のフルパス＋ファイル名を取得し，変数myBOOK_FILE_NAMEに代入します。[キャンセル]ボタンをクリックすると，(2)のステートメントでマクロを終了します。

図1●写真を貼り付ける台紙（Excelファイル）を選ぶ
図1●写真を貼り付ける台紙（Excelファイル）を選ぶ
[画像のクリックで拡大表示]

(3)台紙を開いて，オブジェクト型変数HINAGATA_BOOKに代入します。
(4)ループの始まりです。このループは，始まりと終わりのどちらのステートメントにも終了する条件を記述していないので，無限ループになります。しかし，(5)と(10)のどちらかで，ループを抜けるか，マクロを終了するようになっています。
(6)InputBoxを使って，ユーザーに写真を貼り付ける左上のセルを選択させ，オブジェクト型変数myCELLに代入します。もし，ユーザーが[キャンセル]ボタンをクリックすると，オブジェクト型変数myCELLに代入するところでエラーが発生するので，(5)のステートメントでエラー・トラップを仕掛け，(26)のラベルにジャンプするようにします。

図2●写真を貼り付けるセルを選ぶインプットボックス
図2●写真を貼り付けるセルを選ぶインプットボックス