ｅｘｃｅｌでオブジェクト（写真）を固定するには

質問

ｅｘｃｅｌで商品の表（１００行くらい）をつくりたいのですが、それぞれの商品に写真をつけたいと思います。

各行の項目として番号、商品名、説明、備考に加えて、右端に写真用のボタンがあって、そこをクリックするとウインドウが開き写真が見られて、写真を閉じるとまた表に戻るようなものがいいと思っています。
商品名を見たり、写真を見たりということを頻繁に繰り返すので、ハイパーリンクで別の場所に飛んでいって戻るのに操作が必要というよりは、写真を閉じるだけで元の表に戻れるという作りにしたいです。
そういう意味では、オブジェクトで写真を挿入し、写真は小さく縮めセルに収まるようなサイズにし、クリックしたらみられるようにしたいと思っています。
各行に挿入したオブジェクトがそれぞれの商品の写真の欄（セル）に固定されるようにするにはどうしたらいいでしょうか。
今はカーソルを動かすとセルを越えて動いてしまいますし、反対に、オブジェクトやシートロックをするとクリックしても写真が見られないという状態です。

それぞれの写真がそれぞれの行に収まって固定され、クリックするとすぐ見られ、すぐに閉じられるというためにはどうすればよいでしょうか。

このような動きができるほかのいい方法があれば、オブジェクトを使わなくてもいいです。

このファイルはメールで送信するのが前提です。

よろしくお願いいたします。

回答No.2

mitarashi · ベストアンサー

#1です。誰も期待していないと思いますが、グラフを介する方法がうまくいかなかった理由が判明しました。一旦ワークシートに貼付、縮小し、切り取り、JPEGで再度貼り付ける事でリサイズしようとしていたのですが、ワークシートに貼り付けているつもりが、グラフ上に貼り付けてしまっていたのでした。コードは次の通りですが、試行錯誤の名残で冗長かもしれません。
xl2010でも動作しましたが、xl2000では発生しなかった広い余白が発生したりします。また、画面更新を止めてあるつもりですが、一瞬画像の切り貼りが表示されたりします。
添付画像は少々わかりにくいかもしれませんが、xl2010での実行例です。

Sub pastePic2Comment()
Dim myComment As Comment
Dim myWidth As Double, myHeight As Double
Dim myChart As Chart, myChartName As String
Dim currentWS As Worksheet, currentCell As Range
Dim myPicture As Picture
Dim picPath As String
Const lsLength As Double = 300

Set currentCell = ActiveCell
Application.ScreenUpdating = False
picPath = Application.GetOpenFilename("画像ファイル , *.*")
If picPath = "False" Then Exit Sub
Set currentWS = ActiveSheet
Set myPicture = currentWS.Pictures.Insert(picPath)
With myPicture
If .Width > .Height Then
myWidth = lsLength
myHeight = lsLength * .Height / .Width
Else
myWidth = lsLength * .Width / .Height
myHeight = lsLength
End If
.Width = myWidth
.Height = myHeight
End With

Set myChart = Charts.Add
Set myChart = myChart.Location(Where:=xlLocationAsObject, Name:=currentWS.Name)
myChart.ChartArea.Border.LineStyle = 0
myChartName = Trim(Replace(myChart.Name, currentWS.Name, ""))
currentWS.Shapes(myChartName).Width = myWidth + 6
currentWS.Shapes(myChartName).Height = myHeight + 6
myPicture.Cut
currentCell.Activate
currentWS.PasteSpecial Format:="図 (JPEG)", Link:=False, DisplayAsIcon:=False
Set myPicture = Selection
myPicture.Cut
myChart.Paste
myChart.Export "C:\temp.jpg"
currentWS.Shapes(myChartName).Delete
ActiveCell.ClearComments
Set myComment = ActiveCell.AddComment
With myComment.Shape
.Line.Visible = msoTrue
.Fill.Visible = msoTrue
.Fill.ForeColor.RGB = RGB(255, 255, 255)
.Fill.UserPicture "C:\temp.jpg"
.Width = myWidth
.Height = myHeight
End With
Application.ScreenUpdating = True
End Sub

お礼

重ねてのお返事本当にありがとうございました。
御礼が遅くなり、大変申しわけありません。

せっかく詳しくお教え下さったのですが、残念ながら私にはちょっと理解が及ばないです。
ご丁寧な回答をいただいたのに、本当に申しわけありません。
どなたかが、検索等でこの質問を見て役に立てて下さることを祈っています。
何度もご丁寧にありがとうございました。

回答No.1

mitarashi

お望みの物とは異なると思いますが、昔投稿した、コメントに縮小画像を貼り付けるコードの簡略化にトライしてみました。
コメントに貼り付けるにはリサイズした画像をファイル保存後、読みこむ必要があります。縮小画像の保存にChartのExport機能を使おうと試みましたが、Chartに貼り付ける際に画像が変形されてしまってうまくいっておりません。
やむを得ずOfficeのグラフィックフィルターを用いる方法を使用しておりますが、JPEGの画質はいまいちです。
xl2010(WinXP SP3)での動作も確認しましたが、xl2000より画像の変換が非常に遅いです（前者はCeleron2.4G、後者はPentiumM 1.3G）2000ではプログレスバーが殆ど視認できないのに対し、2010では一秒近く表示されています。
Private Type FLTIMAGE
StructSize As Integer
Type As Byte
Reserved1(0 To 8) As Byte
hImage As Long
Reserved3(0 To 19) As Byte
End Type
Private Type FLTFILE
Reserved1 As Integer
Ext As String * 4
Reserved2 As Integer
Path As String * 260
Reserved3 As Currency
End Type
Private Declare Function GetFilterInfo Lib _
"C:\Program Files\Common Files\Microsoft Shared\Grphflt\JPEGIM32.FLT" _
(ByVal Ver As Integer, ByVal Reserved As Long, _
phMem As Long, ByVal flags As Long) As Long
Private Declare Function ExportGr Lib "JPEGIM32.FLT" _
(ff As FLTFILE, fi As FLTIMAGE, ByVal hMem As Long) As Long
Private Declare Function OpenClipboard Lib "user32" _
(ByVal hWndNewOwner As Long) As Long
Private Declare Function CloseClipboard Lib "user32" () As Long
Private Declare Function GetClipboardData Lib "user32" _
(ByVal uFormat As Long) As Long
Const CF_ENHMETAFILE = 14
Private Declare Function CopyEnhMetaFile Lib "gdi32" _
Alias "CopyEnhMetaFileA" _
(ByVal hemfSrc As Long, ByVal lpszFile As String) As Long
Private Declare Function DeleteEnhMetaFile Lib "gdi32" _
(ByVal hemf As Long) As Long
Private Declare Function GlobalFree Lib "kernel32" _
(ByVal hMem As Long) As Long

Sub pastePic2Comment()
Dim myComment As Comment
Dim myWidth As Double, myHeight As Double
Dim myChart As Chart, myChartName As String
Dim currentWS As Worksheet
Dim myPicture As Picture
Dim picPath As String

Const lsLength As Double = 400 'ここで画像の長片サイズを指定

Application.ScreenUpdating = False
picPath = Application.GetOpenFilename("画像ファイル , *.*")
If picPath = "False" Then Exit Sub
Set currentWS = ActiveSheet
Set myPicture = currentWS.Pictures.Insert(picPath)
With myPicture
If .Width > .Height Then
myWidth = lsLength
myHeight = lsLength * .Height / .Width
Else
myWidth = lsLength * .Width / .Height
myHeight = lsLength
End If
.Width = myWidth
.Height = myHeight
End With
SaveClipToJpg myPicture, "c:\temp.jpg"
myPicture.Delete
ActiveCell.ClearComments
Set myComment = ActiveCell.AddComment
With myComment.Shape
.Line.Visible = msoTrue
.Fill.Visible = msoTrue
.Fill.ForeColor.RGB = RGB(255, 255, 255)
.Fill.UserPicture "C:\temp.jpg"
.Width = myWidth
.Height = myHeight
End With
Application.ScreenUpdating = True
End Sub

' 出典 : http://vbatips.blog37.fc2.com/blog-entry-26.html#more
'imgの型のみ変更
Function SaveClipToJpg(img As Picture, Path As String) As Boolean
Dim tFltImg As FLTIMAGE
Dim tFltFile As FLTFILE
Dim hemf As Long
Dim hMem As Long

SaveClipToJpg = False
'クリップボードにコピー
img.CopyPicture
'Selection.CopyPicture
If OpenClipboard(0) Then
hemf = CopyEnhMetaFile( _
GetClipboardData(CF_ENHMETAFILE), _
vbNullString)
CloseClipboard
End If
If hemf = 0 Then Exit Function
' パラメータ設定
tFltFile.Path = Path & vbNullChar
With tFltImg
.StructSize = LenB(tFltImg)
.Type = 1
.hImage = hemf
End With
' フィルタ呼び出し
If GetFilterInfo(3, 0, hMem, &H10000) And &H10 Then
If ExportGr(tFltFile, tFltImg, hMem) = 0 Then
SaveClipToJpg = True
End If
End If
If hMem Then GlobalFree hMem
DeleteEnhMetaFile hemf
End Function

画像を100個もブックに取り込むとファイルが大きくなり、メール送信できなくなりますので、画像サイズを調整して下さい。
長片サイズ400で、330KB/10画像、100の場合で50KB/10画像程度でした。ご参考まで。

参考URL：

http://vbatips.blog37.fc2.com/blog-entry-26.html#more

お礼

次の回答とあわせ、幾度も詳しい回答をありがとうございました。
御礼が遅くなり、申しわけありませんでした。