Excel2003 既存シートへの写真自動貼付け

質問

Excel2003で作成された、工事現場作業写真シートがありまして、
作業状況写真を、既存のスペース枠に
画像フォルダから自動的に取り込み、貼付けする方法は無いでしょうか？

現在は、
オートシェイプの　□　を選択して、指定サイズに　□　を作成して、その後、オートシェイプの　書式設定→　色と線から、→　色の塗りつぶし効果→　図で図の選択によって、挿入したい図、写真等のファイルを選択しています。

一枚ごとの作業が面倒なことと、
選択画像の縦横比（一眼デジだと通常3：2。コンパクトデジカメ4：3と違う）が、オートシェイプの　□　サイズが合致していないと、無理やり　□サイズに画像が合わせられてしまうため、
縦長や横長になったりしますので、トリミングが必要な時もあります。

できれば、縦か、横のいずれかを固定値にして貼付けしたいのですが、良い方法やフリーソフトウェアなどありませんでしょうか？

回答No.1

xls88 · ベストアンサー

コントロールツールボックスのイメージ コントロールを使えばどうでしょうか？
Pictureプロパティに、LoadPictureで画像ファイルのパスを指定して読み込みできます。
PictureSizeModeプロパティをFmPictureSizeModeZoomに設定すれば縦横の比率が保持されます。

ActiveSheet.OLEObjects("Image1").Object.PictureSizeMode = 3
ActiveSheet.OLEObjects("Image1").Object.Picture = LoadPicture("D:\画像\goo001.jpg")

補足

早々のご回答ありがとうございます。
＞ActiveSheet.OLEObj...が判らず苦労しましたが、なんとかできました。
＞Object.PictureSizeMode = 3　で横サイズ固定で写真全体を載せる事ができました。ありがとうございます。

もう一つ「自動貼付け」ですが、
＞("D:\画像\goo001.jpg")だと、個別に写真を指定しなければいけないのですが、フォルダごと指定することは出来るのでしょうか？

回答No.5

xls88

>色々と試して何とか、出来ましたがなぜか、写真がA列に列挙されます。
色々試されたコードを掲載していただけるとアドバイスし易いのですが、どうでしょうか。

>既にシートに列挙した定型枠（画像枠）に並べることはやはり無理なんですかね？
無理ではありません。コントロールツールボックスのイメージ コントロールが用意されていれば写真が挿入されるはずです。
ANo.4で示したマクロで確認してみてください。

補足

＞色々・・・とは、試したものの、全然出来ませんでした。
VBAの作り方がまったく判らないので、どう説明したらよいのかさえわかりません。

ANO.1程度なら判るのですが、VBAを開いたとたん、どこからどう、手を付けて良いのか判らないんです。。

回答No.4

xls88

試しに、写真をImage枠に連続挿入ができるようにしてみました。
単純に順番でImage枠に挿入しているだけです。
実際には、ファイルを選ぶ、ファイルが写真かどうかを判定する、などの処理が必要かも知れません。

Sub test写真の連続挿入()
　　Dim myDir As String
　　Dim myFile As String
　　Dim i As Integer
　　Dim n As Integer

　　n = 10　　　　　　　　　　　　 '---Image枠の数
　　myDir = "D:\写真\"　　 　　 '---フォルダ指定
　　myFile = Dir(myDir, vbNormal) '---ファイル取得

　　Application.ScreenUpdating = False
　　Do Until myFile = ""　　　　　　'---ファイルがなくなるまで
　　　　If myFile <> "." And myFile <> ".." Then
　　　　　　If (GetAttr(myDir & myFile) And 16) <> 16 Then
　　　　　　　　i = i + 1
　　　　　　　　'画像を挿入
　　　　　　　　With ActiveSheet.OLEObjects("Image" & i)
　　　　　　　　　　.Object.PictureSizeMode = 3
　　　　　　　　　　.Object.Picture = LoadPicture(myDir & myFile)
　　　　　　　　End With
　　　　　　　　If i = n Then Exit Do '---n枚で終了する
　　　　　　End If
　　　　End If
　　　　myFile = Dir　　　　　　　　'---次のファイル名を返す
　　Loop
　　Application.ScreenUpdating = True
End Sub

# ファイルサイズがたちまち大きくなります。
# シートに直接、ファイルから挿入した方が良いかもですね。

補足

色々と試して何とか、出来ましたがなぜか、写真がA列に列挙されます。

既にシートに列挙した定型枠（画像枠）に並べることはやはり無理なんですかね？

回答No.3

xls88

”' C:\ 内のフォルダの名前を表示します。”以下の部分です。

下記のように、
プロシージャ名（SUB @@@ ()～End Sub）と変数を加え
Dir関数の第2引数を vbDirectory から vbNormal に変更
あと
>myPath = "C:\"　　' パスを設定します。
のところを実状に合わせ、写真ファイルのフォルダまでのパス名に変更してください。
例）myPath = "C:\Document\ユーザー\Picture\"

Sub tesdir()
　　Dim myPath As String
　　Dim MYNAME As String

　　myPath = "C:\"　　' パスを設定します。
　　MYNAME = Dir(myPath, vbNormal)

　　Do While MYNAME <> ""　　' ループを開始します。
　　　　' 現在のフォルダと親フォルダは無視します。
　　　　If MYNAME <> "." And MYNAME <> ".." Then
　　　　　　' ビット単位の比較を行い、MyName がファイルかどうかを調べます。
　　　　　　If (GetAttr(myPath & MYNAME) And vbNormal) = vbNormal Then
　　　　　　　　MsgBox MYNAME　　　' ファイル名を表示します。
　　　　　　End If
　　　　End If
　　　　MYNAME = Dir　　　　　　　　' 次のファイル名を返します。
　　Loop
End Sub

準備ができたらマクロを実行してみてください。
写真ファイル名がメッセージボックスで表示されると思います。

あと次のステップで
>MsgBox MYNAME　　　　'ファイル名を表示します。
の部分をImage枠に挿入するコードに書き換えれば良いことになります。

以下、余談になります。
>素人に付きむかつくような質問で申し訳ありませんが、お手柔らかにご教授をお願いいたします。
ということは、私のレスでむかつかれた部分があったのでしょうか？
そうでしたら、お詫びしたいと思います。
私はむかついてなんかいませんので、ご心配なくお願いします。
実は私も素人でして、こうした掲示板で諸先輩方に教えを請うている身なのです。
諸先輩方へのお礼を兼ねて、自助努力をされる方のお手伝いは精一杯させていただきたいと思っています。

補足

＞むかつかれた・・
とんでもありません。常に低い（背も？）姿勢を心がけたつもりが、返って誤解を招いてしまったようで、申し訳ありませんでした。

回答No.2

xls88

ANo.1 は、マクロを組めばどうでしょうか。という提案でした。

>もう一つ「自動貼付け」ですが、
>＞("D:\画像\goo001.jpg")だと、個別に写真を指定しなければいけないのですが、
>フォルダごと指定することは出来るのでしょうか？
Dir関数を使えば良いと思います。
VBAのヘルプに、ほとんどそのまま使える Dir関数の使用例が掲載されています。
やってみて、解らないところがあれば質問してください。

補足

Dir関数をVBAのヘルプで探したら、以下のような使用例を見つめることが出来ました。

Dim MyFile, MyPath, MyName
' "WIN.INI" が存在する場合、そのファイル名を返します(Microsoft Windows の場合)。
MyFile = Dir("C:\WINDOWS\WIN.INI")

' 指定した拡張子を持つファイル名を返します。複数の *.INI ファイル
' が存在すると、最初に見つかったファイル名を返します。
MyFile = Dir("C:\WINDOWS\*.INI")

' 引数を指定せずに再度 Dir 関数を呼び出すと、
' 同じフォルダにある次の *.INIファイルを返します。
MyFile = Dir

' 隠しファイル属性を持つ *.TXT ファイルであり、最初に見つかったファイル名を返します。
MyFile = Dir("*.TXT", vbHidden)

' C:\ 内のフォルダの名前を表示します。
MyPath = "c:\" ' パスを設定します。
MyName = Dir(MyPath, vbDirectory) ' 最初のフォルダ名を返します。
Do While MyName <> "" ' ループを開始します。
' 現在のフォルダと親フォルダは無視します。
If MyName <> "." And MyName <> ".." Then
' ビット単位の比較を行い、MyName がフォルダかどうかを調べます。
If (GetAttr(MyPath & MyName) And vbDirectory) = vbDirectory Then
Debug.Print MyName ' フォルダであれば、それを表示します。
End If
End If
MyName = Dir ' 次のフォルダ名を返します。
Loop

これを、どこで、どう使うのか皆目見当がつきません。。。
ANo.1　で作成した画像を貼り付ける場所で関数を用いるのでしょうか？素人に付きむかつくような質問で申し訳ありませんが、お手柔らかにご教授をお願いいたします。