excel vba セルにマウスをのせて写真表示

質問

excel2003を利用しています。

技術的に可能か、どうかわかりませんが、もし可能であれば、
どのように、記述(vba)すればよいか教えていただきたいです。

とあるセルに、写真が保管されているパスが入力されています。

そのセルにマウスカーソルを合わせると、そのアドレスに保管されている

写真がポップアップやコメントマークのような感じで、パッと表示され、

マウスカーソルを、そのセルから、外すと写真の表示が消えるようにしたいです。

もし可能であれば、教えていただけると大変ありがたいです。よろしくお願いします。

回答No.6

mitarashi

#5のコードですが、文字数を納めるために切り詰め過ぎました
Const Quality = 85
だと、Variant型になってしまい、VarPtr(Quality)のところで0相当になってしまうのか、
画質0?のとんでもないJPEG画像になってしまう事が判明しました。
真面目に
Const Quality as long = 85
としていただく様にお願いします。

お礼

ご丁寧に何度も補足回答ありがとうございました。
現在まだ、検証できておりませんが、
日を改めて検証いたします。

回答No.5

mitarashi

#2です。試した結果、JPEGを貼り付ける方がファイルが小さいため、サムネイルのJPEG保存にトライしてみました。Tempフォルダーに保存しています。Win7Home(64bit)、xl2010(32bit)で動作しました。
Type Guid
Data1 As Long
Data2 As Integer
Data3 As Integer
Data4(7) As Byte
End Type
Type GdiplusStartupInput
GdiplusVersion As Long
DebugEventCallback As Long
SuppressBackgroundThread As Long
SuppressExternalCodecs As Long
End Type
Type EncoderParameter
Guid As Guid
NumberOfValues As Long
Type As Long
Value As Long
End Type
Type EncoderParameters
Count As Long
Parameter(15) As EncoderParameter
End Type

Declare Function GdiplusStartup Lib "gdiplus.dll" _
(ByRef token As Long, ByRef inputBuf As GdiplusStartupInput, ByVal outputBuf As Long) As Long
Declare Sub GdiplusShutdown Lib "gdiplus.dll" (ByVal token As Long)
Declare Function GdipDisposeImage Lib "gdiplus.dll" _
(ByVal image As Long) As Long
Declare Function GdipSaveImageToFile Lib "gdiplus.dll" _
(ByVal image As Long, ByVal filename As Long, ByRef clsidEncoder As Guid, ByVal encoderParams As Long) As Long
Declare Function CLSIDFromString Lib "ole32" _
(ByVal lpszCLSID As Long, ByRef pclsid As Guid) As Long
Declare Function GdipGetImageThumbnail Lib "gdiplus" (ByVal image As Long, ByVal thumbWidth As Long, _
ByVal thumbHeight As Long, thumbImage As Long, ByVal callback As Long, callbackData As Any) As Long
Declare Function GdipLoadImageFromFile Lib "gdiplus" (ByVal filename As Long, image As Long) As Long
Declare Function GdipGetImageHeight Lib "gdiplus" _
(ByVal image As Long, Height As Long) As Long
Declare Function GdipGetImageWidth Lib "gdiplus" _
(ByVal image As Long, Width As Long) As Long

Declare Function GetTempPath Lib "kernel32" Alias "GetTempPathA" (ByVal nBufferLength As Long, ByVal lpBuffer As String) As Long

Const MAX_PATH As Integer = 260
Const CLSID_JPEG = "{557CF401-1A04-11D3-9A73-0000F81EF32E}"
Const CLSID_QUALITY = "{1D5BE4B5-FA4A-452D-9CDD-5DB35105E7EB}"

Sub test()
Dim ret As Boolean
ret = SaveThumbnail("E:\hoge.jpg", getTempFolder & "temp.jpg")
End Sub

Function SaveThumbnail(srcFilename As String, dstfilename As String) As Boolean
Dim GdiPStartupInput As GdiplusStartupInput
Dim ret As Long
Dim GDIPToken As Long
Dim EncodParameters As EncoderParameters
Dim pSrcImage As Long
Dim pDstImage As Long
Dim picWidth As Long, picHeight As Long
Const Quality = 85

On Error GoTo errHandle
GdiPStartupInput.GdiplusVersion = 1
If GdiplusStartup(GDIPToken, GdiPStartupInput, 0&) <> 0 Then Exit Function
ret = GdipLoadImageFromFile(ByVal StrPtr(srcFilename), pSrcImage)
If ret <> 0 Then GoTo errHandle
ret = GdipGetImageWidth(pSrcImage, picWidth)
ret = GdipGetImageHeight(pSrcImage, picHeight)
If picHeight > picWidth Then
ret = GdipGetImageThumbnail(pSrcImage, 120, 160, pDstImage, 0, ByVal 0&)
Else
ret = GdipGetImageThumbnail(pSrcImage, 160, 120, pDstImage, 0, ByVal 0&)
End If
If ret <> 0 Then GoTo errHandle
GdipDisposeImage pSrcImage
If ret = 0 Then
EncodParameters.Count = 1
With EncodParameters.Parameter(0)
.Guid = ConvCLSID(CLSID_QUALITY)
.NumberOfValues = 1
.Type = 4
.Value = VarPtr(Quality)
End With
ret = GdipSaveImageToFile(pDstImage, StrPtr(dstfilename), ConvCLSID(CLSID_JPEG), VarPtr(EncodParameters))
If ret <> 0 Then
GoTo errHandle
Else
SaveThumbnail = True
End If
GdipDisposeImage pDstImage
End If
errHandle:
GdiplusShutdown GDIPToken
End Function

Function ConvCLSID(ByVal sGuid As String) As Guid
CLSIDFromString StrPtr(sGuid), ConvCLSID
End Function

Function getTempFolder() As String
Dim FolderName As String

FolderName = Space(MAX_PATH)
GetTempPath Len(FolderName), FolderName
getTempFolder = Left(FolderName, InStr(1, FolderName, vbNullChar) - 1)
End Function

回答No.4

kkkkkm

No3です。

先のコードだといちいち×でフォームを消さないといけないので面倒ですので以下のようにすると

Private Sub Worksheet_SelectionChange(ByVal Target As Range)
If Target.Value <> "" Then
If Dir(Target.Value) <> "" Then
UserForm1.Image1.Picture = LoadPicture(Target.Value)
UserForm1.Show (vbModeless)
ElseIf UserForm1.Visible = True Then
Unload UserForm1
End If
ElseIf UserForm1.Visible = True Then
Unload UserForm1
End If
End Sub

他のセルを選択したときにパスでなければフォームが消えますし、パスならその画像が引き続き表示されます。

お礼

ご丁寧に何度も補足回答ありがとうございました。
現在まだ、検証できておりませんが、
日を改めて検証いたします。

回答No.3

kkkkkm

No1です。

とりあえず、ご希望の動作とは違いますが、「セルをクリックして選択するセルを変更したとかだとそのアクションによって何かをさせることはできます」と書いたので一応の例です。

UserFormを作成してそこにコントロールのイメージを配置し、該当のシートのシートモジュールに以下のコードを

Private Sub Worksheet_SelectionChange(ByVal Target As Range)
If Target.Value <> "" Then
If Dir(Target.Value) <> "" Then
UserForm1.Image1.Picture = LoadPicture(Target.Value)
UserForm1.Show
End If
End If
End Sub

パスが入力されたセルを他のセルからクリックし直すとと画像の表示されたフォームが開きます。
フォームや画像の大きさを元の画像と合わせたい場合は、適宜それぞれプロパティで高さや幅をコードの中で指定してやることになります。

回答No.2

mitarashi

セルのコメントに画像を貼り付ける方法を回答した事があります。
http://okwave.jp/qa/q5640681.html

コメントに画像をロードするコードについて、xl2000時代の知見ですが、

>Range.Comment.Shape.Fill.UserPicture　の引数のファイル名は、
>constもしくは、string*50といった形でぴったりサイズに宣言した
>文字列変数でないと、エラーになります。
>このファイルは読み込んでしまえば、中味が変わっても可なので、使い回ししております。

ご参考まで。

回答No.1

kkkkkm

エクセルはマウスの位置を常時監視するという機能がありませんから、セルにマウスを「合わせる」とどうにかするという事が出来ません。

セルをクリックして選択するセルを変更したとかだとそのアクションによって何かをさせることはできまので、それで画像を表示させて、他のセルをクリックしたら消すとうことはできるでしょう。

ただ、それだとハイパーリンクを利用して画像を画像ソフトで表示するようにしても機能としては大差がないと思われます。