'OKwaveのqa4353361.html。すっかり忘れていたが、検索で再発見。
'ファイルに関連づけられたアプリのアイコンを取得して、ワークシートに
'パッケージとして貼り付ける際に設定している。下記はその参考にしたコード。
'これは、Bitmap,Icon,WMF,EMF（のハンドル）をstdPictureに変換するプロシージャ
'http://www.thevbzone.com/cResource.cls
'
'=============================================================================================================
'
' CreateOlePicture
'
' This function takes the handle to a picture (Bitmap, Icon, Metafile, or Enhanced Metafile) and creates
' an OLE StdPicture object from it that can be used like the "Picture" properties of such VB objects as
' Form's, PictureBox's, ImageBox's, etc.
'
' Parameter: Use:
' --------------------------------------------------
' PictureHandle Handle to the picture to create.
' - If PictureType = vbPicTypeBitmap : this must be a handle to a HBITMAP
' - If PictureType = vbPicTypeIcon : this must be a handle to a HICON
' - If PictureType = vbPicTypeMetafile : this must be a handle to a HMETAFILE
' - If PictureType = vbPicTypeEMetafile : this must be a handle to a HENHMETAFILE
' PictureType Specifies the type of picture object to create. These are the different types
' of pictures that can be specified:
' vbPicTypeBitmap <-- DEFAULT
' vbPicTypeEMetafile
' vbPicTypeIcon
' vbPicTypeMetafile
' BitmapPalette Optional. Specifies the handle to a Palette to use in the createion process.
' MetaHeight Optional. If the PictureType is vbPicTypeMetafile, the height of the Metafile
' must be provided by this parameter.
' Metawidth Optional. If the PictureType is vbPicTypeMetafile, the width of the Metafile
' must be provided by this parameter.
' Return_ErrNum Optional. If an error occurs, the error number will be returned here.
' Return_ErrDesc Optional. If an error occurs, the error description will be returned here.
'
' Return:
' -------
' If the function succeeds, the return is TRUE
' If the function fails, the return is FALSE
'
'=============================================================================================================
Private 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
On Error Resume Next
Dim ReturnValue As Long
Dim PicInfo_BMP As PICTDESC_BMP
Dim PicInfo_ICON As PICTDESC_ICON
Dim PicInfo_EMETA As PICTDESC_EMETA
Dim PicInfo_META As PICTDESC_META
Dim ThePicture As StdPicture 'IPicture
Dim rIID As GUID
' Clear the return variables
Return_ErrNum = 0
Return_ErrDesc = ""
' Make sure the variable(s) passed are valid
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
' Set the correct interface identifier GUID for the "OleCreatePictureIndirect" API
With rIID
.Data1 = &H20400
.Data4(0) = &HC0
.Data4(7) = &H46
End With
' Set the appropriate type depending on the type of picture
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
' Check the result
If ReturnValue <> S_OK Then GoTo ErrorTrap
' Return the new picture
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