Excelのパスが格納されている列の隣の列に画像を自動で表示させたい

質問

こんにちは。いつも過去ログを大変参考にさせていただいております。
今回も過去Q&Aを探したのですが、何分コーディングの基本を知らずに回答欄のコピペで済ましているため、自分で問題点を見つけることができません。

<質問内容＞
Bの列に画像のフルパスを入れてあります。その画像をAの列に自動で表示させるマクロボタンを作りたいのです。B列の２枚目までは上手く写真が表示されます。
しかし、パスが入っていない３列目はC:\NoPicture.jpgを表示させたいのですが、どうしてもそこで止まってしまい、
実行時エラー’1004:’
Picture クラスのInsert プロパティを取得できません。
とういうエラーメッセージが出ます。
正しいコードの書き方をどなたかお教えいただけますでしょうか？

＜問題点？＞
'r.Item(1).Value = s
With .Pictures.Insert(s).ShapeRange
この辺がうまくいっていないかと・・

＜シート内容＞
行　　列
1　　A(画像表示)　　B(画像のフルパス)　　
2　　 　　　　　　　　　　C:\teet01.JPG
3　　 　　　　　　　　　　C:\teet02.JPG
4　　 　　　　　 　　　　　 (空白)
5 　　　　 　　　　　　　 C:\teet03.JPG
.
.
20　　 　　　　　 　　 　　　C:\teet19.JPG

＜マクロ文＞
Private Sub CommandButton1_Click()
Const n As Long = 2 'margin
Dim r As Range
Dim i As Long
Dim x As Double
Dim s As String

With ActiveSheet
　　 For i = 2 To .Cells(.Rows.Count, 2).End(xlUp).Row '(B)セルは"2", 2行目から順にパスを取得
　　　　 Set r = .Cells(i, 1).MergeArea '(A)セルは"1"
　　　　 s = Cells(i, 2).Value
　　　　 If Dir(s) = "" Then
　　　　 s = "C:\NoPicture.jpg" '画像が無い場合NoPicture画像を表示
　　 Else
　　　 Dir Application.Path
　　 End If
　　 'r.Item(1).Value = s
　　 With .Pictures.Insert(s).ShapeRange
　　 .LockAspectRatio = msoTrue '縦横比固定
　　 x = Application.Min(r.Width / .Width, r.Height / .Height)
　　 If x < 1 Then .Width = .Width * 60 '画像の幅
　　 .Left = r.Left + (r.Width - .Width) / 2 '画像を左右中央に配置
　　 .Top = r.Top + (r.Height - .Height) / 2 '画像を上下中央に配置
　　 End With
　　 Next
　 End With

　 Set r = Nothing
End Sub

回答No.4

myRange · ベストアンサー

またまた登場、myRangeです。

＞顧客が「どうしてもエクセルでデータを欲しい」と言うことなので
＞恥ずかしながらお伺いしている次第です

質問することはなーんも恥ずかしいことではありませぬよ。
ただ、得た知識は必ずや自分のものにする、
という心意気が必須であることは言わずもがなのことですが。。。

では、本題。
CommandButtonのあるシートで実行するので、
かつ、画像はそのままでセルに嵌るということなので
より簡潔なコードにしてあります。

'----------------------------------------　
Private Sub CommandButton1_Click()
　　Dim R As Long
　　Dim myPic As String
　　Dim myCell As Range

　　For R = 2 To Cells(Rows.Count, 2).End(xlUp).Row
　　　　Set myCell = Cells(R, 1)
　　　　myPic = Cells(R, 2).Value
　　　　If myPic = "" Or Dir(myPic) = "" Then
　　　　　　myPic = "C:\aaa\NoPicture.jpg"
　　　　End If
　　　　With ActiveSheet.Pictures.Insert(myPic).ShapeRange
　　　　　　.Top = myCell.Top + (myCell.Height - .Height) / 2
　　　　　　.Left = myCell.Left + (myCell.Width - .Width) / 2
　　　　End With
　　Next
End Sub
'-------------------------------------

なお、明日、明後日と福岡への旅。
よってこれについての再質問は、今夜２３時３０分までに願います。
それか、月曜日に。。。
以上です。

お礼

myRangeさん！
23：26分です！
出来ました～！ありがとうございます！完璧です！

博多ですか？
明太子、歌舞伎・・良いですね～
楽しんで行ってきてください。気をつけて！

本当にありがとうございました。
>質問することはなーんも恥ずかしいことではありませぬよ。
>ただ、得た知識は必ずや自分のものにする、
>という心意気が必須であることは言わずもがなのことですが。。。

はい、これからも頑張ります！また何かあったらよろしくお願いします。

回答No.3

myRange

>その消していたものが巨大なNoPictureでした。

当方が、質問者のコードが、ん？　と言ったのはそこらあたりも含まれています。

巨大の原因は、
　　 If x < 1 Then .Width = .Width * 60 '画像の幅
これです。
画像の高さ、幅、どちらかが、または、どちらも、セルの高さ、幅より大きかったら、
画像の幅を６０倍してますよね？

　　わぁーーー、巨大！(^^;;;

それを含めおかしいと思われる部分など修正したのが下記のコードです。

'----------------------------------------
Private Sub CommandButton1_Click()
　　Const n As Long = 2　　'●もともと未使用
　　Dim r As Range
　　Dim i As Long
　　Dim x As Double　　　　'●今回は使用しない
　　Dim s As String

　With ActiveSheet
　　　For i = 2 To .Cells(.Rows.Count, 2).End(xlUp).Row
　　　　　Set r = .Cells(i, 1)
　　　　　s = .Cells(i, 2).Value
　　　　　If Dir(s) = "" Then s = "C:\aaa\NoPicture.jpg"
　　　　　With .Pictures.Insert(s).ShapeRange
　　　　　　　Range("D1") = .Width / .Height
　　　　　　　.LockAspectRatio = msoTrue
　　　　　　　If .Width >= r.Width Then .Width = r.Width * 0.9
　　　　　　　If .Height >= r.Height Then .Height = r.Height * 0.9
　　　　　　　.Left = r.Left + (r.Width - .Width) / 2
　　　　　　　.Top = r.Top + (r.Height - .Height) / 2
　　　　　End With
　　　Next
　End With
End Sub
'------------------------------

画像の高さ、幅がセルのそれより大きかった場合は、セルの９０％にしてあります。

それから、質問提示のコードで、
Set r = .Cells(i, 1).MergeArea と、MergeAreaを使ってますが、
もし結合セルを扱うのであればコードが違ってくることは言うまでもありません。

それと画像全部を無条件にセルの９０％にするとかは拙いのでしょうか？
以上です。

お礼

myRange 様

本当にご教授ありがとうございます！

>巨大の原因は、
>　　 If x < 1 Then .Width = .Width * 60 '画像の幅
>これです。
>画像の幅を６０倍してますよね？
ご指摘の通りですね。60mmのつもりでした。お恥ずかしい・・

早速修正していただいたコードでトライしてみましたところ、
まだ、NOPicture.jpgが入らず、
With .Pictures.Insert(s).ShapeRange
の位置でデバック？止まってしまいました。

ちなみにご教授いただいた確認方法、コードから直接コピペでB列任意の場所にNoPicture.jpgのパスを入れると,NoPictureを含めて最後の行までちゃんと画像が表示されます。ただその時は(D1)セルになぜか数値1.71969699859619　が入りました。計算結果のような・・

Range("D1") = .Width / .Height
とは、写真の大きさを（D１)セルに合わせるというコードという解釈でよろしいでしょうか？

以上のとおりよろしくお願い申し上げます。

補足

myRange 様

先程のお礼に追加させていただきます。

>Set r = .Cells(i, 1).MergeArea と、MergeAreaを使ってますが、
>もし結合セルを扱うのであればコードが違ってくることは言うまでも>ありません。

結合セルは扱っておりません。
今回の格闘の理由は、MsAccessで商品仕様書管理をしておりまして、顧客が「どうしてもエクセルでデータを欲しい」と言うことなので、恥ずかしながらお伺いしている次第です。OLE画像もテキストと一緒にExcelに貼りつけばこんな苦労しなくて済むのですが・・

＞それと画像全部を無条件にセルの９０％にするとかは拙いのでしょう＞か？
ご心配ありがとうございます。
貯めてある画像は、エクセルに貼り付け用にすべて約W60mmxH30mmに統一してありますので、１倍で大丈夫かと存じます。

以上のとおりよろしくお願い申し上げます。

回答No.2

myRange

回答１、myRangeです。

質問者のコードはコード的には、ん？　という部分もありますが、
そのままでもエラーは出ずに動作するコードです。
で、NoPicture.jpgないのでは？、との回答になりました。

目視での確認では間違いない、ということですから
再確認のため下記を試してみてください、間違いなく存在が確認できますので。

Ｂ列の任意のセル（Ｂ２が直ぐ確認できる）に
問題の画像のフルパス、"C:\NoPicture.jpg"　を入力してマクロを実行する。
存在すれば表示されるはずですよね。

但し、画像のフルパス、C:\NoPicture.jpg　は
手入力ではなく、現在のマクロからセルにコピペすること。
以上です。

お礼

myRange 様

ご返信ありがとうございます。
明日早速会社でご指示通り確かめてみます。

>質問者のコードはコード的には、ん？　という部分もありますが、
>そのままでもエラーは出ずに動作するコードです。
>で、NoPicture.jpgないのでは？、との回答になりました。

コード的には間違っていないとのご指摘ありがとうございます。
このサイト等から見よう見まねで作ったもので・・
もし他の作り方があるようでしたらお教えいただければ大変助かります。

補足

myRange 様
>但し、画像のフルパス、C:\NoPicture.jpg　は
>手入力ではなく、現在のマクロからセルにコピペすること。
>以上です。

結果の報告が遅れ申し訳ありません。
上記の方法、また名前を変えたり保存場所を変えたりしていても上手く行きませんでしたが、格闘している間に気づきました。
「NoPictureだけ表示しない」のではなく、「巨大に貼りつく（１００倍ぐらい？）」ということです。
実はマクロの終了の仕方もおかしかったのです。
マクロが終了後、他のセルの文字が見えないのでデリートキーで消していました。その消していたものが巨大なNoPictureでした。
つまりNoPictureを張付るコードのところだけ、画像の大きさ指示が抜けているようです。
ご教授いただければ幸いです。

回答No.1

myRange

＞パスが入っていない３列目はC:\NoPicture.jpgを表示させたいのですが
＞実行時エラー’1004:’
＞Picture クラスのInsert プロパティを取得できません。
＞とういうエラーメッセージが出ます。

Ｃドライブに、NoPicture.jpg　という名前の画像がないのでは？
チェックてみてください。
以上です。

お礼

myRangeさん早速のご返答ありがとうございます。
私も最初にそれを疑って、パスのコピペで確認しており、画像は実在します。