[[20230330160249]]　『【マクロの組み方を教えてください】画像の挿入・』（初心者みみみ）　ページの最後に飛ぶ

『【マクロの組み方を教えてください】画像の挿入・サイズ指定→セル列での画像の名前表示』（初心者みみみ）

初めて質問させていただきます。

ダブルクリックでの画像の挿入
↓
希望のサイズに自動で
（セルサイズピッタリに配置されるのがうれしいです）
↓
配置された画像の名前を表示
（例えば
A3列に配置した画像の名前がA1に表示される）
A限定ではなくA～以降も続けれるようにしたいです

という事は可能でしょうか。
ご教授いただけますと幸いです

よろしくお願いいたします。

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

 画像の縦横比を維持するか・しないか　でピッタリの定義が変わってきます。
 　縦のサイズに合わせる
 　横のサイズに合わせる
 　セルのサイズに合わせて縦または横を引き延ばす
 どうしたいですか？

（稲葉） 2023/03/30(木) 16:19:14

[[20210615164838]]　『画像挿入をしたい』（Jrq）

初心者みみみさんがお探しのものはこれですか？
（火災報知器） 2023/03/30(木) 16:21:01

お返事遅くなりすみません、コメントありがとうございます

 稲葉さん
画像の比率は維持したままセルのサイズになれば問題ないです

 火災報知器さん
こちらに近いと思われますが、付け加えて名前の表示もさせたいのでその部分をどう付け足したら良いのか分からず…
（初心者みみみ） 2023/03/31(金) 22:41:44

 A3列ってなんだろう？
 イメージわかないので図示してもらえませんか？
（稲葉） 2023/04/01(土) 06:05:50

分かりづらくすみません、、

https://www.excel.studio-kazu.jp/kw/20050308143658.html
こちらの内容が理想なのですが、一枚だけではなく何枚も画像を並べて画像付近のセルに表示させたいと言う感じです

（初心者みみみ） 2023/04/02(日) 15:37:23

こんにちは。＾＾
昔、作ったのがあったので、ちょい手直ししてみました。
こんな感じでせうか。携帯の写真整理に使っています。＾＾；

 Option Explicit
Sub ij_ImgGet_main()
    Dim Opath         As String
    Dim r             As Range
    Dim fNm           As String
    Dim eXt           As String
    Dim i             As Long
    Dim j             As Long
    Dim y             As Long
    Dim x             As Long
    Dim sTp           As Long
    Dim eDp           As Long
    Dim sTpv_Col      As Long
    Dim sTpv_Row      As Long
    Dim nCel          As Long
    Dim iCnt          As Long
    Dim yOko          As Single
    Dim tAte          As Long
    Dim sHp           As Variant
    Dim mImg          As Object
    Dim cNt           As Long
    If Not zGetImgPath(Opath) Then Exit Sub
    '画像[横幅]使用列数
    nCel = 4
    '横に並べる枚数
    iCnt = 3
    '横間隔
    sTpv_Col = 1
    '縦間隔
    sTpv_Row = 4
    With Worksheets("Sheet1")
        yOko = Cells(1).Width * nCel
        .UsedRange.Clear
        mYsp_Del Worksheets("Sheet1")
        y = 3: x = 2
        fNm = Dir(Opath & "*.*")
        fIle_Format_Chk fNm, eXt
        Do
            If fNm = "" Then Exit Do
            If eXt = "svg" Or eXt = "jpeg" Or eXt = "jpg" Or eXt = "bmp" Or eXt = "png" Then
                Set r = .Cells(y, x)
                Set mImg = .Shapes.AddPicture(Opath & fNm, False, True, r.Left, r.Top, -1, -1)
                With mImg
                    .LockAspectRatio = True
                    .Width = yOko
                End With
                r.Offset(-2) = fNm
                cNt = cNt + 1
                x = x + nCel + sTpv_Col
                If x >= ((nCel + sTpv_Col) * iCnt) + 2 Then
                    i = 0
                    eDp = .Shapes.Count
                    Select Case eDp
                        Case 1 To iCnt
                            sTp = 1
                        Case Else
                            sTp = eDp - iCnt + 1
                    End Select
                    For j = sTp To eDp
                        If i < .Shapes(j).BottomRightCell.Row Then
                            i = .Shapes(j).BottomRightCell.Row
                        End If
                    Next
                    tAte = i + sTpv_Row
                    x = 2: y = tAte
                End If
                If cNt Mod 64 = 0 Then DoEvents
                If cNt > 5000 Then
                    MsgBox "要分割注意喚起"
                End If
                If y > .Rows.Count Then
                    MsgBox "強制終了です。格納もれが有ります"
                    Exit Sub
                End If
            End If
            fNm = Dir()
            fIle_Format_Chk fNm, eXt
        Loop
    End With
    MsgBox cNt & " 件処理済"
End Sub
Private Function zGetImgPath(ByRef pNm As String) As Boolean
    Dim x             As Long
    zGetImgPath = False
    With Application.FileDialog(msoFileDialogFolderPicker)
        .AllowMultiSelect = False
        .Title = "画像ファイルのあるフォルダを選択"
        x = .Show
        If x = -1 Then
            pNm = .SelectedItems(1) & "\"
            zGetImgPath = True
        End If
    End With
End Function
Private Sub fIle_Format_Chk(ByVal fNm As String, ByRef eXt As String)
    If InStr(1, fNm, ".") > 0 Then
        eXt = LCase(StrConv(Split(fNm, ".")(UBound(Split(fNm, "."))), vbNarrow))
    End If
End Sub
Sub mYsp_Del(ByVal ws As Worksheet)
    Dim sp            As Object
    For Each sp In ws.Shapes
        sp.Delete
    Next
 End Sub
（隠居Z） 2023/04/03(月) 15:48:58

（隠居Z）さん

ありがとうございます！理想に近しいのですが
すでに書き込みがあるシートだとうまくいかないようで・・・

（初心者みみみ） 2023/04/04(火) 13:43:39

こんにちわ。。。＾＾
ま
サンプルみたいなものなので。シート名　Sheet1が、処理対象です。
それ以外はどぉなるか・・・試してはおりませんです。
＞＞すでに書き込みがあるシートだとうまくいかないようで・・・
↑のシート名がSheet1なら、書き直し[全部消して再書き込み＾＾；]
するかと。

今少し、どうなっちゃうのか。
また
どうなればよろしいのか
ご説明戴くとお手伝い出来るかもしれません。m(__)m

（隠居Z） 2023/04/04(火) 14:17:24

（隠居Z）さん

ご返信ありがとうございます
超初心者なもので申し訳ないです；；

シート横一列で画像を追加挿入しながら名前付きで管理したかったもので...
フォルダ選択後一括できるのは素晴らしいです！
あらかじめ設定しているセルのサイズ（正方形の画像管理なので縦でも横でも画像の縦横比を維持）に挿入という事も可能なのでしょうか？

（初心者みみみ） 2023/04/04(火) 14:37:44

 ちょっと忙しくなったので、途中ですけど隠居Zさんが頑張ってくれているのでお任せします。
 大変申し訳ない
（稲葉） 2023/04/04(火) 14:39:44

稲葉さん。横入り済みません。頑張ってみます。間に合わなければ
また、お願いいたしますう。。。(#^^#)ｖ。。。m(__)m

'画像[横幅]使用列数

    nCel = 4
    '横に並べる枚数
    iCnt = 3
    '横間隔
    sTpv_Col = 1
    '縦間隔
    sTpv_Row = 4
ここいらの、数字を変えてみて下さい。
 nCel = 4　←　既存のセルを右へ4個使い、セルの4列のはば＝画像の横幅としています
高さは比率を保持した値にエクセル様が自動で決めてくれていると思います。
勿論、反対も、可能です。
セルの幅、高さも、変えると、ご希望の大きさになるかもですね。
シートの切替は別途対応が必要です、アクテブシートにすれば
全てのシートで使えると思います。そこにある画像は一旦全て削除されます。けど。＾＾；
m(__)m
（隠居Z） 2023/04/04(火) 16:11:56

ｗ。。。ちょっと。私、体調が悪くなってきました。
コロナでも、かかっちまったかなぁ。。。＾＾；
という事で、ず～っと、拝見はさせて戴きますが。
書込みは暫く、お休みさせて戴きます。お急ぎでなければ
また、元気になりましたら、現れますね。(￣▽￣)
すみません～。。。m(__)mm(__)mm(__)m
（隠居Z） 2023/04/04(火) 17:20:35

（隠居Z）さん

ありがとうございました。こちらをもとに頑張ります！！m(__)m

体調大丈夫ですか？！
お大事になさってください。。
（初心者みみみ） 2023/04/05(水) 09:39:54

おはようございます。＾＾
＞＞体調大丈夫ですか？！
ありがとう御座います。元気になりました。(*^^*)ｖ
頑張ってくださいね。でわでわ
m(__)m
（隠居Z） 2023/04/05(水) 10:29:01

コメント返信：

[ 一覧(最新更新順) ]

[[20230330160249]] 『【マクロの組み方を教えてください】画像の挿入・』（初心者みみみ） ページの最後に飛ぶ

[[20230330160249]]　『【マクロの組み方を教えてください】画像の挿入・』（初心者みみみ）　ページの最後に飛ぶ