Excel VBA質問箱 IV

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

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


6145 / 13644 ツリー ←次へ | 前へ→

【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 お礼[未読]

【46863】画像の貼り付け
質問  ニッキ  - 07/2/19(月) 12:04 -

引用なし
パスワード
   簡単なのかも知れませんが、教えて下さい。
画像をファイルからフォームに読み込む「LoadPicture(””)」のは解っているのですが、シート上にある画像をフォームを開いたとき再表示するには、どのようにしたらよいのでしょうか?
宜しくお願い致します。

【46866】Re:画像の貼り付け
発言  Kein  - 07/2/19(月) 13:05 -

引用なし
パスワード
   >シート上にある画像
も、普通はどこかに保存されている画像ファイルを挿入したものなのだから、
その元のファイルのフルパスを LoadPicture の引数に渡ことで、表示できる
はずですが・・。
>フォームを開いたとき
のイベントなら Private Sub UserForm_Activate() というタイトルにします。

【46869】Re:画像の貼り付け
発言  ニッキ  - 07/2/19(月) 13:33 -

引用なし
パスワード
   ▼Kein さん:

回答有難うございます。

説明不足ですみません。
他の方がシート上に作成した図形をフォーム上に再表示するということで、
自分の手元には、ファイルがないのです。

このような場合、フォーム上に表示できるのでしょうか?

【46871】Re:画像の貼り付け
発言  りん E-MAIL  - 07/2/19(月) 14:11 -

引用なし
パスワード
   ニッキ さん、こんにちわ。

>説明不足ですみません。
>他の方がシート上に作成した図形をフォーム上に再表示するということで、
>自分の手元には、ファイルがないのです。
>
>このような場合、フォーム上に表示できるのでしょうか?

Googleで検索かけたら出てきたのが、よそのサイトの過去ログでしたが。
h t t p://www.keep-on.com/excelyou/2003lng4/200310/03100204.txt 

フォーム上のイメージコントロールをクリックすると、ファイルから画像を読み込んでコピーし、クリップボードからフォームに送る例が出ていました。

With TGUID から下を以下のように変更してみてください。

<<略>>
  With TGUID
    .Data1 = &H20400
    .Data4(1) = &HC0
    .Data4(8) = &H46
  End With
  Call OleCreatePictureIndirect(TPICTDESC, TGUID, True, Clipboard_GetMetafile)
End Function

Private Sub Image1_Click()
  'アクティブなシートの一つ目のピクチャ
  Application.ActiveSheet.Pictures(1).Copy
  'イメージコントロールに割付
  Image1.Visible = False
  Image1.Picture = Clipboard_GetMetafile()
  Image1.Visible = True
End Sub

【46872】Re:画像の貼り付け
回答  Kein  - 07/2/19(月) 14:30 -

引用なし
パスワード
   Pasteメソッドの対象オブジェクトに、UserFormやFrameがあったので
こちらでテストしてみましたが、どうしてもCanPasteプロパティがFalse
を返してしまって成功しませんでした(Excel2000)。
なのでExcel95以前に、現在のユーザーフォームの代用として存在していた
ダイアログシートを使ってやってみたところ、コピーした図形や画像を問題なく表示
することが出来ました。
ダイアログシートの出し方ですが、ワークシートタブを右クリックし、「挿入」から「MS Excel5.0 ダイアログ」を選択するだけです。すると"OK"と"キャンセル"ボタン
が配置された "ダイアログフレーム" が一つ見つかるはずですから、マウスドラッグで
思い切り大きさを拡大します。ついでにタイトルバーにカーソルを合わせ、適当な
タイトル文字列に変更します。それからメニューの「書式」「シート」「表示しない」
を選んで非表示にしておき、図形や画像が挿入されているシートに戻り、任意の
オブジェクトを一つ選択してから以下のマクロを実行してください。

Sub Ap_Obj_Dialog()
  Dim Lp As Single, Tp As Single
  Dim Wp As Single, Hp As Single
 
  If VarType(Selection) <> vbObject Then Exit Sub
  With DialogSheets(1)
   If .DrawingObjects.Count > 0 Then
     .DrawingObjects.Delete
   End If
   With .DialogFrame
     Lp = .Left + 5: Tp = .Top + 10
     Wp = .Width - 10: Hp = .Height - 15
   End With
   Selection.Copy
   .Paste
   With .DrawingObjects(1)
     .Left = Lp: .Top = Tp
     .Width = Wp: .Height = Hp
   End With
   .Show
  End With
  Application.CutCopyMode = False
End Sub

ここで
>DialogFrame
というのがユーザーフォームの外枠に該当します。その形はDialogSheet上で
自由に変形できるため、Lp,Tp,Wp,Hp の各変数に入れる値は、マクロを実行
して実際に表示された状態から判断して調節(何ポイント + するか)して下さい。

【46880】Re:画像の貼り付け
質問  ニッキ  - 07/2/19(月) 16:21 -

引用なし
パスワード
   ▼Kein さん:

なかなか理解できず、申し訳ございません。

例えば、sheet1 に図形1、図形2、図形3をそれぞれ別の人が書き込んだ場合
UserFormを開いたとき、あらかじめ作ってあった image1、image2、image3に
表示したいということなのですが、何度も説明が足らずお手間をかけ申し訳ございません。

宜しくお願い致します。

【46882】Re:画像の貼り付け
回答  Kein  - 07/2/19(月) 18:12 -

引用なし
パスワード
   UserFormに拘るなら、他の人のレスを待って下さい。
先に書いたダイアログシート方式なら、アクティブシートに4つの画像が
挿入されているとして・・

Sub Ap_Obj_Dialog()
  Dim Lp1 As Single, Tp1 As Single
  Dim Lp2 As Single, Tp2 As Single
  Dim Wp As Single, Hp As Single
  Dim i As Integer
 
  With ActiveSheet
   If .Pictures.Count < 4 Then Exit Sub
  End With
  With DialogSheets(1)
   If .DrawingObjects.Count > 0 Then
     .DrawingObjects.Delete
   End If
   With .DialogFrame
     Lp1 = .Left + 5: Tp1 = .Top + 15
     Lp2 = .Left + (.Width / 2 + 5)
     Tp2 = .Top + (.Height - 25) / 2 + 20
     Wp = .Width / 2 - 20: Hp = (.Height - 25) / 2
   End With
   For i = 1 To 4
     ActiveSheet.Pictures(i).Copy
     .Paste
     Application.CutCopyMode = False
   Next i
   With .Pictures
     With .Item(1)
       .Left = Lp1: .Top = Tp1
       .Width = Wp: .Height = Hp
     End With
     With .Item(2)
       .Left = Lp2: .Top = Tp1
       .Width = Wp: .Height = Hp
     End With
     With .Item(3)
       .Left = Lp1: .Top = Tp2
       .Width = Wp: .Height = Hp
     End With
     With .Item(4)
       .Left = Lp2: .Top = Tp2
       .Width = Wp: .Height = Hp
     End With
   End With
   .Show
  End With
End Sub

というコードで出来ます。
こちらでテストした環境で、うまく配置できてました。

【46908】Re:画像の貼り付け
質問  ニッキ  - 07/2/21(水) 15:16 -

引用なし
パスワード
   ▼Kein さん:

お教え下さったダイアログでの表示はうまくできましたが、できれば UserFormを使って
予め用意しておいたimage1,image2・・・・といった所定の場所に表示したいのです。
図1番目はimage1へ
図2番目はimage2へ
図3番目はimage3へ
  ・
  ・
  ・
のように!
お願い致します。

【46910】Re:画像の貼り付け
発言  Kein  - 07/2/21(水) 15:57 -

引用なし
パスワード
   それなら、りんさんの 07/2/19(月) 14:11 の回答を試してみたら
どうでしょーか ? (少なくとも回答をもらったら、お礼ぐらいするべきです)

【46914】Re:画像の貼り付け
お礼  ニッキ  - 07/2/21(水) 16:09 -

引用なし
パスワード
   ▼Kein さん:
大変申し訳ございませんでした。

【46916】Re:画像の貼り付け
お礼  ニッキ  - 07/2/21(水) 16:16 -

引用なし
パスワード
   ▼りん さん:
せっかく教えていただいたのですが、
h t t p://www.keep-on.com/excelyou/2003lng4/200310/03100204.txt 
のサイトをみて見ましたが私には全く理解できません。
もう少し初心者でもわかるような簡単なものはないでしょうか?
ご返事、遅くなって申し訳ありませんでした。

【46922】Re:画像の貼り付け
発言  Ned  - 07/2/21(水) 18:21 -

引用なし
パスワード
   ▼ニッキ さん:
こんにちは。&横から失礼します^ ^
>もう少し初心者でもわかるような簡単なもの
...かどうかはわかりませんが

1)ChartObjectsを一時的に追加してそこにコピー。
2)ChartのExportメソッドでjpgファイルを作成。
3)そのファイルをLoadPictureで読み込む。
...というのを見た事があります。

Private Sub UserForm_Click()
  Dim sp  As Shape
  Dim fName As String
  
  fName = ThisWorkbook.Path & "\tmpshp.jpg"
  With Sheets("sheet1")
    Set sp = .Shapes(1)
    With .ChartObjects.Add(, , sp.Width + 5, sp.Height + 5)
      .Chart.ChartArea.Border.LineStyle = 0
      sp.Copy
      .Chart.Paste
      .Chart.Export Filename:=fName, Filtername:="jpg"
      .Delete
    End With
  End With
  Me.Image1.Picture = LoadPicture(fName)
  Set sp = Nothing
End Sub

...な感じ。
『jpgファイルを作成』して良ければの話ですが。

【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を実行してみてください。

【46925】Re:画像の貼り付け
質問  ニッキ  - 07/2/22(木) 9:29 -

引用なし
パスワード
   ▼りん さん:
お蔭様で表示することができましたが、例えばシート上に図を3個貼り付けたとき
フォームを開くと確かに3個の表示がされるのですが、フォームを1回閉じて
再度、開くと1個目のみしか表示されません。
又、その状態で4個目の図を貼り付けてフォームを開くと今度は1個目と4個目が
表示されます。
修正方法を宜しくお願い致します。

【46926】Re:画像の貼り付け
お礼  ニッキ  - 07/2/22(木) 9:31 -

引用なし
パスワード
   ▼Ned さん:
アドバイス ありがとうございます、
いろいろ 試してみます。

【46928】Re:画像の貼り付け
質問  ニッキ  - 07/2/22(木) 11:11 -

引用なし
パスワード
   ▼りん さん:
お手間をお掛けして申し訳ございません。
先ほど投稿した件、一部間違っておりました。
最後の図のみ表示されます。
 コードは以下の通り


Private Sub UserForm_Activate()
Dim x As Integer

On Error Resume Next

  'アクティブなシートの一つ目のピクチャ
  With Application.ActiveSheet
   If .Pictures.Count = 0 Then
     Me.Caption = .Name & "上にPictureはありませんでした"
   Else
     For x = 1 To 15
      If .Pictures.Count < x Then
       GoTo step1
      Else
       .Pictures(x).Copy
       Me.Caption = .Name & "上の" & .Pictures(x).Name
       'イメージコントロールに割付
       UserForm2("Image" & x).Visible = False
       UserForm2("Image" & x).Picture = Clipboard_GetMetafile()
       UserForm2("Image" & x).Visible = True
      End If
     Next x
step1:
   End If
  End With
End Sub

宜しくお願い致します。

【46932】Re:画像の貼り付け
回答  りん E-MAIL  - 07/2/22(木) 13:23 -

引用なし
パスワード
   ニッキ さん、こんにちわ。
>お手間をお掛けして申し訳ございません。
>先ほど投稿した件、一部間違っておりました。
>最後の図のみ表示されます。

>Private Sub UserForm_Activate()
>Dim x As Integer

画像を最大15個読むんですか?
>       'イメージコントロールに割付
>       UserForm2("Image" & x).Visible = False
>       UserForm2("Image" & x).Picture = Clipboard_GetMetafile()
>       UserForm2("Image" & x).Visible = True

      DoEvents 'これを追加

>      End If
>     Next x
>step1:
>   End If
>  End With
>End Sub

3個読む例はこんな風にしてみたのですが。
Private Sub UserForm_Activate()
  Dim a As String, II As Integer
  'アクティブなシートの一つ目のピクチャ
  With Application.ActiveSheet
   If .Pictures.Count = 0 Then
     Me.Caption = .Name & "上にPictureはありませんでした"
   Else
     a = .Name & "上の "
     For Each obj In .Pictures
      II = II + 1
      .Pictures(II).Copy
      a = a & .Pictures(II).Name & " "
      'イメージコントロールに割付
      With Me.Controls("Image" & II)
        .Visible = False
        .Picture = Clipboard_GetMetafile()
        .Visible = True
      End With
      '
      DoEvents
      '
      If II = 3 Then Exit For '最大3個
     Next
     Me.Caption = a
   End If
  End With
End Sub

【46934】Re:画像の貼り付け
お礼  ニッキ  - 07/2/22(木) 13:48 -

引用なし
パスワード
   ▼りん さん:
バッチリうまく表示できました。
ありがとうございます。

ついでと言う訳ではありませんが、もう一つ関連で教えていただきたいものがあります。表示した3個の図のうち、例えば d:\図1.gif と一致するものがあるか調べることはできますでしょうか?
他の投稿「図形の照合」で回答を頂いたのですが、未熟のため解りませんでした。
もし、よろしければご指導をお願い致します。

【46938】Re:画像の貼り付け
発言  りん E-MAIL  - 07/2/22(木) 16:14 -

引用なし
パスワード
   ニッキ さん、こんにちわ。

>ついでと言う訳ではありませんが、もう一つ関連で教えていただきたいものがあります。表示した3個の図のうち、例えば d:\図1.gif と一致するものがあるか調べることはできますでしょうか?
Googleで探してみたところ、ichinoseさんのおっしゃるように、BMPファイルを作成して比較する方法があるらしいです。

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