| |
ニッキ さん、こんばんわ。
>h t t p://www.keep-on.com/excelyou/2003lng4/200310/03100204.txt
↑ここのコードを、
フォームを表示したときに、
シート上にPictureがあれば画像を表示する
という動作をするように少し変えてみました
（準備）
挿入→ユーザーフォーム でフォーム（UserForm1）を追加
そのフォームに、イメージコントロール(Image1)をのせる
UserForm1のコードを表示し、以下を記述
'↓UserFormここから/////////////////////////////////////////////
'' クリップボード 関連 API ---------------------------------------------------
'' 開く、種類の取得、データの取得、閉じる。>NT3.1, Win95
Private Const CF_ENHMETAFILE = 14
Private Declare Function IsClipboardFormatAvailable Lib "user32.dll" (ByVal wFormat As Long) As Long
Private Declare Function OpenClipboard Lib "user32.dll" (ByVal hwnd As Long) As Long
Private Declare Function GetClipboardData Lib "user32.dll" (ByVal wFormat As Long) As Long
Private Declare Function CloseClipboard Lib "user32.dll" () As Long
'' ハンドルから、ピクチャを取得する。
'OleCreatePictureIndirectに渡すための構造体。
'本来は共用体です。（別にLongの配列を使ってもかまいません。）
Private Const vbPicTypeBitmap = 1
Private Const vbPicTypeIcon = 3
Private Const vbPicTypeEMetafile = 4
Private Type TPICTDESC
cbSizeofStruct As Long 'この構造体のサイズです。
picType As Long 'ピクチャーのタイプを指定。vbPicType
hImage As Long 'イメージのハンドル。
Option1 As Long 'ビットマップの場合は、パレットのハンドル。'メタファイルの場合は、幅。
Option2 As Long 'メタファイルの場合は、高さ。
End Type
'GUIDを格納するための構造体。128bitの値を宣言するのならば、何でもいいかもしれない。
Private Type TGUID
Data1 As Long
Data2 As Integer
Data3 As Integer
Data4(1 To 8) As Byte
End Type
'ピクチャーオブジェクトを作る（？）関数。
Private Declare Function OleCreatePictureIndirect Lib "olepro32.dll" _
(lpPictDesc As TPICTDESC, _
RefIID As TGUID, _
ByVal fPictureOwnsHandle As Long, _
ByRef IPic As IPicture) As Long
Public Function Clipboard_GetMetafile() As StdPicture
Dim hEmf As Long
Dim TPICTDESC As TPICTDESC
Dim TGUID As TGUID
Set Clipboard_GetMetafile = Nothing
If IsClipboardFormatAvailable(CF_ENHMETAFILE) = False Then Exit Function
If OpenClipboard(CLng(0)) = False Then Exit Function
hEmf = GetClipboardData(CF_ENHMETAFILE)
Call CloseClipboard
If hEmf = 0 Then Exit Function
With TPICTDESC
.cbSizeofStruct = Len(TPICTDESC)
.picType = vbPicTypeEMetafile
.hImage = hEmf
End With
With TGUID
.Data1 = &H20400
.Data4(1) = &HC0
.Data4(8) = &H46
End With
Call OleCreatePictureIndirect(TPICTDESC, TGUID, True, Clipboard_GetMetafile)
End Function
Private Sub UserForm_Activate()
'アクティブなシートの一つ目のピクチャ
With Application.ActiveSheet
If .Pictures.Count = 0 Then
Me.Caption = .Name & "上にPictureはありませんでした"
Else
.Pictures(1).Copy
Me.Caption = .Name & "上の" & .Pictures(1).Name
'イメージコントロールに割付
Me.Image1.Visible = False
Me.Image1.Picture = Clipboard_GetMetafile()
Me.Image1.Visible = True
End If
End With
End Sub
'↑UserFormここまで/////////////////////////////////////////////
挿入→標準モジュール(Module1)を追加
標準モジュールに以下を記述
'↓Moduleここから/////////////////////////////////////////////
Sub main()
UserForm1.Show
End Sub
'↑Moduleここまで/////////////////////////////////////////////
こんな感じです
Pictureのあるシートを表示して、Mainを実行してみてください。
|
|
![[未読]](./data/excel/image/read_icon.gif){kind=icon}
- 07/2/19(月) 14:11 -
