Excel2000 VBA フォルダの参照ダイアログボックスを表示し、フォルダフルパスを取得する

Excel2000 VBA フォルダの参照ダイアログボックスを表示し、フォルダフルパスを取得する

Sub フォルダ選択とファイル一覧()
'
'DLファイル名と日時一覧
'
Dim buf, file_name, file_date, MB As String
Dim cnt, i, file_size As Long
Dim Path, Path2 As String
   
On Error Resume Next
    Dim ShellApp As Object
    Dim oFolder As Object
  
    Set ShellApp = CreateObject("Shell.Application")
    Set oFolder = ShellApp.BrowseForFolder(0, "フォルダの選択", 1)

    Path = oFolder.items.Item.Path & "\" '"選択フォルダのフルパス表示"

syori:
    If Err.Number = 91 Then MsgBox "キャンセルかフォルダ選択エラーです"
  
   
'newBOOK作成
   Workbooks.Add
    Worksheets("sheet1").Select

'Const Path As String = Val(Path2)
buf = dir(Path & "*.*", vbDirectory)
 Do While buf <> ""
        cnt = cnt + 1
        If FileLen(Path & buf) = 0 Then Cells(cnt + 1, "A") = "フォルダ  " & buf Else Cells(cnt + 1, "A") = buf
       
        file_date = FileDateTime(Path & buf)
        file_size = FileLen(Path & buf)
        'Cells(cnt + 1, "A") = file_name
        Cells(cnt + 1, "B") = Int(file_size / 1024) & "KB"
        Cells(cnt + 1, "C") = file_date
        buf = dir()

Loop
'項目名設定
    Range("A1") = "ファイル、フォルダ名    ファイル数: " & cnt
    Range("B1") = "ファイルサイズ（KB）"
    Range("C1") = "日時"
'セル幅を整える
    Columns("A").Select
    Selection.ColumnWidth = 56
    Columns("B").Select
    Selection.ColumnWidth = 16
    Columns("C").Select
    Selection.ColumnWidth = 16
'終了処理
    Range("A2").Select
    Set ShellApp = Nothing
    Set oFolder = Nothing
End Sub

---

 

Sub フォルダ選択()
'
'フォルダ参照ダイアログボックスを表示
'
On Error GoTo syori
    Dim ShellApp As Object
    Dim oFolder As Object
   
    Set ShellApp = CreateObject("Shell.Application")
    Set oFolder = ShellApp.BrowseForFolder(0, "フォルダの選択", 1)

    MsgBox oFolder.items.Item.path, vbOKOnly, "選択フォルダのフルパス表示"

syori:
    If Err.Number = 91 Then MsgBox "キャンセルかフォルダ選択エラーです"
   
    Set ShellApp = Nothing
    Set oFolder = Nothing

End Sub

タグ：Excel2000 VBA