[[20201004030855]]　『サブフォルダからも画像挿入させたい』（こまったねやさん）　ページの最後に飛ぶ

『サブフォルダからも画像挿入させたい』（こまったねやさん）

マクロ初心者です。お助けください。
セルに入力したファイル名の画像を「指定フォルダ」から挿入するマクロを
皆さまの実例を寄せ集めて作ったつもりです。
「指定フォルダ」の中に、カテゴリーに分けた「サブフォルダ」があり、
どの「サブフォルダ」からも画像挿入できるようにしたいのです。

下記、部分をどのように記載したらよいでしょうか？
「画像フォルダ」の中に、「画像A」「画像B」・・・とフォルダがあります。

Const foldnm = "D:\画像\画像A\"

- - - - - - - - - - - - - - - - - - - - - - - - - - - - -

    Const foldnm = "D:\画像\画像A\"
    Dim org As Range
    Set org = Range("d6")
    On Error Resume Next
    With ActiveSheet.Pictures.Insert(foldnm & Range("d6").Value & ".jpg")
       .Left = org.Left
       .Top = org.Top
       .Width = org.Width
       .Height = org.Height
       End With
    On Error GoTo 0
End Sub

- - - - - - - - - - - - - - - - - - - - - - - - - - - - -

＜使用 Excel：Excel2016、使用 OS：Windows10 ＞

 挿入する画像が１つなら、指定フォルダのパスを
サブフォルダ含んだパスに変えるだけではないのかな？
サブフォルダ名がカテゴリ1なら
Const foldnm = "D:\画像\画像A\カテゴリ1\"

（はまちゃん） 2020/10/04(日) 06:31

GetOpenFileNameというものを使うと、ファイルを選択する仕組みが簡単に作れます。
例えば、
https://detail-infomation.com/vba-getopenfilename-method/
（一つでも複数でも選択可能です。）

また、フォルダの配下の画像を一括ということなら下記などが参考になるでしょう。
https://tonari-it.com/excel-vba-shapes-addpicture-batch/

ネットで検索すると色々情報がありますよ。

（γ） 2020/10/04(日) 06:36

 Sub test()
    Const foldnm = "D:\画像\"
    Dim DIC As Object
    Dim cFiles As Variant
    Dim vw As Variant
    Dim cw As String
    Dim i As Long

    Set DIC = CreateObject("Scripting.Dictionary")
    cFiles = Split(CreateObject("WScript.Shell").Exec("CMD /C DIR /A:-D/S/B """ & foldnm & "*.jpg""").StdOut().ReadAll(), vbNewLine)
    For i = 0 To UBound(cFiles) - 1
        vw = Split(cFiles(i), "\")
        DIC.Add vw(UBound(vw)), cFiles(i)
    Next i

    For i = 6 To Cells(Rows.Count, "D").End(xlUp).Row
        With Cells(i, "D")
            cw = .Text & ".jpg"
            If DIC.exists(cw) = True Then
                ActiveSheet.Shapes.AddPicture _
                        Filename:=DIC(cw), _
                        LinkToFile:=False, _
                        SaveWithDocument:=True, _
                        Left:=.Left, _
                        Top:=.Top, _
                        Width:=.Width, _
                        Height:=.Height
            End If
        End With
    Next i
 End Sub
（???） 2020/10/04(日) 08:09
（08:35 ファイルが無い場合に対応）

「サブフォルダ」を対象に画像ファイル名で検索し、
複数ヒットした場合の優先順位はありますか。

（マナ） 2020/10/04(日) 09:02

（はまちゃん）さん　ありがとうございます。
「カテゴリ１」「カテゴリ２」・・・と並列で複数ある状況で、指定した「画像名」をすべての
「カテゴリ」フォルダから選んで挿入する、としたいです。

（マナ）さん　ありがとうございます。
テストのやり方すら、わからない素人ですいません。
複数ヒットすることは無い前提ですので、優先順位はありません。

（こまったねやさん） 2020/10/04(日) 10:40

そういうフォルダ構成であれば
こんな感じで、D6セルの値の画像ファイルを検索できます。
これを現在のコードと組み合わせるとよいです。

 Sub 画像を検索()
    Dim fso As Object
    Dim subf As Object, f As Object

    Set fso = CreateObject("scripting.filesystemobject")

    For Each subf In fso.getfolder("D:\画像\").subfolders
        For Each f In subf.Files
                If f.Name = Range("d6").Value & ".jpg" Then
                    MsgBox f.Path
                    Exit Sub
                End If
            Next
        Next

 End Sub

（マナ） 2020/10/04(日) 11:16

MsgBox f.Path

で、検索結果を表示させていますが、
ここに、画像挿入のコードを記述します。

（マナ） 2020/10/04(日) 11:23

 色々やり方あると思いますが、
 　拡張子の大文字小文字の区別
 　2回目以降同名の図が存在したら挿入しない
 など少しだけ工夫してあります。
 カメラによっては、なぜか拡張子が大文字なんですねぇ・・・
 dirだと区別しないので、取得できていましたが、なぜか挿入されない現象があったので、一工夫必要でした。
 いっそ、都度dirで検索欠けたほうが早い！？（画面ちらちらするけど）
 ベースは???さんのコードです。
    Sub test()
        Dim fn As String
        Dim dic As Object
        Dim x As Variant
        Dim r As Range
        Dim shp As Shape
        Const fp As String = "C:\ABC\*.jpg"
        '
        '//連想配列にfp以下サブフォルダに存在するjpgファイル名とパスを入れる
        Set dic = CreateObject("Scripting.Dictionary")
        For Each x In Split(CreateObject("WScript.Shell").Exec("CMD /C DIR /A:-D/S/B " & fp).StdOut().ReadAll(), vbNewLine)
            dic(Replace(LCase(Dir(x)), ".jpg", "")) = x 'キーは小文字に変換して、拡張子を抜いておく
        Next x
        '
        '//D6～Dの最終行までループ処理して図を挿入する
        For Each r In Range("D6", Cells(Rows.Count, "D").End(xlUp))
            fn = Replace(LCase(r.Text), ".jpg", "") '小文字に変換して、拡張子が入力されていたら抜く
            On Error Resume Next
            Set shp = ActiveSheet.Shapes(fn)    '同じ名前の図があれば、処理を飛ばす
            On Error GoTo 0
            If shp Is Nothing Then
                If dic.exists(fn) = True Then
                    With ActiveSheet.Shapes.AddPicture( _
                                                        Filename:=dic(fn), _
                                                        LinkToFile:=False, _
                                                        SaveWithDocument:=True, _
                                                        Left:=r.Left, _
                                                        Top:=r.Top, _
                                                        Width:=r.Width, _
                                                        Height:=r.Height)
                        .Name = fn                  '図に名前を付ける
                    End With
                End If
            End If
            Set shp = Nothing
        Next r
    End Sub

（稲葉） 2020/10/05(月) 11:16

コメント返信：

[ 一覧(最新更新順) ]

[[20201004030855]] 『サブフォルダからも画像挿入させたい』（こまったねやさん） ページの最後に飛ぶ

[[20201004030855]]　『サブフォルダからも画像挿入させたい』（こまったねやさん）　ページの最後に飛ぶ