【VBA】Excelにフォルダ内の画像一覧を作る方法

この記事は約5分で読めます。
スポンサーリンク
コピーボタン
記事のタイトルとURLをコピー

忘備録です。

スポンサーリンク

【VBA】Excelにフォルダ内の画像一覧を作る方法

フォルダの画像を一気に張り付けて、画像一覧を作成するプログラムです。

画像を確認し、一気に名前を変更したいときなどにお使いいただけるかと思います。

Sub JIKKOU2()

    Dim RowN As Integer
    
    ''エクセルシート上で選択した範囲内の全ての図形を削除する

    Set select_range = Range(Cells(6, 1), Cells(10000, 4))
    select_range.ClearContents
    If ActiveSheet.Shapes.Count > 2 Then
        For i = ActiveSheet.Shapes.Count To 1 Step -1
            With ActiveSheet.Shapes(i)
                Set shp_rng = Range(.TopLeftCell, .BottomRightCell)
                If Not Intersect(shp_rng, select_range) Is Nothing Then
                    ActiveSheet.Shapes(i).Delete
                End If
            End With
        Next i
    End If
        
    Application.ScreenUpdating = False '画面更新をOFF
    Application.Calculation = xlManual '自動計算をOFF
    Application.EnableEvents = False 'イベントをOFF
    
    LASTY = Cells(Rows.Count, 2).End(xlUp).Row '1を任意に替える
        
    Call searchPic(Cells(3, 4), 6) '←検索したいフォルダを指定する。ColNは張り付け始める位置。
         
    Application.ScreenUpdating = True '画面更新をON
    Application.Calculation = xlAutomatic '自動計算をON
    Application.EnableEvents = True 'イベントをON
     
End Sub
  
Sub searchPic(PATH As String, ColN As Integer)
    Dim buf As String, childf As Object
 
'フォルダ内全部
    buf = Dir(PATH & "\*.png")
   
    Do While buf <> ""
     
        Cells(ColN, 1).Value = ParentDirName(PATH)
        Cells(ColN, 2).Value = buf
        Cells(ColN, 3).Activate
       '名前が一致したら実行するように指示。
       
        myFileName = PATH & "\" & buf
         
        '--(1) 選択位置に画像ファイルを挿入し、変数myShapeに格納
        Set myShape = ActiveSheet.Shapes.AddPicture( _
              Filename:=myFileName, _
              LinkToFile:=True, _
              SaveWithDocument:=False, _
              Left:=Selection.Left + 1, _
              Top:=Selection.Top + 1, _
              Width:=0, _
              Height:=0)
              
        '--(2) 挿入した画像に対して元画像と同じ高さ・幅にする
        With myShape
            .ScaleHeight 1.5, msoTrue
            .ScaleWidth 1.5, msoTrue
        End With
            
        ColN = ColN + 1
        
       
       '次のファイル
           buf = Dir()
    Loop
     
    '子フォルダも同様に、subFolderを実行する。
    With CreateObject("Scripting.FileSystemObject")
        For Each childf In .GetFolder(PATH).SubFolders
            Call searchKatashiki(childf.PATH, ColN)
        Next
    End With
     
End Sub


Function ParentDirName(PATH As String) As String

    ParentDirName = Left(PATH, InStrRev(PATH, "\") - 1)
    ParentDirName = Mid(ParentDirName, InStrRev(ParentDirName, "\") + 1)
    


'  With ThisWorkbook
'    ParentDirName = Left(ParentDirName, InStrRev(ParentDirName, "\") - 1)
'  End With


End Function

コピーボタン
記事のタイトルとURLをコピー
エクセル
スポンサーリンク
nujonoaをフォローする
nujonoa_blog

コメント欄

タイトルとURLをコピーしました