'図のコピーをコントロールに貼り付けるマクロ(Excel97)

'このマクロでは CClipPicture クラスを使用します。

'ワークシートでオブジェクトを選択し、Visual Basic Editorで
'Imageコントロールを選択して実行してください。

Option Explicit

Private Const sAppName As String = "図のコピーをコントロールに貼り付け"

Sub PastePictureToControl()
    Const CF_BITMAP = 2
    Const CF_ENHMETAFILE = 14
    Dim oClipPicture As New CClipPicture
    Dim oPicture As IPictureDisp
    Dim iXLPictureType As Long
    Dim iPictureType As Long
    Dim ifCopy As Long
    Dim oControl As Object
    Dim oRet As Object
    Dim bFlag As Boolean
    Dim iRet As Long

    bFlag = False
    On Error Resume Next
    With Application.VBE.SelectedVBComponent
        Set oControl = .Designer.Selected.Item(0)
        If Err = 0 Then
            Set oRet = oControl.Picture
            bFlag = (Err = 0)
        Else
            On Error GoTo 0
            On Error Resume Next
            Set oControl = .Designer
            If Err = 0 Then
                Set oRet = oControl.Picture
                bFlag = (Err = 0)
            End If
        End If
    End With

    On Error GoTo 0
    If Not bFlag Then
        MsgBox "コントロールが選択されていません。", _
            vbExclamation, sAppName
        Exit Sub
    End If

    ifCopy = MsgBox("選択オブジェクトの画像をコピーしますか？", _
        vbExclamation Or vbYesNoCancel, sAppName)
    If ifCopy = vbCancel Then Exit Sub

    iRet = MsgBox("ビットマップを貼り付ける場合は[はい]、" & _
        "ピクチャの場合は[いいえ]を選択してください。", _
        vbQuestion Or vbYesNoCancel, sAppName)
    If iRet = vbCancel Then Exit Sub
    If iRet = vbYes Then
        iXLPictureType = xlBitmap
        iPictureType = CF_BITMAP
    Else
        iXLPictureType = xlPicture
        iPictureType = CF_ENHMETAFILE
    End If

    If ifCopy = vbYes Then

        '選択オブジェクトをコピー
        On Error GoTo ErrorHandler_1
        If ActiveChart Is Nothing Then
            Selection.CopyPicture Appearance:=xlScreen, _
                Format:=iXLPictureType
        Else
            ActiveChart.CopyPicture Appearance:=xlScreen, _
                Size:=xlScreen, Format:=iXLPictureType
        End If
    End If

    'コントロールにクリップボードのピクチャを割り当てる
    On Error GoTo ErrorHandler_2
    Set oPicture = oClipPicture.GetClipboardPicture(iPictureType)
    If oPicture Is Nothing Then
        Select Case oClipPicture.ErrorCode
            Case 1
                MsgBox _
                    "クリップボードのピクチャの取得でエラーが発生しました。", _
                    vbExclamation, sAppName
            Case 2
                MsgBox "オブジェクトの作成でエラーが発生しました。", _
                    vbExclamation, sAppName
            Case Else
                MsgBox "エラーが発生しました。", vbExclamation, sAppName
        End Select
    Else
         Set oControl.Picture = oPicture
         Set oPicture = Nothing
    End If

    Exit Sub

ErrorHandler_1:
    MsgBox "図のコピーでエラーが発生しました。", _
        vbExclamation, sAppName
    Exit Sub

ErrorHandler_2:
    MsgBox "エラーが発生しました。", vbExclamation, sAppName
    Exit Sub
End Sub