| |
画像貼り付けを目的とし、コードを見やすくすることを目標に作成しています。
ネットから参照しながら作成していましたが、行き詰ってしまったため
ご教授をお願いますでしょうか。
1.ダイアログから任意のフォルダを開きます。
2.サブフォルダ内の指定したjpegファイルを格納します。
3.シートにjpegファイルを貼り付けます。
4.貼り付けるシートには、B列にフォルダ単位で貼り付けたい。
5.同じサブフォルダ内に複数の指定したjpegが有る場合は、4.で貼り付けた
行のC列以降に貼り付けたい。
6.A行には、サブフォルダ名を入力
Option Explicit
Dim FSO As Scripting.FileSystemObject
Dim pfl As Folder
Dim mySubfld(), myfname() As Variant
Dim i, j As Integer
Sub ユーザーにフォルダーを選択してもらう()
Call mysubfolder
End Sub
Public Function mysubfolder()
Dim dlg As FileDialog
Dim fold_path As String
Set FSO = New Scripting.FileSystemObject
Set dlg = Application.FileDialog(msoFileDialogFolderPicker)
' キャンセルボタンクリック時にマクロを終了
If dlg.Show = False Then Exit Function
' フォルダーのフルパスを変数に格納
fold_path = dlg.SelectedItems(1)
Dim folderName As String
Dim buf As Folder
Dim fold As String
i = 1
With FSO
Set pfl = .GetFolder(fold_path)
For Each buf In pfl.SubFolders ' サブフォルダの一覧を取得
ReDim mySubfld(i)
mySubfld(i) = buf.Name
Call ファイル取得(fold)
Call 画像貼り付け(j)
i = i + 1
Next
End With
End Function
Public Function ファイル取得(ByRef fold As String)
Dim tmpfile As Variant
fold = pfl & "\" & mySubfld(i)
MsgBox fold
ChDir pfl & "\" & mySubfld(i)
tmpfile = Dir("BackResult" & "*.jpg")
If FSO.FileExists(tmpfile) Then
End If
j = 1
Do While tmpfile <> ""
ReDim myfname(j)
myfname(j) = tmpfile
Call 画像貼り付け(j)
tmpfile = Dir()
j = j + 1
Loop
End Function
Public Function 画像貼り付け(ByRef j As Integer)
Dim objshape As Shape
Dim myCell As Range
Dim tmp As Object
For i = 2 To UBound(myfname) + 1
Set myCell = Cells(i + j)
myCell.Select
Set objshape = ActiveSheet.Shapes.AddPicture( _
Filename:=myfname(j), _
linktofile:=False, _
savewithdocument:=True, _
Left:=Selection.Left, _
Top:=Selection.Top, _
Width:=0, _
Height:=0)
Next i
End Function
|
|
![[未読]](./data/excel/image/read_icon.gif){kind=icon}
