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

スポンサーリンク

Excelで作成した図形を、ユーザーフォーム上で表示する方法について説明していきます。

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

図形をユーザーフォーム上に表示するメソッド

「Imageコントロール」上にExcelの図形を表示するコードです。適当なモジュールかクラスに張り付けてから使用してください。

以下のコードでは図形をクリップボードにコピー後、Win32APIを使って「Imageコントロール」上で扱える形式に変換した状態でセットすることで表示しています。

'---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
    shp.Copy
    On Error GoTo 0
    'クリップボード内の図形をImageコントロールにセット
    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
CopyRetry:
    '一定時間待機後、図形コピーをリトライする
    retryCount = retryCount - 1
    If retryCount < 1 Then
        On Error GoTo 0
    End If
    Application.Wait [Now()] + 100 / 86400000
    DoEvents
    Resume
End Function

サンプルコード

「図形をユーザーフォーム上に表示するメソッド」を利用してアクティブシートの「Shape1」を、ユーザーフォーム上の「Imageコントロール(Image1)」に表示しています。

Private Sub UserForm_Initialize()
    Call SetShapeToImageControl(Image1, ActiveSheet.Shapes("Shape1"))
End Sub
ブログランキング
PVアクセスランキング にほんブログ村
タイトルとURLをコピーしました