Option Compare Database
Option Explicit
Dim modLngObjNumber As Long
Dim modFolderLevel As Integer
Sub prcStoreFilesInfoToTableA()
Dim fso As FileSystemObject
Dim dbs As DAO.Database
Dim rst As DAO.Recordset
Dim strFolderPath As String
Dim strSQL As String
' 探索するフォルダのパス
strFolderPath = "C:\TargetFolder"
'入力テーブル初期化
DoCmd.SetWarnings False
strSQL = "DELETE t.* FROM [t01a_test] AS t;"
DoCmd.RunSQL strSQL
DoCmd.SetWarnings True
'Object準備
Set fso = New FileSystemObject
Set dbs = CurrentDb
Set rst = dbs.OpenRecordset("t01a_test", dbOpenTable)
' フォルダ階層の初期化（最初のフォルダを階層0とする）
modFolderLevel = 0
'ファイル番号初期化
modLngObjNumber = 1
' フォルダおよびサブフォルダ内のファイル情報を取得しテーブルに格納
Call prcRecursiveFiles(fso.GetFolder(strFolderPath), fso, rst, modFolderLevel)
' オブジェクトを解放
rst.Close
Set rst = Nothing
Set dbs = Nothing
Set fso = Nothing
'ステータスクリア
SysCmd acSysCmdClearStatus
MsgBox "処理終了"
End Sub
' 再帰的にファイル情報を取得するためのサブルーチン
Sub prcRecursiveFiles(folder As folder, fso As FileSystemObject, rst As DAO.Recordset, ByVal level As Integer)
' ステータスバー表示単位
Const LNG_COUNTSTEP As Long = 20
'フォルダ関連
Dim subFolder As folder
Dim strFolderName As String
Dim strFolderPath As String
Dim strFolderSize As String
Dim strFolderUpdDate As String
'ファイル関連
Dim file As file
Dim strFileName As String
Dim strExtension As String
Dim strFilePath As String
Dim strFileSize As String
Dim strFileUpdDate As String
'その他
Dim strObjType As String
Dim blnContinue As Boolean
On Error GoTo ErrHdl
' フォルダ内の全てのファイルの情報を処理
For Each file In folder.Files
'初期化（エラーで値取得できないケースがあるため、いったん初期化）
strFileName = ""
strExtension = ""
strFilePath = ""
strFileSize = ""
strFileUpdDate = ""
strObjType = ""
'値取得
strFileName = file.Name
strExtension = fncStrGetFileExtension(strFileName)
strFilePath = file.Path
strFileSize = Format(file.Size / 1024 / 1024, "#,##0") 'MBで取得
strFileUpdDate = file.DateLastModified
strObjType = "ファイル"
With rst
.AddNew
!obj番号 = modLngObjNumber
!フォルダ階層 = level
!obj名 = strFileName
!拡張子 = strExtension
!objタイプ = strObjType
!フルパス = strFilePath
!objサイズ = strFileSize
!更新日 = strFileUpdDate
.Update
End With
'検出objカウントアップ
modLngObjNumber = modLngObjNumber + 1
'進捗表示
If modLngObjNumber Mod LNG_COUNTSTEP = 0 Then
Call prcStatusUpdate
End If
With rst
.AddNew
!obj番号 = modLngObjNumber
!フォルダ階層 = level
!obj名 = strFileName
!拡張子 = strExtension
!objタイプ = strObjType
!フルパス = strFilePath
!objサイズ = strFileSize
!更新日 = strFileUpdDate
.Update
End With
Next file
' サブフォルダを再帰的に処理
For Each subFolder In folder.SubFolders
'初期化（エラーで値取得できないケースがあるため、いったん初期化）
strFolderName = ""
strFolderPath = ""
strFolderSize = ""
strFolderUpdDate = ""
strObjType = ""
'値取得
strFolderName = subFolder.Name
strFolderPath = subFolder.Path
strFolderUpdDate = subFolder.DateLastModified
strObjType = "フォルダ"
strFolderSize = Format(subFolder.Size / 1024 / 1024, "#,##0") 'MBで取得
With rst
.AddNew
!obj番号 = modLngObjNumber
!obj名 = strFolderName
!フォルダ階層 = level
!objタイプ = strObjType
!フルパス = strFolderPath
!更新日 = strFolderUpdDate
!objサイズ = strFolderSize
.Update
End With
'検出objカウントアップ
modLngObjNumber = modLngObjNumber + 1
'進捗表示
If modLngObjNumber Mod LNG_COUNTSTEP = 0 Then
Call prcStatusUpdate
End If
Call prcRecursiveFiles(subFolder, fso, rst, level - 1)
Next subFolder
Exit Sub
ErrHdl:
Select Case Err.Number
Case Else
Debug.Print modLngObjNumber & ":" & Err.Number & "/" & Err.Description
Stop
End Select
End Sub
Function fncArrExcelWorksheetNames(strFilePath As String) As String()
Dim cn As ADODB.Connection
Dim rs As ADODB.Recordset
Dim strCon As String
Dim arrSheetNames() As String
Dim i As Integer
' 接続文字列をファイル形式に基づいて設定
Select Case LCase(Right(strFilePath, Len(strFilePath) - InStrRev(strFilePath, ".")))
Case "xls"
' Excel 97-2003 ファイル形式
strCon = "Provider=Microsoft.Jet.OLEDB.4.0;Data Source=" & strFilePath & ";Extended Properties=""Excel 8.0;HDR=NO;"""
Case "xlsx", "xlsm"
' Excel 2007 以降のファイル形式
strCon = "Provider=Microsoft.ACE.OLEDB.12.0;Data Source=" & strFilePath & ";Extended Properties=""Excel 12.0 Xml;HDR=NO;"""
End Select
' ADO接続オブジェクトを作成
Set cn = New ADODB.Connection
cn.Open strCon
' ワークシート名を取得
Set rs = cn.OpenSchema(adSchemaTables)
i = 0
Do While Not rs.EOF
ReDim Preserve arrSheetNames(i)
arrSheetNames(i) = Replace(rs.Fields("TABLE_NAME").Value, "$", "")
i = i + 1
rs.MoveNext
Loop
rs.Close
' オブジェクトを閉じて解放
Set rs = Nothing
cn.Close
Set cn = Nothing
fncArrExcelWorksheetNames = arrSheetNames
End Function
' ----------------------------------------------------------------
' 機能概要:ステータスバー更新
' ----------------------------------------------------------------
Sub prcStatusUpdate()
Dim strText As String
strText = "オブジェクト取得中・・・ " & modLngObjNumber & " obj"
SysCmd acSysCmdSetStatus, strText
DoEvents
End Sub
' ----------------------------------------------------------------
' 機能概要: 拡張子がついたファイル名から拡張子の部分を返す
' 引数:strFileName - ファイル名（拡張子含む）
' 戻り値:String - ファイルの拡張子
' ----------------------------------------------------------------
Function fncStrGetFileExtension(strFileName As String) As String
Dim intDotPosition As Integer
Dim strExtension As String
' ファイル名から最後のドットの位置を見つける
intDotPosition = InStrRev(strFileName, ".")
' ドットが見つかった場合、拡張子を抽出
If intDotPosition > 0 Then
strExtension = Mid(strFileName, intDotPosition + 1)
fncStrGetFileExtension = strExtension
End If
End Function
' ----------------------------------------------------------------
' 機能概要: 書き込み可能フォルダか判定する
' 引数:strFolderPath - 判定するフォルダパス
' 戻り値:Boolean - True=書き込み可 ,False=書き込み不可
' ----------------------------------------------------------------
Function fncBlnFolderWritable(fso As FileSystemObject, strFolderPath As String) As Boolean
' 変数の宣言
Dim strTempFilePath As String
Dim fileTest As TextStream
' 一時ファイルのパスを設定
strTempFilePath = strFolderPath & "\tempfile.tmp"
On Error Resume Next ' エラーハンドリングを開始
' 一時ファイルの作成を試みる
Set fileTest = fso.CreateTextFile(strTempFilePath, True)
' エラーチェック
If Err.Number = 0 Then
fileTest.Close ' テストファイルを閉じる
fso.DeleteFile strTempFilePath ' テストファイルを削除
fncBlnFolderWritable = True
Else
fncBlnFolderWritable = False
End If
On Error GoTo 0 ' エラーハンドリングを終了
End Function
Access
コメント