GDIplusCODE


'☆標準モジュール

 '-- 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
 
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 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 Enum PictureTypeConstants
  vbPicTypeNone = 0
  vbPicTypeBitmap = 1
  vbPicTypeMetafile = 2
  vbPicTypeIcon = 3
  vbPicTypeEMetafile = 4
End Enum

'起動用
Sub showListView()
  With UserForm1
    .Caption = "ファイルをDrop"
    .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

 'アプリケーションまたはファイル名のフルパスからアイコンを抽出して、指定ファイルに保存
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

'たまたま見つけたVB用クラスから借用
'http://www.thevbzone.com/cResource.cls
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

'☆UserForm1モジュール
'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
ListViewにドロップしたファイルをWorksheetに埋め込む
