Excel VBA質問箱 IV

当質問箱は、有志のボランティア精神のおかげで成り立っています。
問題が解決したら、必ずお礼をしましょうね。
本サイトの基本方針をまとめました。こちら をご一読ください。

投稿種別の選択が必要です。ご注意ください。
迷惑投稿防止のため、URLの入力を制限しています。ご了承ください。


35018 / 76738 ←次へ | 前へ→

【46923】Re:画像の貼り付け
回答  りん E-MAIL  - 07/2/21(水) 19:18 -

引用なし
パスワード
   ニッキ さん、こんばんわ。
>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を実行してみてください。

1 hits

【46863】画像の貼り付け ニッキ 07/2/19(月) 12:04 質問
【46866】Re:画像の貼り付け Kein 07/2/19(月) 13:05 発言
【46869】Re:画像の貼り付け ニッキ 07/2/19(月) 13:33 発言
【46871】Re:画像の貼り付け りん 07/2/19(月) 14:11 発言
【46916】Re:画像の貼り付け ニッキ 07/2/21(水) 16:16 お礼
【46922】Re:画像の貼り付け Ned 07/2/21(水) 18:21 発言
【46926】Re:画像の貼り付け ニッキ 07/2/22(木) 9:31 お礼
【46923】Re:画像の貼り付け りん 07/2/21(水) 19:18 回答
【46925】Re:画像の貼り付け ニッキ 07/2/22(木) 9:29 質問
【46928】Re:画像の貼り付け ニッキ 07/2/22(木) 11:11 質問
【46932】Re:画像の貼り付け りん 07/2/22(木) 13:23 回答
【46934】Re:画像の貼り付け ニッキ 07/2/22(木) 13:48 お礼
【46938】Re:画像の貼り付け りん 07/2/22(木) 16:14 発言
【46872】Re:画像の貼り付け Kein 07/2/19(月) 14:30 回答
【46880】Re:画像の貼り付け ニッキ 07/2/19(月) 16:21 質問
【46882】Re:画像の貼り付け Kein 07/2/19(月) 18:12 回答
【46908】Re:画像の貼り付け ニッキ 07/2/21(水) 15:16 質問
【46910】Re:画像の貼り付け Kein 07/2/21(水) 15:57 発言
【46914】Re:画像の貼り付け ニッキ 07/2/21(水) 16:09 お礼

35018 / 76738 ←次へ | 前へ→
ページ:  ┃  記事番号:
2610219
(SS)C-BOARD v3.8 is Free