現在、別フォルダに写真を1000枚ほど管理しています。エクセルに写真を貼り付けると重たくなるので貼付けは避けたいです。商品が完売になった時は、その行を上へ切り取り貼付けで移動させたりもしますので、写真移動しないので貼付けは不可です。また、各商品ごとに該当写真にリンクも考えましたが、全て行なうと1000件もの膨大な作業になります。例えば、下記のように商品名、型番、価格、数量、写真のファイル名の一覧表であった場合、このようなことはできないでしょうか。(1)型番または、写真ファイル名の横に縮小写真が一覧で表示される。(2)写真のファイル名のセルをクリックすると、すぐ横に写真を表示。(3)写真のファイル名のセルをクリックすると、該当写真にリンクして表示。
A B C D E
1 商品名 型番 価格 数量 写真
2 商品1 AAA-1 100 10 AAA-1.jpg
3 商品2 BBB-2 500 30 BBB-2.jpg
4 商品3 CCC-3 1000 15 CCC-3.jpg
～
101 商品99 CCC-100 700 20 CCC-100.jpg
第１希望としては、(1)です。商品一覧表をの画面に表示されている商品名全てにその縮小写真が表示されると便利なのですが、無理な時は(2)のセルをクリックすることで、写真を表示。その場合、必要以外は写真も消せるようにしたいです。最後として別フォルダの写真にリンクさせることです。
当方にとっては難しいので、一件ずつ写真をリンクさせることくらいしかできません。上記のようなことができる方、教えて下さい。よろしくお願い致します。
投稿日時 - 2010-07-19 15:38:49
F列に縮小写真を貼り付けます（サイズは行の高さに合わせます）
画像の存在するフォルダーのパスはコード中の定数に設定する必要があります。
作業用のワークシートを用います。下記ではSheet2としています。
実行都度、縮小画像を全部削除して、新規に貼り付け直す仕様です。
http://okwave.jp/qa/q5744704.html
が元々のコードですが、画像800個で、70～50秒程度かかりました。（PentiumM 1.3M）
画像にはハイパーリンクを設定しますので、クリックすると、ブラウザで元写真が表示されます。
xl2000用のコードなので、上位バージョンで動かなかったら悪しからず。また、中味の解説はいたしかねますので、興味を持たれたらご自分でお調べ下さい。
Sub test()
Dim lastRow As Long, i As Long
Const myFolder As String = "C:\Documents and Settings\?????\My Documents\"
lastRow = Range("E" & Rows.Count).End(xlUp).Row
'既存の画像の全削除
ActiveSheet.Pictures.Delete
For i = 2 To lastRow
Call setThumbnail(myFolder & Cells(i, 5).Value, Cells(i, 6), Sheets("Sheet2"))
Next i
End Sub
'引数 画像ファイルのフルパス、画像貼り付け先のセル、作業用のワークシート
'作業用のシートに縮小サイズで貼り付け後、目的のセルにコピー＆ペーストします
Private Sub setThumbnail(picPath As String, destCell As Range, tempSheet As Worksheet)
Application.ScreenUpdating = False
tempSheet.Activate
ActiveSheet.Pictures.Insert(picPath).Select
Selection.ShapeRange.LockAspectRatio = msoTrue
Selection.ShapeRange.Height = destCell.Height
Selection.Copy
destCell.Parent.Activate
destCell.Select
ActiveSheet.PasteSpecial Format:="図 (JPEG)", Link:=False, DisplayAsIcon:=False
ActiveSheet.Hyperlinks.Add Anchor:=Selection.ShapeRange.Item(1), Address:=picPath
tempSheet.Activate
Selection.Delete
destCell.Parent.Activate
Application.ScreenUpdating = True
End Sub
投稿日時 - 2010-07-19 17:44:52
0人が「このQ&Aが役に立った」と投票しています
