Excelのセルに，ＰＤＦなどのファイルを埋め込みたいのです

Excelのセルを，フォルダーのように使って，関連するファイルを，ドラッグ・アンド・ドロップで，埋め込みたいのです．

これまで，ハイパーリンクを使って用を足していましたが，リンク先のファイルのパスが変更されると，機能しなくなりますし，また，できれば１個のExcelファイルだけで，すべてを扱いたいと思っています．

Excel自身では，このような機能は持っていないと思うのですが，可能とするアドインをご存知でしたらお教えくださいますようお願いいたします．

No.4 回答者： mitarashi 回答日時： 2008/10/02 00:30

もう誰も見ていないでしょうが、アイコンファイルを毎回作成しないように変更しました。

それでも、時間がかかるものはかかるので、パッケージ化が律速になっているのかもしれません。コメント削除して簡素化したので、CreateOlePictureも載せておきます。なにぶん切り貼りなので、詳しい方に解放漏れなどご指摘いただけると幸いです。
<UserForm1>
'For Microsoft ListView Control, version 6.0
Private Sub ListView1_OLEDragDrop(Data As MSComctlLib.DataObject, Effect As Long, Button As Integer, Shift As Integer, X As Single, Y As Single)
Dim i As Long
Dim destRange As Range
Dim fileExtention As String

If TypeName(Selection) <> "Range" Then
MsgBox "最初の貼付先セルを選択しておいて下さい。"
Exit Sub
End If
Set destRange = Selection
Set destRange = destRange.Cells(1)
With Me
AppActivate Me.Caption
.ListView1.ListItems.Clear
If Data.Files.Count < 1 Then Exit Sub
For i = 1 To Data.Files.Count
destRange.Activate
fileExtention = getFileExtention(Data.Files(i))
If Dir(ThisWorkbook.Path & "\" & fileExtention & ".ico") = "" Then
Call extractIconToFile(Data.Files(i), ThisWorkbook.Path & "\" & fileExtention & ".ico")
End If
Call pasteFileObject(Data.Files(i), ThisWorkbook.Path & "\" & fileExtention & ".ico")
Set destRange = destRange.Offset(5, 0)
Next i
End With
End Sub
Private Function getFileExtention(fileName As String) As String
Dim Pos As Integer

Pos = InStrRev(fileName, ".")
getFileExtention = Mid(fileName, Pos + 1)
End Function
Private Sub UserForm_Activate()
With Me.ListView1
.OLEDragMode = 1
.OLEDropMode = 1
.View = 2
End With
End Sub

<Module1>
Sub Auto_Open()
Call showListView
End Sub
Sub showListView()
With UserForm1
.ListView1.Top = 0
.ListView1.Left = 0
.ListView1.Height = .InsideHeight
.ListView1.Width = .InsideWidth
End With
UserForm1.Show vbModeless
End Sub
Sub pasteFileObject(objFilePath As String, iconFilePath As String)
Dim FSO
Dim fileName As String

Set FSO = CreateObject("Scripting.FileSystemObject")
fileName = FSO.GetFileName(objFilePath)
ActiveSheet.OLEObjects.Add(fileName:=objFilePath, Link:=False, _
DisplayAsIcon:=True, IconFileName:=iconFilePath, _
IconIndex:=0, IconLabel:=fileName).Select
Set FSO = Nothing
End Sub
<Module2>
Public Const PICTYPE_UNINITIALIZED = -1
Public Const PICTYPE_NONE = 0
Public Const PICTYPE_BITMAP = 1
Public Const PICTYPE_METAFILE = 2
Public Const PICTYPE_ICON = 3
Public Const PICTYPE_ENHMETAFILE = 4
Public Const S_OK As Long = &H0
Public Const E_NOINTERFACE = &H80004002
Public Const E_POINTER = &H80004003
Public Const E_INVALIDARG = &H80000003
Public Const E_OUTOFMEMORY = &H8007000E
Public Const E_UNEXPECTED = &H8000FFFF
Public Const MAX_PATH = 260
Public Const FILE_ATTRIBUTE_NORMAL = &H80
Public Const SHGFI_LARGEICON = &H0
Public Const SHGFI_SMALLICON = &H1
Public Const SHGFI_ICON = &H100
Public Const WS_CHILD = &H40000000
Public Const WS_VISIBLE = &H10000000
Public Const SS_ICON = &H3&
Public Const SS_REALSIZEIMAGE = &H800

Public Type GUID
Data1 As Long
Data2 As Integer
Data3 As Integer
Data4(7) As Byte
End Type

Public Type PICTDESC_ALL
cbSizeOfStruct As Long
PicType As Long
hPicture As Long
hPALETTE As Long
Reserved As Long
End Type

Public Type PICTDESC_BMP
cbSizeOfStruct As Long
PicType As Long
hBitmap As Long
hPal As Long
End Type

Public Type PICTDESC_META
cbSizeOfStruct As Long
PicType As Long
hMeta As Long
xExt As Long
yExt As Long
End Type

Public Type PICTDESC_ICON
cbSizeOfStruct As Long
PicType As Long
hIcon As Long
End Type

Public Type PICTDESC_EMETA
cbSizeOfStruct As Long
PicType As Long
hEMF As Long
End Type

Private Type SHFILEINFO
hIcon As Long
iIcon As Long
dwAttributes As Long
szDisplayName As String * MAX_PATH
szTypeName As String * 80
End Type

Public Declare Function OleCreatePictureIndirect Lib "olepro32.dll" (ByRef PicDesc As Any, ByRef RefIID As GUID, ByVal fPictureOwnsHandle As Long, ByRef IPic As StdPicture) As Long

Public Declare Function SHGetFileInfo Lib "shell32.dll" Alias "SHGetFileInfoA" ( _
ByVal pszPath As String, _
ByVal dwFileAttributes As Long, _
psfi As SHFILEINFO, _
ByVal cbSizeFileInfo As Long, _
ByVal uFlags As Long) As Long

Public Enum PictureTypeConstants
vbPicTypeNone = 0
vbPicTypeBitmap = 1
vbPicTypeMetafile = 2
vbPicTypeIcon = 3
vbPicTypeEMetafile = 4
End Enum

Sub extractIconToFile(targetPath As String, iconFilePath As String)
Dim icn As StdPicture
Dim shinfo As SHFILEINFO
Dim lngImgHandle As Long
Dim pszPath As String

pszPath = targetPath
lngImgHandle = SHGetFileInfo(pszPath, _
FILE_ATTRIBUTE_NORMAL, _
shinfo, Len(shinfo), SHGFI_ICON Or SHGFI_LARGEICON)
Set icn = CreateOlePicture(shinfo.hIcon, vbPicTypeIcon)
SavePicture icn, iconFilePath
End Sub

Public Function CreateOlePicture(ByVal PictureHandle As Long, _
ByVal PictureType As PictureTypeConstants, _
Optional ByVal BitmapPalette As Long = 0, _
Optional ByVal MetaHeight As Long = -1, _
Optional ByVal MetaWidth As Long = -1, _
Optional ByRef Return_ErrNum As Long, _
Optional ByRef Return_ErrDesc As String) As StdPicture

Dim ReturnValue As Long
Dim PicInfo_BMP As PICTDESC_BMP
Dim PicInfo_EMETA As PICTDESC_EMETA
Dim PicInfo_ICON As PICTDESC_ICON
Dim PicInfo_META As PICTDESC_META
Dim ThePicture As StdPicture
Dim rIID As GUID

On Error Resume Next
Return_ErrNum = 0
Return_ErrDesc = ""
If PictureHandle = 0 Then
Return_ErrNum = -1
Return_ErrDesc = "Invalid bitmap handle"
ElseIf PictureType = vbPicTypeNone Then
Return_ErrNum = -1
Return_ErrDesc = "Invalid picture type specified."
ElseIf PictureType = vbPicTypeMetafile Then
If MetaHeight = -1 Or MetaWidth = -1 Then
Return_ErrNum = -1
Return_ErrDesc = "Invalid metafile dimentions specified."
End If
End If

With rIID
.Data1 = &H20400
.Data4(0) = &HC0
.Data4(7) = &H46
End With

Select Case PictureType
Case vbPicTypeBitmap
PicInfo_BMP.cbSizeOfStruct = Len(PicInfo_BMP)
PicInfo_BMP.PicType = PICTYPE_BITMAP
PicInfo_BMP.hBitmap = PictureHandle
PicInfo_BMP.hPal = BitmapPalette
ReturnValue = OleCreatePictureIndirect(PicInfo_BMP, rIID, 1, ThePicture)
Case vbPicTypeIcon
PicInfo_ICON.cbSizeOfStruct = Len(PicInfo_BMP)
PicInfo_ICON.PicType = PICTYPE_ICON
PicInfo_ICON.hIcon = PictureHandle
ReturnValue = OleCreatePictureIndirect(PicInfo_ICON, rIID, 1, ThePicture)
Case vbPicTypeMetafile
PicInfo_META.cbSizeOfStruct = Len(PicInfo_BMP)
PicInfo_META.PicType = PICTYPE_METAFILE
PicInfo_META.hMeta = PictureHandle
PicInfo_META.xExt = MetaWidth
PicInfo_META.yExt = MetaHeight
ReturnValue = OleCreatePictureIndirect(PicInfo_META, rIID, 1, ThePicture)
Case vbPicTypeEMetafile
PicInfo_EMETA.cbSizeOfStruct = Len(PicInfo_BMP)
PicInfo_EMETA.PicType = PICTYPE_ENHMETAFILE
PicInfo_EMETA.hEMF = PictureHandle
ReturnValue = OleCreatePictureIndirect(PicInfo_BMP, rIID, 1, ThePicture)
End Select
If ReturnValue <> S_OK Then
GoTo ErrorTrap
End If
Set CreateOlePicture = ThePicture
Exit Function

ErrorTrap:
Return_ErrNum = ReturnValue
Select Case ReturnValue
Case E_NOINTERFACE
Return_ErrDesc = "The object does not support the interface specified in riid."
Case E_POINTER
Return_ErrDesc = "The address in pPictDesc or ppvObj is not valid. For example, it may be NULL."
Case E_INVALIDARG
Return_ErrDesc = "One or more arguments are invalid."
Case E_OUTOFMEMORY
Return_ErrDesc = "Ran out of memory."
Case E_UNEXPECTED
Return_ErrDesc = "Catastrophic Failure."
Case Else
Return_ErrDesc = "Unknown Error."
End Select
End Function

この回答へのお礼

ご回答有難うございました．
詳細なマクロのソースを付けてくださっていますので，後で時間をかけて検討させていただきます．
歯が立つかどうかわかりませんが，トライしてみます．
まずは，有難うございました．

お礼日時：2008/10/13 12:48

No.3 回答者： mitarashi 回答日時： 2008/09/26 23:17

海外から、エクセルのシートにファイルをオブジェクトを幾つも貼り付けた資料が送られてくる事があります。

試しにやってみたところ、アイコンの表示のところではまってしまいました。
１．UserFormにListViewControlを設けると、そこにエクスプローラから、複数選択してD&Dしたファイルのパスを取得できます。ListViewControlのコードは、そのバージョンにより微妙に異なり変更の必要がある様です。
２．ファイルオブジェクトの貼付は、#1さんの回答されている操作を自動記録するとヒントが得られます。
貼付位置を指定する項目はなく、カレントセルに貼付られます。
問題はその中のアイコンファイルの取得です。ここには得体の知れない場所のアイコンファイル名が入ったり、関連づけられているアプリケーションの実行ファイルが入ったりする場合がある様です。
３．上記の「得体の知れない」から、このアイコンファイルは一回限りの使い捨てではないかと考え、同じ名前で、中味を変えて複数のオブジェクトに使い回してみましたが問題なさそうでした。（画像はxlsファイル内に取り込まれていて、再読込されない）
４．ファイルが関係づけられているアプリケーションのアイコンを取得して、ファイルに保存するにはWindowsAPIを使用する必要があります。これは元々C++用に作られているので、VBAから使用するには面倒を伴います。（自分も切り貼りして、なんとか使えるレベルです）
５．割り切って、アイコンは無くても気にしなければ、１＆２だけで話は済みます。或いは、使用するアプリケーションは決まっているでしょうから、それぞれに対応するアイコンファイルを予め作成しておいて、拡張子により使い分ける方法も考えられます。（通常は再読込されないので、ファイルオブジェクトを貼り付けたエクセルファイルだけを他の環境に移しても問題ない筈）
６．一応動いたソースを載せますが、当方のXL2000&Windows2000環境以外でも動くかどうかは疑問です。また、一部長いので、参照URLを参照下さい。そこから抜粋できる程度のスキルが無いと、アレンジできないと思います。
<Module1>
Sub Auto_Open()
Call showListView
End Sub
Sub showListView()
With UserForm1
.ListView1.Top = 0
.ListView1.Left = 0
.ListView1.Height = .InsideHeight
.ListView1.Width = .InsideWidth
End With
UserForm1.Show vbModeless
End Sub

Sub pasteFileObject(objFilePath As String, iconFilePath As String)
Dim FSO
Dim fileName As String

Set FSO = CreateObject("Scripting.FileSystemObject")
fileName = FSO.GetFileName(objFilePath)
ActiveSheet.OLEObjects.Add(fileName:=objFilePath, Link:=False, _
DisplayAsIcon:=True, IconFileName:=iconFilePath, _
IconIndex:=0, IconLabel:=fileName).Select
Set FSO = Nothing
End Sub
<Module2>
'-- API宣言 ---
Private Declare Function SHGetFileInfo Lib "shell32.dll" Alias "SHGetFileInfoA" ( _
ByVal pszPath As String, _
ByVal dwFileAttributes As Long, _
psfi As SHFILEINFO, _
ByVal cbSizeFileInfo As Long, _
ByVal uFlags As Long) As Long

'-- 定数・変数宣言 ---
Private Const MAX_PATH = 260
Private Const FILE_ATTRIBUTE_NORMAL = &H80
Private Const SHGFI_LARGEICON = &H0
Private Const SHGFI_SMALLICON = &H1
Private Const SHGFI_ICON = &H100 Private Const WS_CHILD = &H40000000
Private Const WS_VISIBLE = &H10000000
Private Const SS_ICON = &H3&
Private Const SS_REALSIZEIMAGE = &H800

Private Type SHFILEINFO
hIcon As Long
iIcon As Long
dwAttributes As Long
szDisplayName As String * MAX_PATH
szTypeName As String * 80
End Type

'アプリケーションまたはファイル名のフルパスからアイコンを抽出して、指定ファイルに保存
Sub extractIconToFile(targetPath As String, iconFilePath As String)
Dim icn As StdPicture
Dim shinfo As SHFILEINFO
Dim lngImgHandle As Long
Dim pszPath As String
Const vbPicTypeIcon As Long = 3

pszPath = targetPath
'アイコンの情報を取得
lngImgHandle = SHGetFileInfo(pszPath, _
FILE_ATTRIBUTE_NORMAL, _
shinfo, Len(shinfo), SHGFI_ICON Or SHGFI_LARGEICON)
'取得したアイコン情報を保存するにはOlePictureに変換する必要がある
Set icn = CreateOlePicture(shinfo.hIcon, vbPicTypeIcon)
SavePicture icn, iconFilePath
End Sub
ただし、CreateOlePicture関数は下記、参考URLなどをご参照下さい。
'http://www.thevbzone.com/cResource.cls
<フォームモジュール>
UserForm1にはListViewControlのみがあります。
'Microsoft ListView Control, version 6.0
Private Sub ListView1_OLEDragDrop(Data As MSComctlLib.DataObject, Effect As Long, Button As Integer, Shift As Integer, X As Single, Y As Single)
Dim i As Long
Dim destRange As Range

If TypeName(Selection) <> "Range" Then
MsgBox "最初の貼付先セルを選択しておいて下さい。"
Exit Sub
End If
Set destRange = Selection
Set destRange = destRange.Cells(1)
With Me
AppActivate Me.Caption
.ListView1.ListItems.Clear
If Data.Files.Count < 1 Then Exit Sub
For i = 1 To Data.Files.Count
destRange.Activate
Call extractIconToFile(Data.Files(i), ThisWorkbook.Path & "\" & "temp.ico")
Call pasteFileObject(Data.Files(i), ThisWorkbook.Path & "\temp.ico")
Set destRange = destRange.Offset(5, 0)
Next i
End With
End Sub

Private Sub UserForm_Activate()
With Me.ListView1
.OLEDragMode = 1
.OLEDropMode = 1
.View = 2
End With
End Sub

No.2 回答者： imogasi 回答日時： 2008/09/25 08:50

>Excelのセルを，

画像はエクセルのセルの情報になるのでなく、エクセルのシートが台紙のようになって、乗っかるだけのようです。画像の大きさをエクセルのセル１つの大きさに合わせたり、セル左上隅の位置にあわすのはVBAでも出来ますが。
連続自動で画像の挿入であれば、VBA程度で何とかなりそうです。質問者が勉強したら。
ただセルの情報にするとするとなると根本的なエクセルの改変が必要なように思いますので議論の外でしょう。
＞関連するファイルを，ドラッグ・アンド・ドロップで，埋め込みたいのです
これらはすべて高度なプログラムの技量が必要でしょう。
質問者は他人の作ったものがあり、使えればよいのでしょうが、もう少しエクセルに関して、勉強する必要があると思う。そのワリには高度なものを要求しているように思う。

No.1 回答者： taru_smile 回答日時： 2008/09/24 16:47

Excel 2003 での例です。

挿入　－　オブジェクト
「ファイルから」で文書選択、
「アイコンで表示」にチェックを入れてＯＫ