Excel VBA質問箱 IV

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

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


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

【39845】UserFormへの画像の張り付け方 わいわい 06/7/2(日) 22:18 質問[未読]
【39846】Re:UserFormへの画像の張り付け方 bykin 06/7/2(日) 23:11 回答[未読]
【39862】Re:UserFormへの画像の張り付け方 わいわい 06/7/3(月) 13:14 質問[未読]
【39874】Re:UserFormへの画像の張り付け方 Kein 06/7/3(月) 14:53 回答[未読]
【39890】Re:UserFormへの画像の張り付け方 わいわい 06/7/3(月) 18:15 質問[未読]
【39997】Re:UserFormへの画像の張り付け方 ichinose 06/7/5(水) 8:48 発言[未読]
【40137】Re:UserFormへの画像の張り付け方 わいわい 06/7/7(金) 13:48 お礼[未読]
【40371】Re:UserFormへの画像の張り付け方 ichinose 06/7/12(水) 17:45 発言[未読]
【40411】Re:UserFormへの画像の張り付け方 わいわい 06/7/13(木) 13:31 お礼[未読]

【39845】UserFormへの画像の張り付け方
質問  わいわい  - 06/7/2(日) 22:18 -

引用なし
パスワード
   いつもお世話になります。
いま、Sheet1のSelectionChangeイベントでUserFormの画像を切り替えるマクロを作っています。画像ファイルを外部に置いておく方法は、以下のように出来たのですが、Excelファイルのシート上にObjectとして配置したものを呼び出す方法が分かりません。どなたか回答宜しくお願いいたします。

Private Sub Worksheet_SelectionChange(ByVal Target As Range)
  With Target
    TR = .Row
    TC = .Column
    TT = .Top
    TL = .Left
  End With
  m = Cells(TR, 1).Value
  If m = 11 Or m = 12 Or m = 13 Then
    UserForm1.Image1.Picture = LoadPicture("C:\000" & m & ".JPG")
  Else
    UserForm1.Image1.Picture = LoadPicture("C:\00000.JPG")
  End If

End Sub
     <UserForm1>
┏━━━━━━━━━━━━━┓
┃┌−−−−−−−−−−−┐┃
┃|           |┃
┃|           |┃
┃|    Picture    |┃
┃|           |┃
┃└−−−−−−−−−−−┘┃
┃        ┌−−−┐┃
┃        └−−−┘┃
┗━━━━━━━━━━━━━┛

>>  Worksheets("Sheet2").Shapes("Object 1")の指定方が分かりません。

【39846】Re:UserFormへの画像の張り付け方
回答  bykin  - 06/7/2(日) 23:11 -

引用なし
パスワード
   こんばんわ。

ワークシートでもイメージコントロールを使ったら簡単なんやないかな?

1.コントロールツールボックスツールバーからイメージを4個
  Sheet2に貼り付ける。

2.プロパティウィンドウを開いて、各イメージコントロールの・・・
  Name→Image00・Image11〜Image13
  Picture→画像を指定

3.Sheet1のコードを変更する。

Private Sub Worksheet_SelectionChange(ByVal Target As Range)
  Dim m As Variant
  
  m = Target.EntireRow.Cells(1).Value
  Select Case m
    Case 11, 12, 13
      UserForm1.Image1.Picture = Worksheets("Sheet2").OLEObjects("Image" & m).Object.Picture
    Case Else
      UserForm1.Image1.Picture = Worksheets("Sheet2").Image00.Picture
  End Select
End Sub

・・・なんてのでどうでっか?

試してみてな。
ほな。

【39862】Re:UserFormへの画像の張り付け方
質問  わいわい  - 06/7/3(月) 13:14 -

引用なし
パスワード
   bykin 様

回答ありがとうございます。
お教え頂いた方法でシート上の画像を元に、UserForm1のPictureを変更することが出来ました。・・・がファイル容量がすごいことになってしまいました。
今回画像を最大90枚使用する予定なのですが、お教え頂いた方法だと、8MByteクラスのファイルになってしまいます。画像直貼りだと2.8MByteです。OLEObjectsにすることで膨れてしまうようです。これから画像枚数を減らしたり、画像サイズを縮小するなど調整するにしても厳しそうです。
他のやりかたご存知の方いらしたら、宜しくお願い致します。

>こんばんわ。
>
>ワークシートでもイメージコントロールを使ったら簡単なんやないかな?
>
>1.コントロールツールボックスツールバーからイメージを4個
>  Sheet2に貼り付ける。
>
>2.プロパティウィンドウを開いて、各イメージコントロールの・・・
>  Name→Image00・Image11〜Image13
>  Picture→画像を指定
>
>3.Sheet1のコードを変更する。
>
>Private Sub Worksheet_SelectionChange(ByVal Target As Range)
>  Dim m As Variant
>  
>  m = Target.EntireRow.Cells(1).Value
>  Select Case m
>    Case 11, 12, 13
>      UserForm1.Image1.Picture = Worksheets("Sheet2").OLEObjects("Image" & m).Object.Picture
>    Case Else
>      UserForm1.Image1.Picture = Worksheets("Sheet2").Image00.Picture
>  End Select
>End Sub
>
>・・・なんてのでどうでっか?
>
>試してみてな。
>ほな。

【39874】Re:UserFormへの画像の張り付け方
回答  Kein  - 06/7/3(月) 14:53 -

引用なし
パスワード
   シート上に配置した任意の画像ファイルをクリックすると、
ユーザーフォームを出してImageコントロールに画像を表示するマクロです。
Ap_Picを実行し、配置したい複数のファイルを、出てきたダイアログ上で
Ctrlキーを押しながら選択して下さい。
アクティブシート上で"15行×7列分"のサイズにして、縦に順番に並べていきます。

Sub Ap_Pic()
  Dim i As Long
  Dim Tp As Single, Wp As Single, Hp As Single
  Dim MyF As Variant, Pic As Variant
 
  ChDir "C:\Temp" '←画像ファイルを保存しているフォルダーのパスに変更
  With Application
   MyF = .GetOpenFilename("画像ファイル(*.jpg),*.jpg", _
   , , , True)
   If VarType(MyF) = 11 Then GoTo ELine
   .ScreenUpdating = False
  End With
  i = 1
  For Each Pic In MyF
   With Cells(i, 1).Resize(15, 7)
     Tp = .Top: Wp = .Width: Hp = .Height
   End With
   With ActiveSheet.Pictures.Insert(Pic)
     .Left = 0: .Top = Tp
     .Width = Wp: .Height = Hp
     .ShapeRange.AlternativeText = Pic
   End With
   i = i + 15
  Next
  ActiveSheet.Pictures.OnAction = "SetUF"
ELine:
  With Application
   ChDir .DefaultFilePath
   .ScreenUpdating = True
  End With
End Sub

↓こちらは、画像に登録して呼び出し専用とするマクロです。

Sub SetUF()
  Dim FPath As String
  Dim x As Variant
 
  x = Application.Caller
  If VarType(x) <> vbString Then Exit Sub
  FPath = ActiveSheet.Pictures(x) _
  .ShapeRange.AlternativeText
  MsgBox FPath
  If UserForms.Count > 0 Then Unload UserForm1
  UserForm1.Show
  On Error Resume Next
  With UserForm1.Image1.Picture
   .LoadPicture = ""
   .LoadPicture = FPath
  End With
End Sub

*コードは間違いないはずですが、なぜかこちらのテストでは何度やっても
画像を表示できませんでした。
こちらのImageオブジェクトは、どこかがおかしいみたいです・・。

【39890】Re:UserFormへの画像の張り付け方
質問  わいわい  - 06/7/3(月) 18:15 -

引用なし
パスワード
   Kein 様
いつもいつも回答して頂きありがとうございます。

>↓こちらは、画像に登録して呼び出し専用とするマクロです。
>
>Sub SetUF()
>  Dim FPath As String
>  Dim x As Variant
> 
>  x = Application.Caller
>  If VarType(x) <> vbString Then Exit Sub
>  FPath = ActiveSheet.Pictures(x) _
>  .ShapeRange.AlternativeText
>  MsgBox FPath
>  If UserForms.Count > 0 Then Unload UserForm1
>  UserForm1.Show
>  On Error Resume Next
>  With UserForm1.Image1.Picture
>   .LoadPicture = ""
>   .LoadPicture = FPath
>  End With
>End Sub
>
>*コードは間違いないはずですが、なぜかこちらのテストでは何度やっても
>画像を表示できませんでした。
>こちらのImageオブジェクトは、どこかがおかしいみたいです・・。

下記のように変更したら表示できました。

Sub SetUF()
  Dim FPath As String
  Dim x As Variant
 
  x = Application.Caller
  If VarType(x) <> vbString Then Exit Sub
  FPath = ActiveSheet.Pictures(x) _
  .ShapeRange.AlternativeText
  MsgBox FPath
  If UserForms.Count > 0 Then Unload UserForm1
>> UserForm1.Show 0  モーダル起動していたので処理が止まっていた?(1)
'  With UserForm1.Image1.Picture
'   .LoadPicture = ""
'   .LoadPicture = FPath
'  End With
>> With UserForm1.Image1  'WithブロックなんちゃらとErrorが出たので修正
>>  .Picture = LoadPicture("")
>>  .Picture = LoadPicture(FPath)
>> End With
>> UserForm1.Show   Picture設定してからForm表示。(2) (1)とどちらか一方
  On Error Resume Next
End Sub


但しこれですと、FPathで指定しているように外部に画像データを配置しなければならないと思う(実際にフォルダ名称変更でError)のですが、本体ファイル以外にファイル準備をしなくても良いように出来ないですか?例えばxを使ってですが。

【39997】Re:UserFormへの画像の張り付け方
発言  ichinose  - 06/7/5(水) 8:48 -

引用なし
パスワード
   おはようございます。

シートに配置された画像を一度ファイルに落とした後、
それをImageコントロールで読み込むという考え方です。

新規ブックに
 ユーザーフォーム(Userform1)を作成します。
  コントロールは イメージコントロール(Image1)ひとつ


適当なシートをアクティブにした後、

Sub Macro1()
  ActiveSheet.Pictures.Insert "画像パス.jpg"
End Sub
このようなコードでシートに画像を配置してください。

標準モジュールに

'============================================================
Sub test1()
  Dim imgnm As String
  Dim shp As Shape
  Call del_html(ThisWorkbook.path & "\ctmp.htm")
  Set shp = ActiveSheet.Shapes("Picture 1")
'                  ↑実際の名前
  With Workbooks.Add
    shp.Copy
    .Worksheets(1).Paste
    .SaveAs Filename:=ThisWorkbook.path & "\ctmp.htm", _
        FileFormat:=xlHtml, _
        ReadOnlyRecommended:=False, _
        CreateBackup:=False
    .Close False
    End With
  UserForm1.Show vbModeless
  With UserForm1.Image1
    imgnm = get_imgnm(ThisWorkbook.path & "\ctmp.htm")
    If imgnm <> "" Then .Picture = LoadPicture(imgnm)
    End With
  Call del_html(ThisWorkbook.path & "\ctmp.htm")
   
End Sub
'============================================================
Function get_imgnm(htmlnm As String) As String
  On Error Resume Next
  Dim fso As Object
  Dim fl As Object
  get_imgnm = ""
  Set fso = CreateObject("Scripting.FileSystemObject")
  With fso
    For Each fl In .getfolder(.GetParentFolderName(htmlnm) & "\" & .getbasename(htmlnm) & ".files").Files
     If UCase(fl.Name) Like UCase("image001.*") Then
       get_imgnm = fl.path
       Exit For
       End If
     Next
    End With
  Set fso = Nothing

End Function
'============================================================
Sub del_html(path As String)
  On Error Resume Next
  Dim fso As Object
  Set fso = CreateObject("Scripting.FileSystemObject")
  With fso
    .getfile(path).Delete
    .getfolder(.GetParentFolderName(path) & "\" & .getbasename(path) & ".files").Delete
    End With
  Set fso = Nothing
End Sub

Thisworkbook.Pathをコード内で使っていますから、
一度保存した後、test1を実行してみてください。

画像を別の新規ブックにコピーし、Htmlで保存します。
ここから、画像ファイルをサーチし、Imageコントロールに読み込む
というアルゴリズムです。

画像をファイルに落とす方法は他にもあったかと思いますが、
今回は、Htmlから、取得しました。

【40137】Re:UserFormへの画像の張り付け方
お礼  わいわい  - 06/7/7(金) 13:48 -

引用なし
パスワード
   ichinose 様

いつも解答ありがとうございす。
ご提示頂いた、リストを確認してみましたが、そのままでは、画像のUserForm1への貼付けが出来ませんでした。
そこでctmp.filesフォルダ内を調べてみると、私の環境WinXP SE、Excel2000では、以下のような結果となりました。

Set shp = ActiveSheet.Shapes("Picture 1")の場合
  ctmp.files内には、filelist.xml、image001.png、image002.jpg が出来ます。
Set shp = ActiveSheet.Shapes("Rectangle 1")の場合
  ctmp.files内には、filelist.xml、image001.jpg が出来ます。
Set shp = ActiveSheet.Shapes("Group 3")の場合
  ctmp.files内には、filelist.xml、image001.jpg が出来ます。
Set shp = ActiveSheet.Shapes("Object 1")の場合
  filelist.xml、image001.emz、image002.gif、oledata.mso が出来ます。
以上から、今回は"Picture 1"を利用しているので
>     If UCase(fl.Name) Like UCase("image001.*") Then
を     If UCase(fl.Name) Like UCase("image002.*") Then
に変更して表示できました。
ichinoseさんの環境では、UCase("image001.*")で表示できるのでしょうか?多数の人間が使うことを想定していますので、環境によって条件が変わるようだと考えなければなりません。逆に考えてExcelからctmp.filesフォルダへ書出すファイルを制御する方法があればお教え下さい。

とここまでUserForm上に表示する方法を相談させていただいたのですが、手練の皆様の解答を見て、簡単な命令ではないことが分かりました。そこでよく考えると、今回のケースでは、画像の切替表示さえ出来れば良いので画像自体を貼り付けるという方法にすればと思い、以下のリストを作成しました。
>>> Sheet3の1列目に適当な数字を入力する。
>>> Sheet2に Picture 1、Picture 2、Picture 3 を予め準備する。
>>>Sheet2のシートモジュールに
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
  Application.ScreenUpdating = False
  Macro1
  Application.ScreenUpdating = True
End Sub
>>>標準モジュールに
Sub Macro1()
  R = ActiveCell.Row
  C = ActiveCell.Column
  j = ActiveSheet.Cells(R, 1).Value
  Select Case j
    Case 1, 2, 3:  P_Name = "Picture " & j
    Case Else:   Exit Sub
  End Select
    With ActiveSheet
      k = .DrawingObjects.Count
      If k <> 0 Then .DrawingObjects(1).Delete
    End With
    Sheets("Sheet2").Select
    ActiveSheet.Shapes(P_Name).Select
    Selection.Copy
    Sheets("Sheet3").Select
    With ActiveSheet
      .Paste
      .DrawingObjects(1).Select
      Selection.ShapeRange.Left = 648
      Selection.ShapeRange.Top = 270
      .Cells(R, C).Select
    End With
End Sub

これを改良していき、機能を満足させるつもりです。ありがとうございました。

【40371】Re:UserFormへの画像の張り付け方
発言  ichinose  - 06/7/12(水) 17:45 -

引用なし
パスワード
   ▼わいわい さん:
こんにちは。

>いつも解答ありがとうございす。
>ご提示頂いた、リストを確認してみましたが、そのままでは、画像のUserForm1への貼付けが出来ませんでした。
>そこでctmp.filesフォルダ内を調べてみると、私の環境WinXP SE、Excel2000では、以下のような結果となりました。
>
>Set shp = ActiveSheet.Shapes("Picture 1")の場合
>  ctmp.files内には、filelist.xml、image001.png、image002.jpg が出来ます。
>Set shp = ActiveSheet.Shapes("Rectangle 1")の場合
>  ctmp.files内には、filelist.xml、image001.jpg が出来ます。
>Set shp = ActiveSheet.Shapes("Group 3")の場合
>  ctmp.files内には、filelist.xml、image001.jpg が出来ます。
>Set shp = ActiveSheet.Shapes("Object 1")の場合
>  filelist.xml、image001.emz、image002.gif、oledata.mso が出来ます。
>以上から、今回は"Picture 1"を利用しているので
>>     If UCase(fl.Name) Like UCase("image001.*") Then
>を     If UCase(fl.Name) Like UCase("image002.*") Then
>に変更して表示できました。
>ichinoseさんの環境では、UCase("image001.*")で表示できるのでしょうか?多数の人間が使うことを想定していますので、環境によって条件が変わるようだと考えなければなりません。逆に考えてExcelからctmp.filesフォルダへ書出すファイルを制御する方法があればお教え下さい。

図のサイズによっても違うみたいですね!!
Pngは、Imageコントロールで表示できませんしね!!
(Imageコントロールではなく、WebBrowser1コントロールに表示させるのなら、
Pngでも出来ますが)

では、bykinさんの

http://www.vbalab.net/vbaqa/c-board.cgi?cmd=one;no=5437;id=excel

これを参考にしてjpgに落としてみる方法はいかがですか?

例では、セルをjpgに保存していますが、ちょっと応用をきかして
Pictureでも出来ましたよ!!

遅くなってしまったので見ていないかもしれませんが、
もし気が付いたら、試してみてください。

【40411】Re:UserFormへの画像の張り付け方
お礼  わいわい  - 06/7/13(木) 13:31 -

引用なし
パスワード
   ichinose 様

いつも回答ありがとうございます。

>では、bykinさんの
>
>http://www.vbalab.net/vbaqa/c-board.cgi?cmd=one;no=5437;id=excel
>
>これを参考にしてjpgに落としてみる方法はいかがですか?
>例では、セルをjpgに保存していますが、ちょっと応用をきかして
>Pictureでも出来ましたよ!!
>
bykinさんには、当質問でも初めにレスを付けていただきましたし、上記内容も有難く参考にいたします。ただ、別件の作業が忙しく、検証には少し時間がかかってしまいそうです。

>遅くなってしまったので見ていないかもしれませんが、
>もし気が付いたら、試してみてください。
現プロジェクトに参考になるものはないか流し読みをしていたら、自分宛の回答が付いていたので驚きました。(もう回答は無いだろうなと思っていました)いつも質問者の勝手なお願いに、丁寧に最後まで対応して頂き、大変感謝しています。

−−−−−−−−−−−−−−−−−−−−−−−−−−−−−−−−−−−
前回のコメントで画像の直貼操作で調整するとし以下のリスト作りましたが、
表示位置がズレる、拡縮した画像がぼやける、スクロールに連動しない(スクロールイベントが無い)、相対参照にするとエラーなど、不満爆発、これらを調整していくと時間が掛りそうで、作業保留としながらも悩んでいました。今回、新たな情報を得ましたのでまた考え直してみます。

Private Sub Worksheet_SelectionChange(ByVal Target As Range)
  If Target.Column = 3 Then
    Application.ScreenUpdating = False
    Macro1
    Application.ScreenUpdating = True
  End If
End Sub

Sub Macro1()
  A_W = ActiveWindow.Width
  A_H = ActiveWindow.Height
  R = ActiveCell.Row
  C = ActiveCell.Column
  j = ActiveSheet.Cells(R, 1).Value
  
'左上のセル情報取得(スクロールに対応するため)
  Cell_Text = Application.Evaluate("=INFO(""origin"")")
  Cell_len = Len(Cell_Text)
  Cell_Add = Mid(Cell_Text, 4, Cell_len - 3)
  
  OC_L = Range(Cell_Add).Left
  OC_T = Range(Cell_Add).Top

  Select Case j
    Case 1, 2, 3:  P_Name = "Picture " & j
    Case Else:   Exit Sub
  End Select
  
  With ActiveSheet
    k = .DrawingObjects.Count
    If k > 1 Then .DrawingObjects(k).Delete
  End With
  Sheets("Sheet2").Select
  ActiveSheet.Shapes(P_Name).Select
  Selection.Copy
  Sheets("Sheet3").Select
  With ActiveSheet
    .Paste
    .DrawingObjects(2).Select
  End With
'画面サイズ変更時の表示画像サイズ補正
  With Selection.ShapeRange
    .LockAspectRatio = msoTrue
    .Height = .Height * (100 / ActiveWindow.Zoom) ^ 0.5
    .Width = .Width * (100 / ActiveWindow.Zoom) ^ 0.5
  End With
'画面サイズ変更時の表示画像位置補正
  With Selection.ShapeRange
    .Left = (A_W - 44 + OC_L) * 100 / ActiveWindow.Zoom - .Width
    .Top = (A_H - 55 + OC_T) * 100 / ActiveWindow.Zoom - .Height
  End With
  ActiveSheet.Cells(R, C).Select
End Sub

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