may the VBA be with you

Excel VBAとか業務自動化とか

画像表示マクロ ができるまで その3

はじめに

前回、

vba-belle-equipe.hatenablog.com

表示される画像の大きさと位置を調節しました。

今回は、

  • 行を選択した時に画像変更

できるようにして、マクロを完成させたいと思います。

おさらい

ここまでで、

Sub test()
  Dim imgPath As String
  Dim myShape As Shape
  Dim bairitu As Double
  
  imgPath = "C:¥test¥フリー画像素材¥ahiru.jpg"
  Set myShape = ActiveSheet.Shapes.AddPicture( _
      Filename:=imgPath, _
      Linktofile:=True, _
      SaveWithDocument:=False, _
      Left:=0, _
      Top:=Rows(1).Height, _
      Width:=0, _
      Height:=0)
  
  With myShape
    .ScaleHeight 1, msoTrue
    .ScaleWidth 1, msoTrue
    bairitu = Columns(1).Width / .Width
    .ScaleHeight bairitu, msoTrue
    .ScaleWidth bairitu, msoTrue
  End With
End Sub

「imgPath」に、画像のパスを入れて、A2セルの上辺にあわせて表示するところまでできています。

選択した行の画像パスを表示する

f:id:vba-belle-equipe:20160401142011p:plain

こんな感じでD列に画像ファイルのパスが入っていますので、
シートのSelectionChangeイベントで、パスを表示させてみます。

Private Sub Worksheet_SelectionChange(ByVal Target As Range)
  Debug.Print Cells(Target.Row, 4)
End Sub

こんな感じです。

f:id:vba-belle-equipe:20160404140633p:plain

イミディエイトウインドウに表示されました。

画像パスを渡して表示させるようにする

'////標準プロシージャ////

Sub 画像表示(imgPath As String)
  Dim myShape As Shape
  Dim bairitu As Double
  
  Set myShape = ActiveSheet.Shapes.AddPicture( _
      Filename:=imgPath, _
      Linktofile:=True, _
      SaveWithDocument:=False, _
      Left:=0, _
      Top:=Rows(1).Height, _
      Width:=0, _
      Height:=0)
  
  With myShape
    .ScaleHeight 1, msoTrue
    .ScaleWidth 1, msoTrue
    bairitu = Columns(1).Width / .Width
    .ScaleHeight bairitu, msoTrue
    .ScaleWidth bairitu, msoTrue
  End With
End Sub
'////ワークシートのイベントプロシージャ////

Private Sub Worksheet_SelectionChange(ByVal Target As Range)
  Call 画像表示(Cells(Target.Row, 4))
End Sub

imgPathを引数にして表示させるように変更します。

結果

上から順にセルを選択していくと、

f:id:vba-belle-equipe:20160404141810p:plain

画像が重なって表示されちゃっています。


そして、空白の行をクリックすると

実行時エラー'1004':

指定したファイルが見つかりませんでした。

怒られます。(まあ、当然ですが)


あ、それとA1セルの見出しを変えないといけませんでしたね。

修正する

修正しましょう。

見出し変更

C列に見出しの情報があるので

Range("A1") = (Cells(Target.Row, 3))

をイベントプロシージャに追加すればOKです。

画像を消すマクロ

画像表示の前に、表示されている画像を消します。

'////標準プロシージャ////

Sub 画像削除()
  Dim o As Object
  For Each o In ActiveSheet.Shapes
    o.Delete
  Next
End Sub
'////ワークシートのイベントプロシージャ////

Private Sub Worksheet_SelectionChange(ByVal Target As Range)
  Call 画像削除
  Call 画像表示(Cells(Target.Row, 4))
  Range("A1") = (Cells(Target.Row, 3))
End Sub

こんな感じです。

ちなみに他にオートシェイプ等があっても全て消してしまう、強力すぎるマクロなので、myShapeに「.Name = "何か名前"」で名前をつけて、画像削除の中で「o.name」が一致する場合に削除、というふうにしたほうが一般的には良いでしょう。*1

1004対策

1004が起こる要因としては

  • 空白行がクリックされた
  • 画像ファイルのパスが間違っている
  • パスはあっているけど画像ファイルじゃない

等が考えられます。

文字列が空白かチェックしたりDir関数でファイルの存在を確認したりもできますが、今回は単純に「表示できない場合は何もしない」ようにします。

'////標準プロシージャ////

Sub 画像表示(imgPath As String)
  Dim myShape As Shape
  Dim bairitu As Double
  
  On Error GoTo err
  
  Set myShape = ActiveSheet.Shapes.AddPicture( _
      Filename:=imgPath, _
      Linktofile:=True, _
      SaveWithDocument:=False, _
      Left:=0, _
      Top:=Rows(1).Height, _
      Width:=0, _
      Height:=0)
  
  With myShape
    .ScaleHeight 1, msoTrue
    .ScaleWidth 1, msoTrue
    bairitu = Columns(1).Width / .Width
    .ScaleHeight bairitu, msoTrue
    .ScaleWidth bairitu, msoTrue
  End With
  
  Exit Sub
  
err:
  'MsgBox err.Number & "_" & err.Description

End Sub

「On Error GoTo err」で、エラーが起こったら「err:」に飛ぶようにしています。

エラー番号や内容がどうしても見たい場合は「MsgBox err.Number & "_" & err.Description」をコメントから戻せば確認できます。

終わりに

知人から言われて作ってみたものですが、なかなか面白かったです。

特に列の幅にあわせて画像の大きさが変えられるのがよいな、と思いました。

Excel便利!

*1:じゃあそう書けばいいのに