VERSION 1.0 CLASS
BEGIN
  MultiUse = -1  'True
END
Attribute VB_Name = "CClipPicture"
Attribute VB_Creatable = True
Attribute VB_PredeclaredId = False
Attribute VB_Exposed = False
'CClipPicture
'クリップボードから Picture オブジェクトを作成するクラス(Excel97)

'このテキストファイルをプロジェクトにインポートしてください。
'（Visual Basic Editor [ファイル]-[ファイルのインポート]）
'使用方法は以下のサンプルコードを参照してください。


''UserFormでの使用例
'
''Sheet1 に埋め込みグラフを作成、UserForm にイメージコントロール、
''コマンドボタン2つを作成、以下のコードを作成してください。
'
'Option Explicit
'
''Sheet1の埋め込みグラフをイメージコントロールに表示するプロシージャ
'Private Sub UpdateChartImage(ByVal iXLPictureType As Long)
'    Const CF_BITMAP = 2
'    Const CF_ENHMETAFILE = 14
'    Dim oClipPicture As New CClipPicture
'    Dim oPicture As IPictureDisp
'    Dim iPictureType As Long
'
'    If iXLPictureType = xlBitmap Then
'        iPictureType = CF_BITMAP
'    ElseIf iXLPictureType = xlPicture Then
'        iPictureType = CF_ENHMETAFILE
'    Else
'        Exit Sub
'    End If
'
'    'Sheet1の埋め込みグラフのピクチャをコピー
'    Sheets("Sheet1").ChartObjects(1).Chart.CopyPicture _
'        Appearance:=xlScreen, Size:=xlScreen, Format:=iXLPictureType
'
'    'イメージコントロールにクリップボードのピクチャを割り当てる
'    Set oPicture = oClipPicture.GetClipboardPicture(iPictureType)
'    If oPicture Is Nothing Then
'        MsgBox "エラーが発生しました。", vbExclamation
'    Else
'        Set Me.Image1.Picture = oPicture
'        Set oPicture = Nothing
'    End If
'End Sub
'
''コマンドボタンのイベントプロシージャ(ビットマップを貼り付け)
'Private Sub CommandButton1_Click()
'    UpdateChartImage xlBitmap
'End Sub
'
''コマンドボタンのイベントプロシージャ(メタフィルを貼り付け)
'Private Sub CommandButton2_Click()
'    UpdateChartImage xlPicture
'End Sub


Option Explicit

Private Const CF_BITMAP = 2
Private Const CF_PALETTE = 9
Private Const CF_ENHMETAFILE = 14
Private Const PICTYPE_BITMAP = 1
Private Const PICTYPE_ENHMETAFILE = 4
Private Const IMAGE_BITMAP = 0
Private Const LR_COPYRETURNORG = &H4

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

Private Type PicDescBMP
    Size As Long
    Type As Long
    hBitmap As Long
    hPalette As Long
End Type

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

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 CopyImage Lib "user32" ( _
    ByVal hImage As Long, ByVal uType As Long, _
    ByVal cxDesired As Long, ByVal cyDesired As Long, _
    ByVal fuFlags As Long) As Long

Private Declare Function CreatePalette Lib "gdi32" ( _
    ByRef lpLogPalette As Any) As Long
Private Declare Function GetPaletteEntries Lib "gdi32" ( _
    ByVal hPal As Long, ByVal iStartIndex As Long, _
    ByVal nEntries As Long, ByRef lppe As Any) As Long

Private Declare Function DeleteObject Lib "gdi32" ( _
    ByVal hObject 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 Any, ByRef iid As GUID, _
    ByVal bPictureOwnsHandle As Integer, _
    ByRef IPic As IPictureDisp) As Long

Private hBitmap As Long
Private hPalette As Long
Private hEnhMetafile As Long
Private iPicType As Long
Private iError As Long

'クリップボードからビットマップを取得する関数
Private Function GetClipboardBitmap(ByRef hPalette As Long) As Long
    Dim hBitmap As Long
    Dim hBitmap2 As Long
    Dim lPalette() As Long
    Dim iPalCount As Long
    Dim iRet As Long

    GetClipboardBitmap = 0
    hPalette = 0

    On Error GoTo ErrorHandler

    'クリップボードにビットマップがあるかチェック
    If IsClipboardFormatAvailable(CF_BITMAP) = 0 Then
        Exit Function
    End If

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

    'クリップボードからビットマップハンドルを取得
    hBitmap = GetClipboardData(CF_BITMAP)
    If hBitmap = 0 Then GoTo Exit_Finally

    'ビットマップをコピー
    hBitmap2 = CopyImage(hBitmap, IMAGE_BITMAP, 0, 0, LR_COPYRETURNORG)
    If hBitmap2 = 0 Then GoTo Exit_Finally

    'クリップボードにパレットがあるかチェック
    If IsClipboardFormatAvailable(CF_PALETTE) = 0 Then
        iRet = CloseClipboard()
        If iRet = 0 Then GoTo Exit_Finally
        GetClipboardBitmap = hBitmap2
        Exit Function
    End If

    'クリップボードからパレットハンドルを取得
    hPalette = GetClipboardData(CF_PALETTE)
    If hPalette = 0 Then GoTo Exit_Finally

    'パレットエントリ数を取得
    iPalCount = GetPaletteEntries(hPalette, 0, 0, ByVal 0&)
    iPalCount = iPalCount And &HFFFF&
    If iPalCount = 0 Then GoTo Exit_Finally

    'LOGPALETTE のメモリを確保
    ReDim lPalette(0 To iPalCount)

    'LOGPALETTE のバージョンとエントリ数の設定
    lPalette(0) = &H300& Or (iPalCount * &H10000)

    'LOGPALETTE のパレットエントリの設定
    iRet = GetPaletteEntries(hPalette, 0, iPalCount, lPalette(1))
    If iRet = 0 Then GoTo Exit_Finally

    'パレットの作成
    hPalette = CreatePalette(lPalette(0))
    If hPalette = 0 Then GoTo Exit_Finally

    iRet = CloseClipboard()
    If iRet = 0 Then GoTo Exit_Finally

    'クリップボードのクローズ
    GetClipboardBitmap = hBitmap2
    Exit Function

Exit_Finally:
    If hBitmap2 <> 0 Then
        iRet = DeleteObject(hBitmap2)
        hBitmap2 = 0
    End If
    If hPalette <> 0 Then
        iRet = DeleteObject(hPalette)
        hPalette = 0
    End If
    iRet = CloseClipboard()
    Exit Function

ErrorHandler:
    If hBitmap2 <> 0 Then
        iRet = DeleteObject(hBitmap2)
        hBitmap2 = 0
    End If
    If hPalette <> 0 Then
        iRet = DeleteObject(hPalette)
        hPalette = 0
    End If
    iRet = CloseClipboard()
    Exit Function

End Function


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

    GetClipboardEnhMetaFile = 0

    On Error GoTo ErrorHandler

    'クリップボードに拡張メタファイルがあるかチェック
    If IsClipboardFormatAvailable(CF_ENHMETAFILE) = 0 Then
        Exit Function
    End If

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

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

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

    'クリップボードのクローズ
    iRet = CloseClipboard()
    If iRet = 0 Then
        Exit Function
    End If

    GetClipboardEnhMetaFile = hemf2
    Exit Function

ErrorHandler:
    iRet = CloseClipboard()
    Exit Function

End Function


'クリップボードからPictureオブジェクトを作成する関数
Public Function GetClipboardPicture(ByVal iPictureType As Long) As IPictureDisp
    Dim iid As GUID
    Dim utPicDescBMP As PicDescBMP
    Dim utPicDescEMF As PicDescEMF
    Dim oPicture As IPictureDisp
    Dim iRet As Long

    iError = -1
    hBitmap = 0
    hPalette = 0
    hEnhMetafile = 0
    iPicType = iPictureType

    On Error GoTo ErrorHandler

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

    If iPictureType = CF_BITMAP Then

        hBitmap = GetClipboardBitmap(hPalette)
        If hBitmap = 0 Then
            iError = 1
            Exit Function
        End If

        With utPicDescBMP
            .Size = Len(utPicDescBMP)
            .Type = PICTYPE_BITMAP
            .hBitmap = hBitmap
            .hPalette = hPalette
        End With

        iRet = OleCreatePictureIndirect(utPicDescBMP, iid, 1, oPicture)
        If iRet <> 0 Then
            iError = 2
            GoTo Exit_Finally
        End If

        Set GetClipboardPicture = oPicture

    ElseIf iPictureType = CF_ENHMETAFILE Then

        hEnhMetafile = GetClipboardEnhMetaFile()
        If hEnhMetafile = 0 Then
            iError = 1
            Exit Function
        End If

        With utPicDescEMF
            .Size = Len(utPicDescEMF)
            .Type = PICTYPE_ENHMETAFILE
            .hMetaFile = hEnhMetafile
        End With

        iRet = OleCreatePictureIndirect(utPicDescEMF, iid, 1, oPicture)
        If iRet <> 0 Then
            iError = 2
            GoTo Exit_Finally
        End If

        Set GetClipboardPicture = oPicture

    Else
        iError = 3
        Exit Function
    End If

    Exit Function

Exit_Finally:
    If hBitmap <> 0 Then
        iRet = DeleteObject(hBitmap)
        hBitmap = 0
    End If
    If hPalette <> 0 Then
        iRet = DeleteObject(hPalette)
        hPalette = 0
    End If
    If hEnhMetafile <> 0 Then
        iRet = DeleteEnhMetaFile(hEnhMetafile)
        hEnhMetafile = 0
    End If
    Set oPicture = Nothing
    Exit Function

ErrorHandler:
    If hBitmap <> 0 Then
        iRet = DeleteObject(hBitmap)
        hBitmap = 0
    End If
    If hPalette <> 0 Then
        iRet = DeleteObject(hPalette)
        hPalette = 0
    End If
    If hEnhMetafile <> 0 Then
        iRet = DeleteEnhMetaFile(hEnhMetafile)
        hEnhMetafile = 0
    End If
    Set oPicture = Nothing
End Function


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