access vba フォルダ内ファイル名エクセル出力フォーム

access vbaでフォルダ内のファイル名一覧を表示、エクセル出力も出来るフォームの紹介。

フォーム画面

画面解像度1280×1024以上

①フォルダ選択

②ファイル名表示

③エクセル出力

④終了

使用手順

①フォルダ選択

①フォルダ選択右のテキストボックスをクリックするとファイルダイアログが表示されるのでファイル名表示をしたいフォルダを選択しOKボタンをクリックする。

コード

参照設定　Micrsoft Office 1※.0 Object Library

Function GetFolder()
‘選択したフォルダ名を格納する変数
Dim SelF As String
With Application.FileDialog(msoFileDialogFolderPicker)
‘ダイアログボックスを表示
If .Show = True Then
‘OKボタンが押された場合、フォルダ名を取得する
SelF = .SelectedItems(1)
‘メッセージを表示
End IfEnd With
If Right$(SelF, 1) <> “\” Then SelF = SelF & “\”
フォルダ選択 = SelF
End Function
—————————————————————————–
Private Sub フォルダ選択_Click()
‘フォルダダイアログ表示呼び出し
フォルダ選択 = “”
Call GetFolder
End Sub

②ファイル名表示

②ファイル名表示ボタンをクリックするとファイル名一覧が画面に表示される。

ファイル名は最大200までしか表示されません。

200以上ある場合はエクセル出力を使用してください（最大1048576)

コード

Private Sub ファイル名表示_Click()
‘変数宣言
Dim I As Long
Dim FOL As Object
Dim f As Object
Dim PATH As String
‘テキストボックス非表示
For L = 1 To 200: Me(“T” & L).Visible = False: Next L
PATH = フォルダ選択
‘ファイル名取得
Set FOL = CreateObject(“Scripting.FileSystemObject”)
FILE数 = FOL.GetFolder(PATH).Files.Count
‘テキストボックスにファイル名表示
For Each f In FOL.GetFolder(PATH).Files
I = I + 1
If I > 200 Then MsgBox (“200以上は表示されません “): Exit Sub
Me(“T” & I).Visible = True
Me(“T” & I) = f.Name
Next f
‘FOL 開放
Set FOL = Nothing
End Sub

③エクセル出力

③エクセル出力釦をクリックするとエクセルにファイル名一覧が表示される。

②のファイル名表示をしなくても出力可能です。

コード

Private Sub エクセル出力_Click()
‘参照設定を使わないエクセルの変数宣言
Dim xlApp As Object
Dim xlBook As Object
Dim xlSheet As Object
‘エクセルの新規BOOK起動する
Set xlApp = CreateObject(“Excel.Application”)
Set xlBook = xlApp.Workbooks.Add
Set xlSheet = xlBook.Worksheets(1)
xlApp.Visible = True
‘列幅指定
xlBook.Worksheets(1).Columns(“A:A”).ColumnWidth = 5
xlBook.Worksheets(1).Columns(“B:B”).ColumnWidth = 50
‘変数宣言
Dim I As Long
Dim FOL As Object
Dim f As Object
Dim PATH As String
‘フォルダ内ファイル名取得
PATH = フォルダ選択 & “\”
Set FOL = CreateObject(“Scripting.FileSystemObject”)
FILE数 = FOL.GetFolder(PATH).Files.Count
‘セルにファイル名書き出し
For Each f In FSO.GetFolder(PATH).Files
I = I + 1
xlBook.Worksheets(1).Cells(I, 1) = I
xlBook.Worksheets(1).Cells(I, 2) = f.Name
Next f
Set FSO = Nothing
‘罫線
xlBook.Worksheets(1).Range(xlBook.Worksheets(1).Cells(1,1),xlBook.Worksheets(1).Cells(I, 2)).Borders.LineStyle = 1
End Sub