Excel (VBA)

Excel VBAに関するフォーラムです。
  • 解決済みのトピックにはコメントできません。
このトピックは解決済みです。
質問

 
(Windows 7 Professional : Excel 2007)
イメージコントロールについて
投稿日時: 17/11/28 16:21:29
投稿者: コウキ 大平

一覧表に登録されたデータを検索で呼び出してユーザーフォームにかきだすマクロを組んでいます。呼び出した画像を変更できるようにしたいのですが、可能でしょうか?
 
やり方がわかる方よろしくお願いします。
テキストボックスの方の呼び出しは下記の様になります。
一覧表には画像のファイル名で保存されています。(セルはAU列です。)
 
コマンドボタン(画像ボタンで変更できるようにしたいです。)
他に必要な情報があればお答えしますので、よろしくお願いします!
 
Private Sub 読込ボタン_Click()
 
 
     Dim myRng As Range, sn As Variant
     For Each sn In Array("F6一覧表", "F7一覧表", "F8一覧表", "起重機一覧表", "その他一覧表")
         Set myRng = Sheets(sn).Columns(3).Find(What:=Me.TextBox1.Value, LookIn:=xlValues, LookAt:=xlWhole)
         If Not myRng Is Nothing Then
         If myRng.Offset(0, 1).Value = "" Then
           MsgBox "データがありません。", vbExclamation, "NotFound"
            Exit Sub
            End If
            Me.発見期日テキストボックス.Value = Sheets(sn).Cells(myRng.Row, "D").Value
            Me.時間テキストボックス.Value = Sheets(sn).Cells(myRng.Row, "E").Value
            Me.班長テキストボックス.Value = Sheets(sn).Cells(myRng.Row, "F").Value
            Me.記入者テキストボックス.Value = Sheets(sn).Cells(myRng.Row, "G").Value
            Me.依頼作業名テキストボックス.Value = Sheets(sn).Cells(myRng.Row, "H").Value
            Me.異常内容テキストボックス.Value = Sheets(sn).Cells(myRng.Row, "I").Value
            Me.発生原因テキストボックス.Value = Sheets(sn).Cells(myRng.Row, "J").Value
            Me.処置方法テキストボックス.Value = Sheets(sn).Cells(myRng.Row, "K").Value
            Me.備考テキストボックス.Value = Sheets(sn).Cells(myRng.Row, "L").Value
            Me.起案者テキストボックス.Value = Sheets(sn).Cells(myRng.Row, "V").Value
            Me.内線テキストボックス.Value = Sheets(sn).Cells(myRng.Row, "W").Value
            Me.安全コンボボックス.Value = Sheets(sn).Cells(myRng.Row, "AF").Value
            Me.環境コンボボックス.Value = Sheets(sn).Cells(myRng.Row, "AG").Value
            Me.品質コンボボックス.Value = Sheets(sn).Cells(myRng.Row, "AH").Value
            Me.作業希望日テキストボックス.Value = Sheets(sn).Cells(myRng.Row, "AI").Value
            Me.ComboBox1.Value = Sheets(sn).Cells(myRng.Row, "P").Value
            Me.備考テキストボックス.Value = Sheets(sn).Cells(myRng.Row, "L").Value
            Me.完了日テキストボックス.Value = Sheets(sn).Cells(myRng.Row, "R").Value
            Me.Image1.Picture = LoadPicture(Sheets(sn).Cells(myRng.Row, "AU").Value)
             
            Me.保全オプションボタン.Value = Sheets(sn).Cells(myRng.Row, "M").Value = "○"
            Me.操炉オプションボタン.Value = Sheets(sn).Cells(myRng.Row, "N").Value = "○"
            Me.外注オプションボタン.Value = Sheets(sn).Cells(myRng.Row, "O").Value = "○"
            Me.復旧オプションボタン.Value = Sheets(sn).Cells(myRng.Row, "X").Value = "○"
            Me.改造オプションボタン.Value = Sheets(sn).Cells(myRng.Row, "Y").Value = "○"
            Me.新設オプションボタン.Value = Sheets(sn).Cells(myRng.Row, "Z").Value = "○"
            Me.取替オプションボタン.Value = Sheets(sn).Cells(myRng.Row, "AA").Value = "○"
            Me.その他オプションボタン.Value = Sheets(sn).Cells(myRng.Row, "AB").Value = "○"
            Me.緊急オプションボタン.Value = Sheets(sn).Cells(myRng.Row, "AC").Value = "○"
            Me.普通オプションボタン.Value = Sheets(sn).Cells(myRng.Row, "AD").Value = "○"
            Me.定修時オプションボタン.Value = Sheets(sn).Cells(myRng.Row, "AE").Value = "○"
            Me.トラブルレポートオプションボタン.Value = Sheets(sn).Cells(myRng.Row, "AJ").Value = "○"
            Me.改善提案オプションボタン.Value = Sheets(sn).Cells(myRng.Row, "AK").Value = "○"
            Me.製作依頼オプションボタン.Value = Sheets(sn).Cells(myRng.Row, "AL").Value = "○"
            Me.各パトロール指摘オプションボタン.Value = Sheets(sn).Cells(myRng.Row, "AM").Value = "○"
            Me.各委員会指摘オプションボタン.Value = Sheets(sn).Cells(myRng.Row, "AN").Value = "○"
            Me.カーバイトオプションボタン.Value = Sheets(sn).Cells(myRng.Row, "AO").Value = "○"
            Me.PACオプションボタン.Value = Sheets(sn).Cells(myRng.Row, "AP").Value = "○"
            Me.フロックオプションボタン.Value = Sheets(sn).Cells(myRng.Row, "AQ").Value = "○"
            Me.イソウール類オプションボタン.Value = Sheets(sn).Cells(myRng.Row, "AR").Value = "○"
            Me.無水タールオプションボタン.Value = Sheets(sn).Cells(myRng.Row, "AS").Value = "○"
            Me.その他オプションボタン3.Value = Sheets(sn).Cells(myRng.Row, "AT").Value = "○"
 
 Exit For
         End If
          
     Next
     If myRng Is Nothing Then
         MsgBox Me.TextBox1.Value & "は、見つかりません", 48
     End If
 End Sub

回答
投稿日時: 17/11/28 17:03:35
投稿者: baoo

ご質問の意味がよくわかりません。
現在のコードで見つかった画像に変更されませんか?
 
それとも変更というのはWindowsのアクセサリにあるようなペイントソフトで
編集したいということでしょうか?
そうだとすれば画像編集ソフトを作成するのは大変難しいので、
提示のコードを元にすれば

Private Sub 画像ボタン_Click() 
    Shell "C:\Winows\System32\mspaint.exe """ & Sheets(sn).Cells(myRng.Row, "AU").Value & """"
End Sub
とするぐらいでしょうか。

投稿日時: 17/11/28 17:14:16
投稿者: コウキ 大平

一度登録したデータを呼び出して再び新しい画像を登録し直して保存したいのです。

回答
投稿日時: 17/11/28 18:14:05
投稿者: baoo

あなたの業務での登録とは何かについて私が知る必要がありますか?
 
データベースのように沢山の列のあるデータがあり、その中に画像情報もある。
検索により、ある1件(1行)のデータを呼び出したときに、そのデータの中の画像情報に合わせて
Imageコントロールに画像が表示されるようになっている。
呼び出したデータを修正するときに画像ファイル名も変更したいが、
画像はテキストボックスが無いので修正できない。
どうしたら良いか?
 
ということでしょうか?
こちらはあなたの業務も状況も分からないし、何で困っているのかも説明されなければわかりません。
 
提示のコードの中に画像を読み込む処理がありますよね。
方法論としてはイメージコントロールのそばにボタンなどを配置して
ボタンを押したらファイル選択ダイアログを表示して選択したファイルで
画像を読み込む処理と同じことを行えばよろしいかと思います。

    Dim strImgFile As String
    strImgFile = Application.GetOpenFilename("*.jpg,*.jpg")
    If strImgFile = "False" Then
        Exit Sub
    End If
    Me.Image1.Picture = LoadPicture(strImgFile)
    
    '画像を読み込んだ時にファイル名をシートに書き出して良いか?
    Sheets(sn).Cells(myRng.Row, "AU").Value = strImgFile
すべての修正を完了してから修正完了ボタンをクリックするような処理になっているなら、
strImgFileをグローバル変数やフォーム内のPrivate変数にするか、
フォーム内に画像ファイル名を保持するテキストボックス、ラベル等を用いて、
修正完了処理の中で最後の1文を実行するなどという運用になると思います。

回答
投稿日時: 17/11/28 22:05:33
投稿者: もこな2

baooさんがすでに指摘されておられますけど、私が見ても何を困ってるのかよくわからないです。
 
たとえば、〜〜〜したくて×××というコードを書いたけれど、〜〜〜っていうエラーが発生してうまくいかないなど、どの点で詰まっているのかを提示願えないでしょうか。
 
また、ご質問の部分ではないですけど

Dim myRng As Range, sn As Variant
Sheets(sn).Cells(myRng.Row, "D").Value 
この部分の「sn」をVariant型で宣言してますが、後段を見るとワークシートのようですし、myRng.Rowが何回も出てきているのでもうちょっと工夫すれば多少は見やすくなるような気がします。
テストしてないですけど、たとえばこんな感じとか・・・
Dim myRng As Range

Dim 検索対象シート As Object
Set 検索対象シート = Array( _
                        Worksheets("F6一覧表"), _
                        Worksheets("F7一覧表"), _
                        Worksheets("F8一覧表"), _
                        Worksheets("起重機一覧表"), _
                        Worksheets("その他一覧表"))

Dim sn As Worksheet
Dim 行 As Long

For Each sn In 検索対象シート
    If sn.Columns(3).Find(What:=Me.TextBox1.Value, LookIn:=xlValues, LookAt:=xlWhole) <> Nothing Then
        Set myRng = sn.Columns(3).Find(What:=Me.TextBox1.Value, LookIn:=xlValues, LookAt:=xlWhole)
        行 = myRng.Row
    End If
Next sn

If myRng Is Nothing Then
    MsgBox "データがありません。", vbExclamation, "NotFound"
    Exit Sub
End If

With sn
    Me.発見期日テキストボックス.Value = .Cells(行, "D").Value
    Me.時間テキストボックス.Value = Sheets(sn).Cells(行.Row, "E").Value
    Me.班長テキストボックス.Value = .Cells(行.Row, "F").Value
    Me.記入者テキストボックス.Value = .Cells(行.Row, "G").Value
    Me.依頼作業名テキストボックス.Value = .Cells(行.Row, "H").Value
    Me.異常内容テキストボックス.Value = .Cells(行.Row, "I").Value
    Me.発生原因テキストボックス.Value = .Cells(行.Row, "J").Value
    Me.処置方法テキストボックス.Value = .Cells(行.Row, "K").Value
    Me.備考テキストボックス.Value = .Cells(行.Row, "L").Value
End With

回答
投稿日時: 17/11/28 22:16:54
投稿者: もこな2

引用:
呼び出した画像を変更できるようにしたいのですが、可能でしょうか?

ふと思いましたがもしかしてこんな感じでしょうか
@ユーザーフォーム上のボタンを押したら、UserFormのImageコントローラーに別の画像を読み出す
AUserFormのImageコントローラーに設定されている画像のパスをキーにして、複数シートを串刺し検索
B検索がヒットしたら(どのシートのどの列かわかったら)、ユーザーフォーム上の各コントロールをいろいろ設定
 
もしこの通りであれば、
 @は、ボタンのクリックイベントでどうにでもなりそうです。
 Aは、提示のコードに答えが出てるので割愛
 Bも、提示のコードに答えがでてるので割愛
となります。
 
いずれにせよ、今のままだと何をされたいのかが回答者から見えないので、レスが付きづらいように思われます。

投稿日時: 17/11/29 07:42:10
投稿者: コウキ 大平

わかりにくい質問で申し訳ありません。
 
エクセルでやりたいことの流れは、
@ 別のユーザーフォーム(UserForm1)でデータを一覧表(F7一覧表)に登録します。
  →ここで、すでに画像が登録されています。(ファイル名として)
A この、登録したデータをF7一覧表から編集用(UserForm2)に呼び出します。
  →呼び出すのは、管理番号で検索し呼び出します。
B 呼び出したデータを編集します。
 ここまではマクロとしてできています
C 編集したデータを呼び出したデータと同じ場所に上書き保存する。
  ↑ここの部分の画像ファイルの選択と前画像の削除、上書き保存の仕方がわかりません。
   他のデータ(テキストボックス)の保存はできるのですが画像のみできません。
 
画像はユーザーフォームのImageに呼出していますので、コマンドボタン(画像変更)をおしたら、その画像を削除し、新しい画像を選択、表示し、一覧表に保存したいのです。
 
よろしくお願いします
  
 

回答
投稿日時: 17/11/29 10:30:30
投稿者: もこな2

う〜ん
ごめんさい。やっぱり私にはよくわからないです。もしかしてこんな感じでしょうか?
 

引用:
@ 別のユーザーフォーム(UserForm1)でデータを一覧表(F7一覧表)に登録します。
  →ここで、すでに画像が登録されています。(ファイル名として)
@ 入力用フォーム(UserForm1)に入力して登録ボタンを押すと、フォーム上の内容が
  シート(F7一覧表)に反映されるマクロがあります。
  また、入力用フォーム(UserForm1)のImageコントローラーに表示している画像の
  ファイル名はシート(F7一覧表)のセル「AU」に反映するようになっています。
  ※1行が1レコードになる。
 
引用:
A この、登録したデータをF7一覧表から編集用(UserForm2)に呼び出します。
  →呼び出すのは、管理番号で検索し呼び出します。
A 編集用フォーム(UserForm2)の読込ボタンを押すと、管理番号入力欄に
  入力されている管理番号をキーに複数のシートを串刺し検索して、レコードが
  あるシート&行を(以下、レコードと標記)取得。
  レコードから、フォーム(UserForm2)の各コントロールに値をセットします。
 
引用:
B 呼び出したデータを編集します。
 ここまではマクロとしてできています

 
引用:
C 編集したデータを呼び出したデータと同じ場所に上書き保存する。
  ↑ここの部分の画像ファイルの選択と前画像の削除、上書き保存の仕方がわかりません。
   他のデータ(テキストボックス)の保存はできるのですが画像のみできません。
C 編集用フォーム(UserForm2)の登録ボタンを押したら各コントローラーの内容を
  レコードに出力します。
  しかし、テキストボックスのデータは出力させることができましたが、Imageコント
  ローラに表示されている画像ファイルのファイル名を取得する方法がわからないので、
  レコードの「AU」列に反映させることができません。
 
仮にこのとおりだとすると、私にはImageコントローラーに読み込まれている画像ファイルのパスやファイル名を取得する方法はわかりませんけど、コウキ 大平さんは、@で出来ているということでしょうから、何がお困りかよくわかりません。
 
なお、Imageコントローラーに読み込まれている画像ファイルのパスやファイル名を取得する方法でお困りということであれば、上記のとおり私にはわからないですけど、解決方法というか回避方法として、フォーム上に隠しオブジェクト(非表示のラベルとか)を置いておいて、Imageコントローラーに画像を読み込ませるときに、一緒に隠しオブジェクトにパスなりファイル名なりを格納しておくという方法ならいけそうですね。

投稿日時: 17/11/29 10:58:11
投稿者: コウキ 大平

ありがとうございます。
 
UserForm1(入力用)にはImage1を使用していないのでやり方がわかりません。
UserForm1に使っているマクロは下記の様になっています。
Sub 画像貼り付けボタン_Click()
 Dim Pic As String, PHT As Single, PWD As Single
 Dim CTP As Single, CLF As Single, CHT As Single, CWD As Single
 Dim shp As Object
 Dim rng As Range
 Pic = Application.GetOpenFilename
 If Pic = "False" Then Exit Sub
 Application.ScreenUpdating = False
 With Sheets("F6一覧表")
Set rng = .Range("AU" & .Cells(Rows.Count, "AU").End(xlUp).Row + 1)
 rng.Value = Mid(Pic, InStrRev(Pic, "\") + 1)
 .Hyperlinks.Add Anchor:=rng, Address:=Pic
 End With
 With Sheets("原紙")
 .Activate
 CTP = .Range("K10:AE23").Top 'セル範囲の上辺位置
CLF = .Range("K10:AE23").Left 'セル範囲の左辺位置
CHT = .Range("K10:AE23").Height 'セル範囲の高さ
CWD = .Range("K10:AE23").Width 'セル範囲の幅
'指定セル範囲にある画像を削除
For Each shp In ActiveSheet.Pictures
 If shp.Left >= CLF And shp.Top >= CTP Then
 shp.Delete
 End If
 Next shp
 .Pictures.Insert(Pic).Select
 With Selection.ShapeRange
 PHT = .Height '写真の縦サイズ
PWD = .Width '写真の横サイズ
.LockAspectRatio = msoTrue
 Select Case PHT / PWD '写真の縦/横比と比べて、
Case Is >= CHT / CWD 'セル範囲の縦/横比が小さい
.Height = CHT
 PWD = Selection.ShapeRange.Width '拡縮時の横サイズ
.Top = CTP
 .Left = CLF + (CWD - PWD) / 2
 Case Else 'セル範囲の縦/横比が大きい
.Width = CWD
 PHT = Selection.ShapeRange.Height '拡縮時の縦サイズ
.Top = CTP + (CHT - PHT) / 2
 .Left = CLF
 End Select
 End With
 End With
 'Sheets("F6一覧表").Activate
 Sheets("原紙").Activate
 Application.ScreenUpdating = True
 End Sub
 
 
 
なので、Sheet(F6一覧表)の部分に元の一覧のシート(シートは全5枚)に書き出すマクロを入れればよいのかと思いやってみましたができませんでした。
 
 
なにか方法はありますでしょうか?

回答
投稿日時: 17/11/29 13:59:44
投稿者: もこな2

 17/11/29 10:58:11の投稿を見てのコメントです。
 
まず、ソースコードが見づらいです。インデントやコメントを設定してどこで何をやってるか見やすくしたほうが後々良いように思います。
 
ということで、ちょっと編集させていただきました。

Sub 画像貼り付けボタン_Click()

Dim Pic As String, PHT As Single, PWD As Single
Dim CTP As Single, CLF As Single, CHT As Single, CWD As Single
Dim shp As Object
Dim rng As Range

'組み込みダイアログで画像ファイルのパスを取得
Dim Pic As String
Pic = Application.GetOpenFilename
If Pic = "False" Then Exit Sub

Application.ScreenUpdating = False '画面更新を停止

With Sheets("F6一覧表")
    Set rng = .Range("AU" & .Cells(Rows.Count, "AU").End(xlUp).Row + 1)
    rng.Value = Mid(Pic, InStrRev(Pic, "\") + 1)
    .Hyperlinks.Add Anchor:=rng, Address:=Pic
End With

With Sheets("原紙")
    .Activate
    CTP = .Range("K10:AE23").Top 'セル範囲の上辺位置
    CLF = .Range("K10:AE23").Left 'セル範囲の左辺位置
    CHT = .Range("K10:AE23").Height 'セル範囲の高さ
    CWD = .Range("K10:AE23").Width 'セル範囲の幅

    '指定セル範囲にある画像を削除
    For Each shp In ActiveSheet.Pictures
        If shp.Left >= CLF And shp.Top >= CTP Then
            shp.Delete
        End If
    Next shp

    .Pictures.Insert(Pic).Select
    With Selection.ShapeRange
        PHT = .Height '写真の縦サイズ
        PWD = .Width '写真の横サイズ
        .LockAspectRatio = msoTrue
        Select Case PHT / PWD '写真の縦/横比と比べて、
            Case Is >= CHT / CWD 'セル範囲の縦/横比が小さい
                .Height = CHT
                PWD = Selection.ShapeRange.Width '拡縮時の横サイズ
                .Top = CTP
                .Left = CLF + (CWD - PWD) / 2
            Case Else 'セル範囲の縦/横比が大きい
                .Width = CWD
                PHT = Selection.ShapeRange.Height '拡縮時の縦サイズ
                .Top = CTP + (CHT - PHT) / 2
                .Left = CLF
        End Select
    End With
 End With

 'Sheets("F6一覧表").Activate
 Sheets("原紙").Activate
 Application.ScreenUpdating = True '画面更新の停止を解除
 End Sub

 
編集して思ったんですが、
With Sheets("F6一覧表")
    Set rng = .Range("AU" & .Cells(Rows.Count, "AU").End(xlUp).Row + 1)
    rng.Value = Mid(Pic, InStrRev(Pic, "\") + 1)
    .Hyperlinks.Add Anchor:=rng, Address:=Pic
End With
この部分で使っている「rng」という変数は後で出てこないので、withステートメントで記述したほうがすっきりしそうな気がします。まぁ好みでしょうが。。
With Sheets("F6一覧表")
        With .Range("AU" & .Cells(Rows.Count, "AU").End(xlUp).Row + 1)
            .Value = Mid(Pic, InStrRev(Pic, "\") + 1)
            .Hyperlinks.Add Anchor:=.Range, Address:=Pic
        End With
End With
※Anchor:=.Rangeでうまくいかなかったらごめんなさい。
 
また、「Mid(Pic, InStrRev(Pic, "\") + 1)」という記述はおそらくフルパスからファイル名だけ取り出したかったのだと思いますが、Dir関数を使えばもっと簡単に「Dir(Pic)」で済みます。 
 
このほか、
    '指定セル範囲にある画像を削除
    For Each shp In ActiveSheet.Pictures
とありますが、「ActiveSheet.Pictures」となってますから、アクティブシートの.Picturesが対象になっているように思います。指定セル範囲がどこかわかりませんが前段から推測して、「.Range("K10:AE23")」だとして、さらに、SheetオブジェクトやRangeオブジェクトにPicturesというオブジェクト?プロパティ?があるのかわからないですけどあるならこんな感じに直せますよね
    With .Range("K10:AE23")
        CTP = .Top 'セル範囲の上辺位置
        CLF = .Left 'セル範囲の左辺位置
        CHT = .Height 'セル範囲の高さ
        CWD = .Width 'セル範囲の幅

        '指定セル範囲にある画像を削除
        For Each shp In .Pictures
            shp.Delete
        Next shp
    End With

 
引用:
なので、Sheet(F6一覧表)の部分に元の一覧のシート(シートは全5枚)に書き出すマクロを入れればよいのかと思いやってみましたができませんでした。
なにか方法はありますでしょうか?
私の読解力不足なのかもですが、何がなのでなのかわかりません。
追加で提示のあったコードを拝見すると
 @組み込みダイアログでユーザーに画像ファイルを選ばせて、ファイルパスを取得
 A「F6一覧表」シートの「AU列の(最終行+1)行」セルに画像ファイルのハイパーリンクを設定して
 B「原紙」シートの全画像ファイルを削除して
 C「原紙」シートの特定箇所に@で取得したパスの画像をなんやかんやがんばって挿入
というように読めましたので、「Sheet(F6一覧表)の部分に元の一覧のシート(シートは全5枚)に書き出すマクロ」ではないと判断しました。したがって、何を困っているのか依然としてよくわかりません。という結論になってしまいます。
 
なかなか、困っていることを文章で伝えるのは難しいとおもいますけど、作ったコードを片っ端から並べて、うまくいかない箇所があります。だけですと回答者は何が困っているのか、どう動くようにしたいのかがわかりませんので、答えようがないと思われます。(少なくとも私は無理です。)
 
たとえば、追加提示のあったコードの実行中に止まってしまって困っているのであれば、止まった箇所を示さないと、原因分析ができません。

投稿日時: 17/11/29 15:24:21
投稿者: コウキ 大平

申し訳ありません。
 
もう一度内容検討し再投稿致します。
 
その時はよろしくお願い致します。