Excel VBA質問箱 IV

当質問箱は、有志のボランティア精神のおかげで成り立っています。
問題が解決したら、必ずお礼をしましょうね。
本サイトの基本方針をまとめました。こちらをご一読ください。

投稿種別の選択が必要です。ご注意ください。
迷惑投稿防止のため、URLの入力を制限しています。ご了承ください。


	新規投稿 ┃ツリー表示 ┃一覧表示 ┃トピック表示 ┃検索 ┃設定 ┃過去ログ ┃ホーム

2087 / 76735

←次へ　｜　前へ→


	【80292】画像貼り付け

インザーギ - 19/1/5(土) 17:38 -


	引用なし

	パスワード

画像貼り付けを目的とし、コードを見やすくすることを目標に作成しています。
ネットから参照しながら作成していましたが、行き詰ってしまったため
ご教授をお願いますでしょうか。

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

0 hits

▼

【80292】画像貼り付け インザーギ 19/1/5(土) 17:38