Excel VBA マクロ 選択したフォルダを取り込み

リストボックスで選択したフォルダの中身（JPGファイルが複数入っています）をExcelシートに貼り付けるマクロを作成したいです。

ユーザーフォームにはフォルダの選択を行う以下のマクロが組んであります。
Private Sub UserForm_Initialize()
Dim S_folderPath As String
Dim filename As String

Me.TextBox1 = ThisWorkbook.Path & "\"
S_folderPath = Me.TextBox1.Text

UserForm1.Caption = "フォルダ名を選択して下さい"
'先頭のファイル名の取得
FolderName = Dir(S_folderPath, vbDirectory) '←リストボックスに表示させるフォルダ名

'ファイルが見つからなくなるまで繰り返す
Do While FolderName <> ""
If FolderName <> "." And FolderName <> ".." Then
ListBox1.AddItem FolderName
End If
FolderName = Dir()
Loop
End Sub

該当のフォルダを選択し、コマンドボタンを押せばそのフォルダの画像が貼り付けられるようにしたいのですが、コマンドボタンにどのようなマクロを組めば良いのか分かりません。

写真を取り込むマクロはあるのですが、これをどう使えば良いかも分かりません。
Sub 写真取り込み()
　Dim folderpath As String
　Dim basefile As String
　Dim filename As String
　Dim myFileName As String
　Dim filenum As Integer
　Dim filen As Integer
　Dim myShape As Shape
　Dim darray() As Variant
　Dim i As Shape

　basefile = "このマクロが組んであるファイル.xlsm"
　folderpath = ThisWorkbook.Path & "\"

　Workbooks(basefile).Activate
　Worksheets("写真").Select
　 Cells.ClearContents

　'jpegファイル名を取り込む
　Dim buf As String, cnt As Long
　buf = Dir(folderpath & "*.jpg")
　Do While buf <> ""
　cnt = cnt + 1
　Sheets("写真").Cells(cnt, 1) = buf
　 buf = Dir()
　Loop

　'ファイル数を数える
　Workbooks(basefile).Activate
　Worksheets("写真").Select
　filenum = WorksheetFunction.CountA(Columns("A:A"))

　'写真を貼り付ける
　 For filen = 1 To filenum
　'貼り付けるファイル名を決める
　filename = Sheets("写真").Cells(filen, 1)
　folderpath = ThisWorkbook.Path & "\"
　myFileName = folderpath & filename

　 Cells(filen, 2).Select

　'--(1) 選択位置に画像ファイルを挿入し、変数myShapeに格納
　 Set myShape = ActiveSheet.Shapes.AddPicture( _
　 filename:=myFileName, _
　 LinkToFile:=False, _
　 SaveWithDocument:=True, _
　 Left:=Selection.Left, _
　 Top:=Selection.Top, _
　 Width:=0, _
　 Height:=0)

　'--(2) 挿入した画像に対して元画像と同じ高さ・幅にする
　 myShape.Select
　 Selection.ShapeRange.Height = 99
　 Selection.ShapeRange.Width = 132.09428
　 Selection.ShapeRange.ZOrder msoSendToBack
　 Next
End Sub

長々と申し訳ありません。
一部でも分かるような方がいましたら、お力をお貸しいただけないでしょうか？
よろしくお願いいたします。

No.1 回答者： fujillin 回答日時： 2020/12/24 16:10

こんにちは

コード中のコメントにある通り、ひとつのファイルを貼り付けるのは（１）の部分（実際は一つの命令）だけです。
画像のサイズを固定（？）に調整するのなら（２）の部分も。

上記（１）を実行する際には、
　・変数myFileNameに画像のパス
　・Selectionは画像を挿入するセル位置
にしておく必要があります。

ということで、
＞コマンドボタンにどのようなマクロを組めば良いのか分かりません。
　・formで選択されている画像ファイルのパスを変数myFileNameに
　・画像挿入位置のセルを選択
の状態にして、（１）の処理（必要に応じて（２）も）を行えば宜しいかと。

この回答へのお礼

回答ありがとうございます｡
恥ずかしながら知識不足で､頂いたアドバイスを実行することができなさそうです｡
（写真を取り込むマクロは当方が作成したものではなく、そのため解読できていない有様です。）
申し訳ありません｡

お礼日時：2020/12/25 12:59

No.2 回答者： Qchan1962 回答日時： 2020/12/24 17:06

こんばんは、

＞該当のフォルダを選択し、コマンドボタンを押せばそのフォルダの画像が貼り付けられるようにしたい
＞写真を取り込むマクロはあるのですが、これをどう使えば良いかも分かりません。
TextBox1で選択したフォルダを対象にするためには　
Sub 写真取り込み()の
folderpath = ThisWorkbook.Path & "\"　を
folderpath = Me.TextBox1.Text　にすることで良いかと思います。
使用されていない変数などもあるようなのでざっくりですが、、

ブック名やシート名は適時変更、A列にファイル名、B列に画像（.jpg）、と言う処理のようですが、ファイル数を数えるについては、変数cntが値を持っているので、流用できるような気がしますし、変数bufが、ファイル名を持っているなら、このDo While buf <> ""　内ですべて処理してしまっても良さそうですが、入力（設定）メイン処理　出力を分ける意味では有用なのかもしれませんね。
また、拡張子の大文字小文字対策や簡単なエラー処理も必要かと思います。未検証なので、、あくまで参考程度で。

この回答へのお礼

回答ありがとうございます｡
恥ずかしながら知識不足で､頂いたアドバイスを実行することができなさそうです｡
（写真を取り込むマクロは当方が作成したものではなく、そのため解読できていない有様でして、後半のおっしゃっていることもわかりませんでした..
.）
申し訳ありません｡

お礼日時：2020/12/25 13:00

No.3 ベストアンサー 回答者： Qchan1962 回答日時： 2020/12/25 22:44

＃２です。

不明な点を確認するべきでした。
＞リストボックスで選択したフォルダの中身（JPGファイルが複数入っています）をExcelシートに貼り付けるマクロを作成したいです。

フォルダ内のすべてのjpgファイルを貼り付けたいと言う事でよろしいのでしょうか？また、どこのセルにどのように出力（貼り付け）したいのでしょうか？

ご質問にあるコードを拝見すると

Excelには写真と名付けられたシートがあり、
UserFormには、TextBox1とListBox1、CommandButton1が配置されていると想定できます。

おそらく実行するとTextBox1にThisWorkbook.Pathが、ListBox1に同階層のファイルとフォルダが表示されてしまいます。
この時ListBox1にファイル名も表示されると思いますが、そのファイル単体で貼り付ける場合もあるのでしょうか？

もし、ListBox1にフォルダ名のみを表示して、そのフォルダを選択して実行するなら、vbNormal+vbDirectory=16の不具合を回避するために

Do While FolderName <> ""
If GetAttr(S_folderPath & FolderName) And vbDirectory Then
If FolderName <> "." And FolderName <> ".." Then
ListBox1.AddItem FolderName
End If
End If
FolderName = Dir()
Loop
こんな感じになるでしょうか、他には
FSO（Scripting.FileSystemObject）などを使う方法もあります。

この部分はご質問の部分ではないので置いといて、
参考にされようとしている　Sub 写真取り込み()を読むと、ListBox1の対象フォルダを選択してCommandButtonを押すとSheets("写真")のA列にフォルダ内にあるすべてのjpgファイル名が出力され、B列に画像（jpg)が指定サイズで貼り付けられるかと思います。
すべての画像をB列下方向に貼り付けで良いのでしょうか？
この時、貼り付けサイズはどうされますか？

参考になるか分かりませんが、

Private Sub CommandButton1_Click()
Dim buf As String
Dim folderpath As String
Dim cnt As Long
Dim myShape As Shape
Worksheets("写真").Activate
With ActiveSheet
.Shapes.SelectAll 'すべてのShapeを選択
Selection.Delete '選択されているShapeを削除
.Cells.ClearContents 'シートセルの書式、値をクリアー
folderpath = TextBox1.Text & "\" & ListBox1.Text & "\"
'jpegファイル名を取り込む
buf = Dir(folderpath & "*.jpg")
Do While buf <> ""
cnt = cnt + 1
.Cells(cnt, 1) = buf
'写真を貼り付ける
.Cells(cnt, 2).Select
'--(1) 選択位置に画像ファイルを挿入し、変数myShapeに格納
Set myShape = ActiveSheet.Shapes.AddPicture( _
filename:=folderpath & "\" & buf, _
LinkToFile:=False, _
SaveWithDocument:=True, _
Left:=Selection.Left, _
Top:=Selection.Top, _
Width:=0, _
Height:=0)
'--(2) 挿入した画像に対して高さ・幅を設定する
myShape.Select
With Selection
.ShapeRange.Height = .TopLeftCell.Height 'セルの高さ
.ShapeRange.Width = .TopLeftCell.Width 'セルの幅
End With
buf = Dir()
Loop
End With
MsgBox ("画像ファイル " & cnt & "枚を貼り付けしました")
End Sub

これを実行するとListBox1で選択したフォルダ内すべてのjpgファイルが
Worksheets("写真")のB列にセルのサイズに合わせて貼り付けられると思います。
長文回答で分かり難いかも知れませんが、参考になれば幸いです。

追記
拡張子の大文字小文字対策、、、
buf = Dir(folderpath & "*.jpg")なので忘れてください。
条件設定など（If～ Like）の場合と勘違いしました。
例
For Each myFile In fso.GetFolder(folderpath).Files
If LCase(myFile.Name) Like "*.jpg" Then

この回答へのお礼

こんにちは。お返事が遅くなりました。
詳細にありがとうございます。
ご提示いただいたマクロで、目的通りの操作になりました！
最終目標はまた別にあるので、これをもとに改良していこうと思います。
無知で失礼いたしました。
本当にありがとうございます。

お礼日時：2020/12/29 12:53