【Excel VBA】図形をユーザーフォームに表示する方法



Excel VBA 図形をユーザーフォームに表示する




'---Win32API 宣言---
Private Declare PtrSafe Function IsClipboardFormatAvailable Lib "user32.dll" ( _
        ByVal wFormat As Long) As Long
Private Declare PtrSafe Function OpenClipboard Lib "user32.dll" ( _
        ByVal hWnd As Long) As Long
Private Declare PtrSafe Function GetClipboardData Lib "user32.dll" ( _
        ByVal wFormat As Long) As Long
Private Declare PtrSafe Function CloseClipboard Lib "user32.dll" () As Long
Private Declare PtrSafe Function OleCreatePictureIndirect Lib "oleaut32.dll" ( _
        ByRef lpPictDesc As PictDesc, _
        ByRef RefIID As GUID, _
        ByVal fPictureOwnsHandle As Long, _
        ByRef IPic As IPicture) As Long
'---Win32API Types宣言---
Private Type PictDesc
        cbSizeofStruct As Long
        picType        As Long
        hImage         As Long
        Option1        As Long
        Option2        As Long
End Type
Private Type GUID
        Data1          As Long
        Data2          As Integer
        Data3          As Integer
        Data4(7)       As Byte
End Type
'---Win32API Constants定義---
Private Const CF_BITMAP      As Long = 2
Private Const CF_PALETTE     As Long = 9

''' <summary>
''' 図形をImageコントロールに表示する
''' </summary>
''' <param name="con">Imageコントロール</param>
''' <param name="shp">図形</param>
Function SetShapeToImageControl(ByRef con As MSForms.Image, ByRef shp As Shape)
    Dim retryCount As Integer: retryCount = 100
    On Error GoTo CopyRetry
    On Error GoTo 0
    Dim hImg      As Long
    Dim hPalette As Long
    Dim uPictDesc As PictDesc
    Dim uGUID     As GUID
    Call IsClipboardFormatAvailable(CF_BITMAP)
    Call OpenClipboard(0&)
    hImg = GetClipboardData(CF_BITMAP)
    hPalette = GetClipboardData(CF_PALETTE)
    Call CloseClipboard
    If hImg = 0 Then Exit Function
    With uPictDesc
        .cbSizeofStruct = Len(uPictDesc)
        .picType = 1
        .hImage = hImg
        .Option1 = hPalette
    End With
    With uGUID
        .Data1 = &H20400
        .Data4(0) = &HC0
        .Data4(7) = &H46
    End With
    Dim stdPic As StdPicture
    Call OleCreatePictureIndirect(uPictDesc, uGUID, 0&, stdPic)
    Set con.Picture = stdPic
    Exit Function
    retryCount = retryCount - 1
    If retryCount < 1 Then
        On Error GoTo 0
    End If
    Application.Wait [Now()] + 100 / 86400000
End Function



Private Sub UserForm_Initialize()
    Call SetShapeToImageControl(Image1, ActiveSheet.Shapes("Shape1"))
End Sub
PVアクセスランキング にほんブログ村