Excel VBA質問箱 IV

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

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


19778 / 76732 ←次へ | 前へ→

【62380】Re:ファイル一覧を作りましたが
回答  Hirofumi  - 09/7/15(水) 16:28 -

引用なし
パスワード
   今使っている、コードを少し変更した物で余り上手く有りませんが?
再帰呼び出しでSubFolderも探して居ます

Option Explicit

Sub ファイル一覧_2()

  Dim myFSO As Object
  Dim i As Long
  'フォルダー取得
  Dim myShell As Object, myPath As Object
  Dim vntFiles As Variant
  
  Set myShell = CreateObject("Shell.Application")
  Set myPath = myShell.BrowseForFolder(0, "フォルダを選択して下さい", &H11)
  'If Not myPath Is Nothing Then MsgBox myPath.Items.Item.Path
  
  'FSOのオブジェクトを取得
  Set myFSO = CreateObject("Scripting.FileSystemObject")
  
  'ファイル名取得
  If Not GetFilesList(vntFiles, myPath.Items.Item.Path, myFSO, , , -1) Then
    GoTo Wayout
  End If
  
  With ActiveSheet
    .Cells(1, 1).Resize(, 5).Value _
        = Array("No", "ファイル名", "作成日", "サイズ", "パス")
    With .Cells(2, 1)
      .Value = 1
      .Resize(UBound(vntFiles, 2) + 1).DataSeries _
          Rowcol:=xlColumns, Type:=xlLinear, _
          Date:=xlDay, Step:=1, Trend:=False
      .Offset(, 1).Resize(UBound(vntFiles, 2) + 1, 4).Value = vntFiles
    End With
  End With

Wayout:

  Set myFSO = Nothing
  Set myPath = Nothing
  Set myShell = Nothing

End Sub

Private Function GetFilesList(vntFileNames As Variant, _
              strFolderPath As String, _
              objFSO As Object, _
              Optional strBasePattan As String = ".*", _
              Optional strExtePattan As String = ".*", _
              Optional lngSubDir As Long = -1) As Boolean

'  vntFileNames  : ファイル名等が返される変数(配列)
'  strFolderPath  : 探し始めるフォルダを指定
'  strBasePattan  : ファイルのBase名を正規表現で指定
'  strExtePattan  : ファイル拡張子を正規表現で指定
'  lngSubDir    : 探すサブフォルダの階層を指定、0はstrFolderPath、1はstrFolderPathの下の
'           -1ははstrFolderPath以下全てのサブフォルダ
'  戻り値     : 値が在った場合、Trueを返す
              
  Const clngLower As Long = 0
  
  Dim regName As Object
  Dim vntRead As Variant
  
  'フォルダの存在確認
  If Not objFSO.FolderExists(strFolderPath) Then
    GoTo Wayout
  End If
  
  Set regName = CreateObject("VBScript.RegExp")
  '大文字と小文字を区別しないように設定
  regName.IgnoreCase = True

  'ファイル名List配列の初期化
  ReDim vntRead(3, clngLower To 1)
  'ファイル名Listの作成
  GetFilePath vntRead, _
        objFSO.GetFolder(strFolderPath), _
        strBasePattan, strExtePattan, _
        regName, objFSO, lngSubDir
  
  'ファイル名List配列の先頭値が""で無いなら
  If vntRead(0, clngLower) <> "" Then
    vntFileNames = Application.WorksheetFunction.Transpose(vntRead)
    GetFilesList = True
  End If
  
Wayout:
  
  Set regName = Nothing

End Function

Private Sub GetFilePath(vntFileNames As Variant, _
            objFolder As Object, _
            strBasePattan As String, _
            strExtePattan As String, _
            regName As Object, _
            objFSO As Object, _
            ByVal lngSubDir As Long)

  Dim lngLower As Long
  Dim i As Long
  Dim objFile As Object
  Dim objSubDir As Object
  Dim strDirPath As String
  Dim strName As String
  
  'List配列の最小添え字を取得
  lngLower = LBound(vntFileNames, 2)
  'List配列に値が有る場合
  If vntFileNames(0, lngLower) <> "" Then
    'カウンタをList配列の最大添え字に設定
    i = UBound(vntFileNames, 2)
  Else
    'カウンタをList配列の最小添え字以下に設定
    i = lngLower - 1
  End If
  
  '現在のFoderPathを取得
  strDirPath = objFolder.Path & "\"
  'ファイル名を列挙
  For Each objFile In objFolder.Files
    strName = objFile.Name
    With regName
      '拡張子を比較
      .Pattern = strExtePattan
      If .TEST(objFSO.GetExtensionName(strName)) Then
        'Base名を比較
        .Pattern = strBasePattan
        If .TEST(objFSO.GetBaseName(strName)) Then
          'カウンタをインクリメント
          i = i + 1
          'List配列を拡張
          ReDim Preserve vntFileNames(3, lngLower To i)
          'Path、ファイル名を代入
          vntFileNames(0, i) = strName
          vntFileNames(1, i) = objFile.Datecreated
          vntFileNames(2, i) = objFile.Size
          vntFileNames(3, i) = objFile.Path
        End If
      End If
    End With
  Next objFile

  Set objFile = Nothing
  
  '指定階層数になるまで再帰、lngSubDir < 0 の時は最終階層まで再帰
  If lngSubDir > 0 Or lngSubDir < 0 Then
    '階層指定を一つ下げる
    lngSubDir = lngSubDir - 1
    'SubFolderを探索
    For Each objSubDir In objFolder.SubFolders
      GetFilePath vntFileNames, objSubDir, _
            strBasePattan, strExtePattan, _
            regName, objFSO, lngSubDir
    Next objSubDir
  End If
  
  Set objSubDir = Nothing
  
End Sub
1 hits

【62373】ファイル一覧を作りましたが ざき 09/7/15(水) 11:51 質問
【62374】Re:ファイル一覧を作りましたが つん 09/7/15(水) 13:01 発言
【62386】Re:ファイル一覧を作りましたが ざき 09/7/16(木) 8:19 お礼
【62380】Re:ファイル一覧を作りましたが Hirofumi 09/7/15(水) 16:28 回答
【62381】Re:ファイル一覧を作りましたが Hirofumi 09/7/15(水) 16:33 回答
【62387】Re:ファイル一覧を作りましたが ざき 09/7/16(木) 8:24 お礼
【62388】Re:ファイル一覧を作りましたが Hirofumi 09/7/16(木) 10:39 回答
【62457】Re:ファイル一覧を作りましたが ざき 09/7/22(水) 20:35 お礼

19778 / 76732 ←次へ | 前へ→
ページ:  ┃  記事番号:
2610219
(SS)C-BOARD v3.8 is Free