VERSION 1.0 CLASS
BEGIN
  MultiUse = -1  'True
END
Attribute VB_Name = "CClipMeta"
Attribute VB_Creatable = True
Attribute VB_PredeclaredId = False
Attribute VB_Exposed = False
'クリップボードの拡張メタファイルから
'Imageコントロール用のオブジェクトを作成するクラス(Excel97)

'このテキストファイルをプロジェクトにインポートしてください。
'（Visual Basic Editor [ファイル]-[ファイルのインポート]）


''UserFormでの使用例
'
''コマンドボタンのイベントプロシージャ
'Private Sub CommandButton1_Click()
'    Dim oClipMeta As New CClipMeta
'    Dim oPic As IPictureDisp
'
'    'Sheet1の埋め込みグラフをコピー
'    Sheets("Sheet1").ChartObjects(1).Chart.CopyPicture _
'        Appearance:=xlScreen, Size:=xlScreen, Format:=xlPicture
'
'    'イメージコントロールにクリップボードのピクチャを割り当てる
'    Set oPic = oClipMeta.GetClipEnhMeta()
'    If oPic Is Nothing Then
'        MsgBox "エラーが発生しました。", vbExclamation
'    Else
'        Set Me.Image1.Picture = oPic
'        Set oPic = Nothing
'    End If
'End Sub


Option Explicit

Private Type GUID
    Data1 As Long
    Data2 As Integer
    Data3 As Integer
    Data4(0 To 7) As Byte
End Type

Private Type PicDescEMF
    Size As Long
    Type As Long
    hMetaFile As Long
    xExt As Long
    yExt As Long
End Type

Private Const CF_ENHMETAFILE As Long = 14
Private Const PICTYPE_ENHMETAFILE As Long = 4

Private Declare Function IsClipboardFormatAvailable Lib "user32" ( _
    ByVal wFormat As Long) As Long
Private Declare Function OpenClipboard Lib "user32" ( _
    ByVal hWnd As Long) As Long
Private Declare Function CloseClipboard Lib "user32" () As Long
Private Declare Function GetClipboardData Lib "user32" ( _
    ByVal wFormat As Long) As Long

Private Declare Function CopyEnhMetaFile Lib "gdi32" Alias "CopyEnhMetaFileA" ( _
    ByVal hmf As Long, ByVal lpFileName As Long) As Long
Private Declare Function DeleteEnhMetaFile Lib "gdi32" ( _
    ByVal hmf As Long) As Long
Private Declare Function OleCreatePictureIndirect Lib "olepro32.dll" ( _
    ByRef picdesc As PicDescEMF, ByRef iid As GUID, _
    ByVal bPictureOwnsHandle As Integer, _
    ByRef IPic As IPictureDisp) As Long

Private hmf As Long
Private iError As Long


'クリップボードから拡張メタファイルを取得する関数
Private Function GetClipboardEnhMetaFile() As Long
    Dim hmf As Long, hmf2 As Long, iRet As Long

    On Error GoTo ErrorHandler

    GetClipboardEnhMetaFile = 0

    '拡張メタファイルかチェック
    If IsClipboardFormatAvailable(CF_ENHMETAFILE) = 0 Then Exit Function

    'クリップボードのオープン
    If OpenClipboard(0) = 0 Then Exit Function

    'クリップボードの拡張メタファイルのハンドルを取得
    hmf = GetClipboardData(CF_ENHMETAFILE)
    If hmf = 0 Then
        iRet = CloseClipboard()
        Exit Function
    End If

    'クリップボードの拡張メタファイルをコピー
    hmf2 = CopyEnhMetaFile(hmf, 0&)
     If hmf2 = 0 Then
        iRet = CloseClipboard()
        Exit Function
    End If

    'クリップボードのクローズ
    iRet = CloseClipboard()

    GetClipboardEnhMetaFile = hmf2
    Exit Function

ErrorHandler:
    iRet = CloseClipboard()
End Function

'Imageコントロール用の拡張メタファイルを作成する関数
Private Function CreateOlePictureEMF(hmf As Long) As IPictureDisp
    Dim pic As IPictureDisp
    Dim picdesc As PicDescEMF
    Dim iid As GUID
    Dim iRet As Long

    On Error GoTo ErrorHandler

    'IDispatch Interface ID
    With iid
        .Data1 = &H20400
        .Data4(0) = &HC0
        .Data4(7) = &H46
    End With

    With picdesc
        .Size = Len(picdesc)
        .Type = PICTYPE_ENHMETAFILE
        .hMetaFile = hmf
    End With

    'Pictureオブジェクトの作成
    iRet = OleCreatePictureIndirect(picdesc, iid, 1, pic)
    If iRet <> 0 Then Exit Function
    Set CreateOlePictureEMF = pic

    Exit Function

ErrorHandler:

End Function

'クリップボードの拡張メタファイルから
'Imageコントロール用のオブジェクトを作成する関数
Public Function GetClipEnhMeta() As IPictureDisp
    Dim pic As IPictureDisp

    On Error GoTo ErrorHandler

    iError = -1

    hmf = 0
    hmf = GetClipboardEnhMetaFile()
    If hmf = 0 Then
        iError = 1
    Else
        Set pic = CreateOlePictureEMF(hmf)
        If pic Is Nothing Then
            DeleteEnhMetaFile hmf
            hmf = 0
            iError = 2
        Else
            Set GetClipEnhMeta = pic
            Set pic = Nothing
            iError = 0
        End If
    End If

    Exit Function

ErrorHandler:
    If hmf <> 0 Then
        DeleteEnhMetaFile hmf
        hmf = 0
    End If
    Set pic = Nothing
End Function


'エラー情報を返すプロパティ
Public Property Get ErrorCode() As Long
    ErrorCode = iError
End Property