'***************************************************************************************************
' Excel文書プロパティ一覧作成 Module1(Module)
'
' 作成者:井上治 URL:https://www.ne.jp/asahi/excel/inoue/ [Excelでお仕事!]
'***************************************************************************************************
' [参照設定]
' ・Microsoft Scripting Runtime
'***************************************************************************************************
' 変更日付 Rev 変更履歴内容---------------------------------------------------------------------->
' 07/10/06(1.0.0)新規作成
' 14/11/03(1.1.0)「フォルダの参照」ダイアログ変更
' 20/02/21(1.1.1)*.xlsm化、記述整理等
' 20/03/04(1.1.2)ダイアログを表示をmodFolderPicker1からmodFolderPicker2に変更
'***************************************************************************************************
Option Explicit
'***************************************************************************************************
' ■■■ シート側からの呼び出し処理 ■■■
'***************************************************************************************************
'* 処理名 ：GET_BuiltinDocumentProperties
'* 機能 ：Excel文書プロパティ一覧作成
'---------------------------------------------------------------------------------------------------
'* 返り値 ：(なし)
'* 引数 ：(なし)
'---------------------------------------------------------------------------------------------------
'* 作成日 ：2007年10月06日
'* 作成者 ：井上 治
'* 更新日 ：2020年03月04日
'* 更新者 ：井上 治
'* 機能説明：
'* 注意事項：
'***************************************************************************************************
Sub GET_BuiltinDocumentProperties()
'-----------------------------------------------------------------------------------------------
Dim xlApp As Application ' Excel.Application
Dim objShDst As Worksheet ' 一覧表示シート
Dim objFso As FileSystemObject ' FileSystemObject
Dim objFolder As Folder ' フォルダ
Dim lngRow As Long ' 行
Dim lngPos As Long ' パス名の現在フォルダ位置
Dim cntKensu As Long ' 件数カウンタ
Dim strPathname As String ' 指定フォルダ名
' 一覧を作成するシート(本ブックのシート)
Set objShDst = ThisWorkbook.Worksheets(1)
' 「フォルダの参照」よりフォルダ名の取得(modFolderPicker2に収容)
strPathname = modFolderPicker2.FolderDialog("フォルダを指定して下さい", True)
If strPathname = "" Then Exit Sub
lngPos = Len(strPathname) + 1
Set xlApp = Application
' 画面描画停止等
With xlApp
.ScreenUpdating = False ' 画面描画停止
.EnableEvents = False ' イベント動作停止
.EnableCancelKey = xlErrorHandler ' Escキーでエラートラップする
.Cursor = xlWait ' カーソルを砂時計にする
End With
' 一覧シートの初期化
With objShDst
' フィルタ解除
If .FilterMode Then .ShowAllData
.Rows("2:" & .Rows.Count).ClearContents
End With
Set objFso = New FileSystemObject
cntKensu = 0
lngRow = 1
'---------------------------------------------------------------------------
Set objFolder = objFso.GetFolder(strPathname)
' 指定フォルダ配下のExcelブックを順次処理
Call GP_PROC_for_PATH(xlApp, _
objShDst, _
objFso, _
lngRow, _
cntKensu, _
lngPos, _
objFolder, _
strPathname)
'---------------------------------------------------------------------------
' 処理終了
With xlApp
.StatusBar = False ' ステータスバーを復帰
.EnableEvents = True ' イベント動作再開
.EnableCancelKey = xlInterrupt ' Escキー動作を戻す
.Cursor = xlDefault ' カーソルをデフォルトにする
.ScreenUpdating = True ' 画面描画再開
End With
Set objFso = Nothing
Set xlApp = Nothing
End Sub
'***************************************************************************************************
' ■■■ サブ処理(Private) ■■■
'***************************************************************************************************
'* 処理名 ：GP_PROC_for_PATH
'* 機能 ：１フォルダ単位の処理(再帰動作)
'---------------------------------------------------------------------------------------------------
'* 返り値 ：(なし)
'* 引数 ：Arg1 = Excel.Application(Object)
'* Arg2 = 一覧表示シート(Object)
'* Arg3 = FileSystemObject(Object)
'* Arg4 = 行(Long) ※Ref参照
'* Arg5 = 件数カウンタ(Long) ※Ref参照
'* Arg6 = パス名の現在フォルダ位置(Long) ※Ref参照
'* Arg7 = フォルダ(Object)
'* Arg8 = パス名(String)
'---------------------------------------------------------------------------------------------------
'* 作成日 ：2007年10月06日
'* 作成者 ：井上 治
'* 更新日 ：2020年02月21日
'* 更新者 ：井上 治
'* 機能説明：
'* 注意事項：
'***************************************************************************************************
Private Sub GP_PROC_for_PATH(ByRef xlApp As Application, _
ByRef objShDst As Worksheet, _
ByRef objFso As FileSystemObject, _
ByRef lngRow As Long, _
ByRef cntKensu As Long, _
ByRef lngPos As Long, _
ByVal objFolder As Folder, _
ByVal strPathname As String)
'-----------------------------------------------------------------------------------------------
Dim objFolder2 As Folder ' サブフォルダ
Dim objFile As File ' ファイル
Dim strFilename As String ' ファイル名
Dim strExtU As String ' 拡張子(大文字)
xlApp.StatusBar = Mid(strPathname, lngPos) & " 処理中．．．．"
'---------------------------------------------------------------------------
' 配下のサブフォルダの処理
For Each objFolder2 In objFolder.SubFolders
' １フォルダ単位の処理(再帰呼び出し)
Call GP_PROC_for_PATH(xlApp, _
objShDst, _
objFso, _
lngRow, _
cntKensu, _
lngPos, _
objFolder2, _
objFso.BuildPath(strPathname, objFolder2.Name))
Next objFolder2
'---------------------------------------------------------------------------
' 本フォルダ内の各Excelブックを処理
For Each objFile In objFolder.Files
strFilename = objFile.Name
strExtU = UCase(objFso.GetExtensionName(strFilename))
' 拡張子にて処理対象か判断
If ((strExtU = "XLS") Or _
(strExtU = "XLSX") Or _
(strExtU = "XLSM") Or _
(strExtU = "XLSB") Or _
(strExtU = "XLA") Or _
(strExtU = "XLAM") Or _
(strExtU = "XLT") Or _
(strExtU = "XLTX") Or _
(strExtU = "XLTM")) Then
' １ファイル単位の処理
Call GP_PROC_for_FILE(objShDst, _
objFso, _
lngRow, _
cntKensu, _
lngPos, _
strPathname, _
strFilename)
End If
Next objFile
End Sub
'***************************************************************************************************
'* 処理名 ：GP_PROC_for_FILE
'* 機能 ：１ファイル単位の処理
'---------------------------------------------------------------------------------------------------
'* 返り値 ：(なし)
'* 引数 ：Arg1 = 一覧表示シート(Object)
'* Arg2 = FileSystemObject(Object)
'* Arg3 = 行(Long) ※Ref参照
'* Arg4 = 件数カウンタ(Long) ※Ref参照
'* Arg5 = パス名の現在フォルダ位置(Long) ※Ref参照
'* Arg6 = フォルダ(Object)
'* Arg7 = パス名(String)
'---------------------------------------------------------------------------------------------------
'* 作成日 ：2007年10月06日
'* 作成者 ：井上 治
'* 更新日 ：2020年02月21日
'* 更新者 ：井上 治
'* 機能説明：
'* 注意事項：
'***************************************************************************************************
Private Sub GP_PROC_for_FILE(ByRef objShDst As Worksheet, _
ByRef objFso As FileSystemObject, _
ByRef lngRow As Long, _
ByRef cntKensu As Long, _
ByRef POS As Long, _
ByVal strPathname As String, _
ByVal strFilename As String)
'-----------------------------------------------------------------------------------------------
Dim objWBK As Workbook ' ワークブック
Dim objP As DocumentProperty ' 文書プロパティ
Dim strFullname As String ' フルパス名
Dim strKoumoku As String ' 項目名
Dim strValue As String ' 値
' ワークブックを開く(読み取り専用)
cntKensu = cntKensu + 1 ' 文書カウント
strFullname = objFso.BuildPath(strPathname, strFilename)
On Error Resume Next
Set objWBK = Workbooks.Open(Filename:=strFullname, UpdateLinks:=False, ReadOnly:=True)
' Open失敗か
If Err.Number <> 0 Then
' ブックが開けない場合の処置
With objShDst
lngRow = lngRow + 1
.Cells(lngRow, 1).Value = cntKensu
.Cells(lngRow, 2).Value = Mid(strPathname, POS)
.Cells(lngRow, 3).Value = strFilename
.Cells(lngRow, 4).Value = "*ERR" & Format(Err.Number, "000")
.Cells(lngRow, 5).Value = Err.Description
End With
On Error GoTo 0
Exit Sub
End If
On Error GoTo 0
With objShDst
On Error Resume Next
For Each objP In objWBK.BuiltinDocumentProperties
strKoumoku = objP.Name
strValue = objP.Value
' 件数、日付関連等と値がブランクのプロパティを除外
' (この判断は必要に応じて変更して下さい)
If ((strKoumoku <> "Last print date") And _
(strKoumoku <> "Creation date") And _
(strKoumoku <> "Last save time") And _
(strKoumoku <> "Total editing time") And _
(strKoumoku <> "Application name") And _
(Left(strKoumoku, 9) <> "Number of") And _
(strKoumoku <> "Security") And _
(strKoumoku <> "Hyperlink base") And _
(strValue <> "")) Then
lngRow = lngRow + 1
.Cells(lngRow, 1).Value = cntKensu
.Cells(lngRow, 2).Value = Mid(objWBK.Path, POS)
.Cells(lngRow, 3).Value = objWBK.Name
.Cells(lngRow, 4).Value = strKoumoku
.Cells(lngRow, 5).Value = objP.Value
End If
Next objP
On Error GoTo 0
End With
' 開いたブックをClose
objWBK.Saved = True
objWBK.Close SaveChanges:=False
End Sub
'----------------------------------------<< End of Source >>----------------------------------------
