実現したいこと
指定フォルダからpngの画像を縦に並べて一括で貼り付けたい。
前提
◆「入力」と「出力用」のシートがあります。
・入力シートは画像の配置場所や、画像を貼り付けたシートを出力するシートです
・出力用シートは画像を貼り付けるシートであり、黄色い範囲に貼り付けて、1行開けて次のファイルを貼り付ける。としたいです。
◆処理の流れ（ざっくりですが大まかな流れ）
①エラーチェック（画像格納場所やpngの画像有無判定など）
②指定のフォルダから画像を取得
③出力用のシートをシートの末にコピー
④↑のシート名を変更
⑤↑のシートに画像はりつける
⑥完了ダイアログ
⑦入力シートに戻る
発生している問題・エラーメッセージ
ソースコードの「imgPathArray」に値が入らず、
While文が動かずに画像貼り付けをせずに終わってしまう。
該当のソースコード
vba
1Sub 画像貼り付け()2 3 Dim testCaseNo As String '001-014 testCaseNo = Range("C6").Text '.TEXT でセル表示形式のまま取得する .Value だと入力値を取得してしまう5 6 Dim inputDir As String '画像を格納したフォルダまでのパス。例)C:\Users\userName\Downloads\画像7 inputDir = Range("C3").Text 8 9 Dim outputDir As String 'エビデンスEXCELを格納するフォルダまでのパス。例)C:\Users\userName\Downloads\画像10 outputDir = Range("C4").Text 11 12 Dim outputBookName As String '出力するBook名。例)SHOT15_STエビデンス_001-03_小型_OK13 outputBookName = Range("C9").Text 14 15 Dim outputBookNamePath As String 'エビデンスを保存するフォルダとエビデンス名。例)C:\Users\userName\Downloads\画像\SHOT15_STエビデンス_001-03_小型_OK16 outputBookNamePath = outputDir + "\" + outputBookName 17 18 19 '-----------------------------↓事前チェック処理↓-----------------------------20 21 'FileSystemObject設定(フォルダやファイルの操作に使う)22 Dim fso As Object23 Set fso = CreateObject("Scripting.FileSystemObject")24 25 Dim imgNameArray As String26 imgNameArray = Dir(inputDir & "\" & "*.png")27 28 29 '画像格納フォルダの存在を確認30 If fso.FolderExists(inputDir) = False Then31 'フォルダが存在しない場合はメッセージを表示して処理を終了(vbCrLfは改行コード)32 MsgBox "指定の画像格納フォルダが存在しない為、処理を終了します。" & vbCrLf & "C3 セルのパスが正しいか確認してください。"33 End34 End If35 36 'エビデンス出力先フォルダの存在確認37 If fso.FolderExists(outputDir) = False = "" Then38 'フォルダが存在しない場合はメッセージを表示して処理を終了(vbCrLfは改行コード)39 MsgBox "エビデンス出力先のフォルダが存在しない為、処理を終了しました。" & vbCrLf & "C4 セルのパスが正しいか確認してください。"40 End41 End If42 43 '同フォルダのpngファイルのパスを全て取得44 45 '指定拡張子(.png)のファイルの存在確認46 If imgNameArray = "" Then47 MsgBox "指定フォルダに画像ファイル(.png)が存在しない為、処理を終了しました。" & vbCrLf & "C3 セルのパスのフォルダに画像が格納されているか確認してください。"48 End49 End If50 51 52 '指定拡張子(.png)のファイルの存在が確認できたら画像貼り付け処理開始53 54 '-----------------------------↓シート処理↓-----------------------------55 56 '出力用 のシートを末にコピーして追加57 Worksheets("出力用").Copy After:=Worksheets(Worksheets.Count)58 59 '末にコピーして追加したシートの名前をテストケースNoに変更する60 Sheets("出力用 (2)").Name = testCaseNo 61 62 '一番右のシートを取得63 Dim wsEnd As Worksheet 64 Set wsEnd = Sheets(Sheets.Count)65 66 '-----------------------------↓画像貼り付け処理↓-----------------------------67 68 '挿入する行を格納69 Dim in_row As Long70 in_row = 271 72 '複数写真の貼り付け処理を開始73 Do While imgPathArray <> "" ' <> はノットイコール74 75 '画像のファイル名を取得76 Dim imgName As String77 imgName = fso.GetBaseName(imgNameArray)78 79 Debug.Print inputDir & "\" & imgNameArray 80 81 '最初はB2からAC21(21行28列)に画像を貼り付け82 With ActiveSheet.Pictures.Insert(inputDir & "\" & imgNameArray)83 .Width = wsEnd.Range(Sheet1.Cells(in_row, 1), wsEnd.Cells(in_row, 3)).Width 84 .Top = wsEnd.Cells(in_row, 1).Top 85 .Left = wsEnd.Cells(in_row, 1).Left 86 End With87 DoEvents 88 89 '貼り付けた画像の名前を取得して写真の横のセルに転記90 wsEnd.Cells(in_row + 2, 5).Value = imgName 91 92 '14行間隔で挿入する93 in_row = in_row + 1494 95 '次の画像貼り付け処理へ96 imgPathArray = Dir()97 Loop98 99 Set fso = Nothing100 101 '入力シートに戻る102 Worksheets("入力").Activate 103 Range("C3").Select104 105 MsgBox "写真の貼り付けが正常に完了しました。"106 107End Sub108
試したこと
以下のサイト参考にしたところ、
ダイアログに取得した画像が一覧として表示されるのですが、
画像貼り付けはできずでした。。
http://officetanaka.net/excel/vba/tips/tips69.htm
補足情報（FW/ツールのバージョンなど）
こちらページを参考にして作成しています。
https://detail.chiebukuro.yahoo.co.jp/qa/question_detail/q13254168948
引き続き自分でも調査していきますが、
有識者の方にご協力いただけたら幸いです。
また、VBAを触るのがはじめてなので、
動いている部分でも冗長であったり改善の余地等あると思いますので、
そういった部分のご指摘もいただけますと嬉しいです。
何卒よろしくお願い申し上げます。
0 コメント