Excelで作成した図形を、ユーザーフォーム上で表示する方法について説明していきます。
図形をユーザーフォーム上に表示するメソッド
「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
