Excel VBA ファイル操作

Excel VBA のトップに戻る
Excel VBA 目次

索引

ファイル名一覧(マクロと同じフォルダの全てのファイル)

 このExcelをダウンロードできます。→ListFileNamesVBA02.xls


Option Explicit

'01:2012/03/30:新規作成

   Dim ファイル名 As String
   Dim 処理行 As Integer
   Dim 現在のパス As String
   Dim カウンタ As Integer
   Dim ファイルシステムオブジェクト As Object          ' FileSystemObject
   Dim フォルダ As Object
   Dim ファイル As Object
   Dim 開始日時 As Variant
   Dim 終了日時 As Variant


Sub ファイル名抽出()

   開始日時 = Now                ' 開始時刻を変数に格納します。

   カウンタ = 1
   ThisWorkbook.Worksheets("Sheet1").Activate

   現在のパス = ThisWorkbook.Path

   Set ファイルシステムオブジェクト = CreateObject("Scripting.FileSystemObject")

   Set フォルダ = ファイルシステムオブジェクト.GetFolder(現在のパス)

   '★Excelの存在するフォルダの全てのファイルを対象
   For Each ファイル In フォルダ.Files

      ファイル名 = ファイル.Path
      カウンタ = カウンタ + 1
      Range("A1").Cells(カウンタ, 1).Value = Dir(ファイル名)

   Next '★ファイル

   Set ファイルシステムオブジェクト = Nothing

   終了日時 = Now
   MsgBox "処理を終了しました。" & vbNewLine & "処理時間は、" _
   & Format(終了日時 - 開始日時, "hh時間nn分ss秒") & " でした。"

End Sub


この種類の目次に戻る↑ 索引へ↓ トップページに戻る


ブック名シート名一覧(マクロと同じフォルダの全て)

 この VBA を登録したExcelファイルと同じフォルダにある、全てのExcelファイルの「ファイル名」とその「シート名」を取得します。
 特定のExcelファイルのシート名を取得する場合は、「Book名とSheet名・シート数を取得」を使って下さい。


Option Explicit
Option Base 1


Sub 対象ExcelBook情報の取得()

   Dim 対象シート As Worksheet
   Dim シート数 As Integer
   Dim シート名(100, 1) As String
   Dim 現在のパス As String
   Dim カウンタ As Integer
   Dim ファイルシステムオブジェクト As Object          ' FileSystemObject
   Dim フォルダ As Object
   Dim ファイル As Object
   Dim 開始日時 As Variant
   Dim 終了日時 As Variant
   Dim 処理Book As Workbook
   Dim 書込み行 As Integer
   Dim ファイル名 As String


   開始日時 = Now                ' 開始時刻を変数に格納します。

   現在のパス = ThisWorkbook.Path

   Set ファイルシステムオブジェクト = CreateObject("Scripting.FileSystemObject")

   Set フォルダ = ファイルシステムオブジェクト.GetFolder(現在のパス)

   書込み行 = 1
   '★自身のExcelの存在するフォルダの全てのファイルを対象
   For Each ファイル In フォルダ.Files

      ファイル名 = ファイル.Path
      Erase シート名

      If LCase(Mid(ファイル名, InStrRev(ファイル名, ".") + 1, 3)) = "xls" Then

         If Dir(ファイル名) <> ThisWorkbook.Name Then '自分自身は対象外

            カウンタ = カウンタ + 1

            Set 処理Book = Workbooks.Open(Filename:=ファイル名) 'ブックを開く

             ' シート名を全て取得

             処理Book.Activate

             ' 作業中のブックのすべてのワークシートの名前を、For〜Nextで配列に登録します。
             シート数 = 0
             For Each 対象シート In Worksheets
                 シート数 = シート数 + 1
                 シート名(シート数, 1) = 対象シート.Name
             Next

             処理Book.Close savechanges:=False           '保存せずにブックを閉じる

            Set 処理Book = Nothing
             ' 結果表示

            ThisWorkbook.Worksheets("sheet1").Activate
            Range("A2").Cells(書込み行, 1).Value = Dir(ファイル名)
            Range("B2").Cells(書込み行, 1).Resize(シート数, 1).Value = シート名
            書込み行 = 書込み行 + シート数
         End If
     End If

   Next '★ファイル

   Set フォルダ = Nothing
   Set ファイルシステムオブジェクト = Nothing

   終了日時 = Now
   MsgBox "処理を終了しました。" & vbNewLine & "処理時間は、" _
   & Format(終了日時 - 開始日時, "hh時間nn分ss秒") & " でした。"
End Sub

この種類の目次に戻る↑ 索引へ↓ トップページに戻る


ファイルリスト一覧(指定フォルダ以下のすべての階層のファイル)

 Excel 2007 から、FileSearch が使えなくなりました。

Application.FileSearch
実行時エラー'445':
オブジェクトはこの動作をサポートしていません。

 となってしまいます。
 うまい対応方法が無いかと、ググっていて見つけました。

くろっぽいねこ さんの、 2007/01/26(金) の書き込みです。
http://park7.wakwak.com/~efc21/cgi-bin/exqalounge.cgi?print+200701/07010088.txt

 上に公開していただいているマクロは、
 指定フォルダについて、サブフォルダ内のファイルを含めた、全ファイルリストを作成するものです。
 配列ファイルリスト内にファイル名(フルパス)を抽出するので、FileSearchの代替に使えます。

 下は、くろっぽいねこ さんのマクロに、私が、拡張子を限定できるように、手を加えたものです。

 使い方:拡張子で絞り込みたいときはシートに拡張子を指定します。全てのファイルを対象とする場合はセルを空白にします。
 実行するとファイルを選択するダイアログが表示されるので、対象のフォルダで、何れでもよいのでファイルを選択します。このファイルの保存されているフォルダが対象フォルダになります。

 このExcelをダウンロードできます。→FileList.xls

 Dir 関数を使う方法も参照下さい。


Option Explicit
Option Base 1

    Dim フルパス As String
    Dim ファイルリスト() As String
    Dim 項目数 As Integer

Sub ファイルリスト一覧()

    Dim フォルダパス As String
    Dim ファイルタイプ As String
    Dim エラーカウント As Integer
    Dim 拡張子 As String
    Dim メッセージ As String
    Dim 開始日時 As Variant
    Dim 終了日時 As Variant
    Dim 既存データ As Integer

    Dim 追加シート名初期 As String
    Dim 追加シート名 As String
    Dim 重複 As Integer
    Dim シート As Worksheet
    Dim シート数 As Integer

    追加シート名初期 = "ファイルリスト"
    追加シート名 = 追加シート名初期

    For 重複 = 1 To 100
    ' 100枚まで追加しても重複しないように追番を設定します。
        For Each シート In Worksheets
            If シート.Name = 追加シート名 Then
                追加シート名 = 追加シート名初期 & "(" & 重複 & ")"
            End If
        Next シート
    Next 重複
    シート数 = Worksheets.Count
    Worksheets("テンプレート").Copy After:=Worksheets(シート数)
    ActiveSheet.Name = 追加シート名


    ThisWorkbook.Worksheets("スタート").Activate
        
    ファイルタイプ = Trim(Range("A2").Value)
    If ファイルタイプ = "" Then
        拡張子 = "*"
    Else
        拡張子 = Right(ファイルタイプ, Len(ファイルタイプ) - InStrRev(ファイルタイプ, "."))
    End If

    '対象フォルダの指定
    '[ファイルを開く]ダイアログボックスで、ファイルを指定して、パスを取得
    フォルダパス = Application.GetOpenFilename(ファイルタイプ)

    '[ファイルを開く]で「キャンセル」した場合は、処理を終了
    If フォルダパス = "False" Then End

    開始日時 = Now                ' 開始時刻を変数に格納します。

    'フォルダパスから、後ろのファイル名の部分を削除して、フォルダ・パスに変更
    フォルダパス = Left(フォルダパス, InStrRev(フォルダパス, "\"))

    'Excelのシート構成が違ってもエラーで止まらないようにする。
     On Error GoTo エラー表示

    項目数 = 9
    ReDim ファイルリスト(項目数, 1)

    Call ファイル検索(フォルダパス, ファイルリスト, 拡張子)

    Worksheets(追加シート名).Activate

    Range("A3").Resize(UBound(ファイルリスト, 2), 項目数) _
    = WorksheetFunction.Transpose(ファイルリスト)

    Range("A3").Select

    終了日時 = Now
    MsgBox "処理時間は、" _
    & Format(終了日時 - 開始日時, "hh時間nn分ss秒") & " でした。"

    Exit Sub  'エラー以外は、以下のラベル部分を実行させないためのテクニック。

エラー表示:

    エラーカウント = エラーカウント + 1
    メッセージ = "エラーが発生しました。" & Chr(13) _
    & "フォルダパス= " & フォルダパス & Chr(13) _
    & "フルパス= " & フルパス & Chr(13) _
    & "UBound(ファイルリスト, 2)= " & UBound(ファイルリスト, 2) & Chr(13) _
    & "ActiveWorkbook名= " & ActiveWorkbook.Name & Chr(13) _
    & "エラー番号 " & Str(Err.Number) & Err.Source & _
    " でエラーが発生しました。" & Chr(13) & Err.Description

    MsgBox メッセージ, , "エラー", Err.HelpFile, Err.HelpContext

    ActiveWorkbook.Close False

    If エラーカウント > 5 Then Exit Sub
    Resume Next
End Sub


'★再帰処理でファイル抽出★
Sub ファイル検索(フォルダパス As String, ファイルリスト() As String, 拡張子 As String)

    Dim n0 As Long
    Dim s0 As String
    Dim v0 As Variant
    Dim フォルダ As Object
    Dim o0 As Object
    Dim o1 As Object
    Dim ファイルシステムオブジェクト As Object
    Dim 件数 As Integer

    Set ファイルシステムオブジェクト = CreateObject("Scripting.FileSystemObject")

    If Not ファイルシステムオブジェクト.FolderExists(フォルダパス) Then
        Exit Sub
    End If
    Set フォルダ = ファイルシステムオブジェクト.GetFolder(フォルダパス)
    Set o0 = フォルダ.Files
    For Each o1 In o0
        フルパス = o1.Path
        If Right(フルパス, Len(フルパス) - InStrRev(フルパス, ".")) Like 拡張子 Then
            ファイルリスト(1, UBound(ファイルリスト, 2)) = フルパス
            ファイルリスト(2, UBound(ファイルリスト, 2)) = o1.ParentFolder
            ファイルリスト(3, UBound(ファイルリスト, 2)) = o1.Name
            ファイルリスト(4, UBound(ファイルリスト, 2)) = CStr(o1.Size)
            ファイルリスト(5, UBound(ファイルリスト, 2)) = o1.Type
            ファイルリスト(6, UBound(ファイルリスト, 2)) = o1.DateLastModified
            ファイルリスト(7, UBound(ファイルリスト, 2)) = o1.DateCreated
            ファイルリスト(8, UBound(ファイルリスト, 2)) = o1.DateLastAccessed
            ファイルリスト(9, UBound(ファイルリスト, 2)) = o1.Attributes
            件数 = UBound(ファイルリスト, 2) + 1
            ReDim Preserve ファイルリスト(項目数, 件数)
        End If
    Next

    DoEvents

    Set o0 = フォルダ.SubFolders
    For Each o1 In o0
        If (o1.Attributes And (2 + 4)) = 0 Then
            Call ファイル検索(o1.Path, ファイルリスト, 拡張子)
        End If
    Next
End Sub

 解説:
 UBound 関数は、配列の指定された次元で使用できる、添字の最大値を、長整数型 (Long) の値で返します。
 UBound 関数は、LBound 関数と組み合わせて、配列のサイズを調べるために使います。
 LBound 関数は、配列の添字の最小値を調べるときに使います。
 Array に要素が 1 つしかない場合、UBound は 0 を返します。
 要素が長さゼロの文字列である場合など、Array に要素がない場合、UBound は -1 を返します。

構文:UBound(arrayname[, dimension])
指定項目内容
arrayname必ず指定します。配列変数の名前です。
変数の標準的な名前付け規則に従って指定します。
dimension省略可能です。バリアント型 (内部処理形式 Long の Variant) の値を指定します。
添字の最大値を調べる対象となる配列の次元を示す整数を指定します。
最初の次元なら 1、2 番目の次元なら 2、というように指定します。
引数 dimension を省略すると、1 が指定されたものと見なされます。


この種類の目次に戻る↑ 索引へ↓ トップページに戻る


指定フォルダの全てのExcelファイルのプロパティを出力する

 Excelファイル(Book)の、メニューの、ファイル→(配布準備)→プロパティで、ファイルの作成情報を見たり、設定したりできます。

 官公庁や、企業のパソコンは、通常インストール時に、これらのデフォルト値が登録されています。
 誤って、ファイルが流出したとき、プロパティの内容で、出所が明らかになったりすると困る場合など、前もってプロパティを削除しておくと良いでしょう。

 参考:Office 2003/XP アドイン: 隠しデータの削除 rhdtool.exe
http://www.microsoft.com/downloads/details.aspx?displaylang=ja&FamilyID=144E54ED-D43E-42CA-BC7B-5446D34E5360

 逆に、著作権を主張したい場合には、ここにキチンと書くとよいでしょう。

 ここで紹介するマクロは、指定したフォルダに登録されている、全ての Excelファイルのプロパティを、一覧出力するものです。

 このマクロをダウンロードできます。→BookPropertyVBA02.xls←Excel 2007〜にも対応しました。


Option Explicit
Option Base 1

Sub ExcelBookのファイルの概要を取得()

Dim フォルダパス As String
Dim ブック指定 As Variant
Dim 行 As Integer
Dim 列 As Integer
Dim ファイル As Integer
Dim データ(1000, 65) As Variant
Dim 項目
Dim 項目数 As Integer
Dim 最大項目数 As Integer
Dim 追加シート名初期 As String
Dim 追加シート名 As String
Dim 重複 As Integer
Dim シート As Worksheet
Dim シート数 As Integer
Dim エラーカウント As Integer
Dim メッセージ As String


    ThisWorkbook.Activate

    追加シート名初期 = "Excelプロパティ"
    追加シート名 = 追加シート名初期

    For 重複 = 1 To 100
    ' 100枚まで追加しても重複しないように追番を設定します。
        For Each シート In Worksheets
            If シート.Name = 追加シート名 Then
                追加シート名 = 追加シート名初期 & "(" & 重複 & ")"
            End If
        Next シート
    Next 重複
    シート数 = Worksheets.Count
    Worksheets("テンプレート").Copy After:=Worksheets(シート数)
    ActiveSheet.Name = 追加シート名


    '画面表示を止めて、処理を高速化
    Application.ScreenUpdating = False
    最大項目数 = 0
    '[ファイルを開く]ダイアログボックスで、ファイルを指定して、パスを取得
    フォルダパス = Application.GetOpenFilename("Excelファイル,*.xls")

    '[ファイルを開く]で「キャンセル」した場合は、処理を終了
    If フォルダパス = "False" Then End

    'フォルダパスから、後ろのファイル名の部分を削除して、フォルダ・パスに変更
    フォルダパス = Left(フォルダパス, InStrRev(フォルダパス, "\"))

    'Excelのシート構成が違ってもエラーで止まらないようにする。
     On Error GoTo エラー表示

    '上で指定したフォルダ内の、全てのExcelファイルを対象に検索
    With Application.FileSearch
        .LookIn = フォルダパス
        .Filename = "*.xls"

        If .Execute > 0 Then
            For ファイル = 1 To .FoundFiles.Count
                Workbooks.Open Filename:=.FoundFiles(ファイル), ReadOnly:=True

                データ(ファイル, 1) = ActiveWorkbook.Name
                項目数 = 0
                On Error Resume Next
                For Each 項目 In ActiveWorkbook.BuiltinDocumentProperties
                    項目数 = 項目数 + 1
    '                データ(ファイル, 項目数 * 2) = 項目.Name
                    データ(ファイル, 項目数 + 1) = 項目.Value
                Next

                If 項目数 > 最大項目数 Then 最大項目数 = 項目数

                ActiveWorkbook.Close False
                On Error GoTo 0

            Next ファイル
        End If
    End With

    ThisWorkbook.Worksheets(追加シート名).Activate
    Application.ScreenUpdating = True

    For 行 = 1 To ファイル
        For 列 = 1 To 最大項目数 + 1
            ThisWorkbook.Worksheets(追加シート名).Range("A3").Cells(行, 列) _
            = データ(行, 列)
        Next 列
    Next 行

    Worksheets(追加シート名).Columns("A:Z").AutoFit
    MsgBox "最大項目数 = " & 最大項目数 & Chr(13) & _
    "(最大項目数が30でない場合は、テンプレートを修正して下さい。)"
    Range("A1").Select

Exit Sub  'エラー以外は、以下のラベル部分を実行させないためのテクニック。

エラー表示:

    エラーカウント = エラーカウント + 1
    メッセージ = "エラーが発生しました。" & Chr(13) _
    & "フォルダパス= " & フォルダパス & Chr(13) _
    & "ファイル名= " & ActiveWorkbook.Name & Chr(13) _
    & "エラー番号 " & str(Err.Number) & Err.Source & _
    " でエラーが発生しました。" & Chr(13) & Err.Description

    MsgBox メッセージ, , "エラー", Err.HelpFile, Err.HelpContext

    ActiveWorkbook.Close False

    If エラーカウント > 5 Then Exit Sub
    Resume Next
End Sub

 解説:

 Workbook.BuiltinDocumentProperties プロパティは、指定されたブックにあるすべての組み込みのドキュメント プロパティを表す DocumentProperties コレクションを返します。
 値の取得のみ可能です。

構文
 Workbook オブジェクトを表す変数.BuiltinDocumentProperties

 このプロパティは、すべての組み込みのドキュメント プロパティを返します。
 コレクションの単一のメンバ (DocumentProperty オブジェクト) を返すには、プロパティ名またはコレクションのインデックス (値) を指定した Item メソッドを使用します。

 インデックス値または名前でドキュメント プロパティを指定することができます。

 コンテナ アプリケーションでは、すべての組み込みのドキュメント プロパティに対して値が設定されているわけではありません。
 目的のアプリケーションで組み込みのドキュメント プロパティの値が設定されていない場合、そのドキュメント プロパティに対する Value プロパティを取得するとエラーが発生します。

 Item メソッドは、DocumentProperties コレクションに対する既定のメソッドです。次の 2 つのステートメントでは、同じ結果が得られます。

BuiltinDocumentProperties.Item(1)
BuiltinDocumentProperties(1)

 ユーザー設定のドキュメント プロパティのコレクションを返すには、CustomDocumentProperties プロパティを使います。


 Resume ステートメントは、エラー処理ルーチンの終了後に、プログラムの実行を再開します。

 Resume ステートメントの構文の形式は次のとおりです。
 Resume [0]
 Resume Next
 Resume line

ステートメント内容
Resume [0]エラー処理ルーチンと同じプロシージャ内でエラーが発生した場合、エラーの原因となったステートメントからプログラムの実行が再開されます。
呼び出されたプロシージャ内でエラーが発生した場合、エラー処理ルーチンを含むプロシージャが最後に呼び出したステートメントからプログラムの実行が再開されます。
Resume Nextエラー処理ルーチンと同じプロシージャ内でエラーが発生した場合、エラーの原因となったステートメントの次のステートメントからプログラムの実行が再開されます。
呼び出されたプロシージャ内でエラーが発生した場合、エラー処理ルーチンを含むプロシージャが最後に呼び出したステートメントの次のステートメント、または On Error Resume Next ステートメントからプログラムの実行が再開されます。
Resume line引数 line に指定した行からプログラムの実行が再開されます。
引数 line は必ず指定します。引数 line には行ラベルまたは行番号を指定します。
また、エラー処理ルーチンと同じプロシージャに指定する必要があります。

 エラー処理ルーチン以外の場所で Resume ステートメントを使用すると、エラーが発生します。


この種類の目次に戻る↑ 索引へ↓ トップページに戻る


指定フォルダの全ての Office ファイルのプロパティを出力して、変更する

 こちらで紹介した、PDF ファイルのプロパティ操作の、Office ファイル版です。
 使い方は、PDF 版と同じです。

このマクロをダウンロードできます。→ChangeOfficeProperty1.xls

 Office ファイルのプロパティの取得と変更には、下記で公開されている Dsofile.dll を使います。

 Dsofile.dllのダウンロード
http://support.microsoft.com/kb/q224351/
http://www.microsoft.com/downloads/details.aspx?FamilyId=9BA6FAC6-520B-4A0A-878A-53EC8300C4C2&displaylang=en
 ダウンロードした、DsoFileSetup_KB224351_x86.exe を実行すると、デフォルトでは、C:\DsoFile フォルダを作って、関連ファイルが展開されます。
 このフォルダの中の、Dsofile.dll を、C:\WINDOWS\system32 フォルダにコピーします。

 Dsofile.dllの使い方
 下記に具体的に書かれています。
 Dsofile: 語られざる物語 Tales from the Script
http://technet.microsoft.com/ja-jp/scriptcenter/ff191274.aspx


Option Explicit
Option Base 1

   Dim 行 As Integer
   Dim 列 As Integer
   Dim 最終行 As Integer
   Dim ファイル名 As String
   Dim 入力フォルダ As String
   Dim 入力フルパス As String
   Dim Stime As Variant
   Dim Etime As Variant
   Dim 区分 As String
   Dim objFile As Object
   Dim 拡張子 As String
   Dim ファイル区分 As Integer

Sub Officeプロパティを取得()

   Dim ファイル As Integer
   Dim データ(1, 31) As Variant


    Stime = Now()
   ThisWorkbook.Worksheets("Sheet1").Activate
   ファイル区分 = Range("AD1").Value
   拡張子 = Range("AE1").Cells(ファイル区分, 1).Value
   拡張子 = "*." & 拡張子
   入力フォルダ = Range("A5").Value

   If 区分 = "変更後" Then
      入力フォルダ = 入力フォルダ & "\変更"
   End If

   'シートの既存内容を削除
   最終行 = Cells(ActiveSheet.Rows.Count, 1).End(xlUp).Row 'ファイル名の列で最終行を判定


   If 最終行 >= 11 Then
      Rows("11:" & CStr(最終行)).Delete Shift:=xlUp
   End If

   Set objFile = CreateObject("DSOFile.OleDocumentProperties")

   'Dir 関数を使用して、
    '指定されたフォルダで、見つかった指定拡張子のファイルを開きます。

    Dim ファイル名 As String   'Dirの返り値を一時的に保存

    '初期化
    ファイル名 = Dir(入力フォルダ & "\" & 拡張子, vbDirectory)
    ファイル = 1
'    Stop

    'ファイル名をリストアップ
    While ファイル名 <> ""

      データ(1, 1) = ファイル名
      入力フルパス = 入力フォルダ & "\" & ファイル名

       objFile.Open (入力フルパス)

       ' 文書情報を取得
          
          データ(1, 2) = objFile.SummaryProperties.ApplicationName '(アプリケーション名)

          If Range("C9").Value = True Then
            データ(1, 3) = objFile.SummaryProperties.Author '(作者)

          End If

          If Range("D9").Value = True Then
            データ(1, 4) = objFile.SummaryProperties.ByteCount '(バイト数)
          End If
          If Range("E9").Value = True Then
            データ(1, 5) = objFile.SummaryProperties.Category '(分類)
          End If
          If Range("F9").Value = True Then
            データ(1, 6) = objFile.SummaryProperties.CharacterCount '(文字数)
          End If
          If Range("G9").Value = True Then
            データ(1, 7) = objFile.SummaryProperties.CharacterCountWithSpaces '(スペースを含む文字数)
          End If
          If Range("H9").Value = True Then
            データ(1, 8) = objFile.SummaryProperties.Comments '(コメント)
          End If
          If Range("I9").Value = True Then
            データ(1, 9) = objFile.SummaryProperties.Company '(会社名)
          End If
          If Range("J9").Value = True Then
            データ(1, 10) = objFile.SummaryProperties.DateCreated '(作成日)
          End If
          
          If Range("K9").Value = True Then
            データ(1, 11) = objFile.SummaryProperties.DateLastPrinted '(最終印刷日)
          End If
          If Range("L9").Value = True Then
            データ(1, 12) = objFile.SummaryProperties.DateLastSaved '(最終保存日)
          End If
          If Range("M9").Value = True Then
            データ(1, 13) = objFile.SummaryProperties.HiddenSlideCount '(非表示スライドの数)
          End If
          If Range("N9").Value = True Then
            データ(1, 14) = objFile.SummaryProperties.Keywords '(キーワード)
          End If
          If Range("O9").Value = True Then
            データ(1, 15) = objFile.SummaryProperties.LastSavedBy '(最終保存日)
          End If
          If Range("P9").Value = True Then
            データ(1, 16) = objFile.SummaryProperties.LineCount '(行)
          End If
          If Range("Q9").Value = True Then
            データ(1, 17) = objFile.SummaryProperties.Manager '(マネージャ)
          End If
          If Range("R9").Value = True Then
            データ(1, 18) = objFile.SummaryProperties.MultimediaClipCount '(マルチメディア クリップ)
          End If
          If Range("S9").Value = True Then
            データ(1, 19) = objFile.SummaryProperties.NoteCount '(メモ)
          End If
          If Range("T9").Value = True Then
            データ(1, 20) = objFile.SummaryProperties.PageCount '(ページ数)
          End If
          If Range("U9").Value = True Then
            データ(1, 21) = objFile.SummaryProperties.ParagraphCount '(段落)
          End If
          If Range("V9").Value = True Then
            データ(1, 22) = objFile.SummaryProperties.PresentationFormat '(表現の形式)
          End If
          If Range("W9").Value = True Then
            データ(1, 23) = objFile.SummaryProperties.RevisionNumber '(改訂番号)
          End If
          If Range("X9").Value = True Then
            データ(1, 24) = objFile.SummaryProperties.SharedDocument '(共有文書)
          End If
          If Range("Y9").Value = True Then
            データ(1, 25) = objFile.SummaryProperties.SlideCount '(スライド)
          End If
          If Range("Z9").Value = True Then
            データ(1, 26) = objFile.SummaryProperties.Subject '(サブジェクト)
          End If
          If Range("AA9").Value = True Then
            データ(1, 27) = objFile.SummaryProperties.Template '(テンプレート)
          End If
          If Range("AB9").Value = True Then
            データ(1, 28) = objFile.SummaryProperties.Title '(タイトル)
          End If
          If Range("AC9").Value = True Then
            データ(1, 29) = objFile.SummaryProperties.TotalEditTime '(編集時間)
          End If
          If Range("AD9").Value = True Then
            データ(1, 30) = objFile.SummaryProperties.Version '(バージョン)
          End If
          If Range("AE9").Value = True Then
            データ(1, 31) = objFile.SummaryProperties.WordCount '(単語数)
          End If

         objFile.Close

         Range("A11").Cells(ファイル, 1).Resize(1, 31).Value = データ
         ActiveSheet.Hyperlinks.Add Anchor:=Range("A11").Cells(ファイル, 1), Address:=入力フルパス

        ファイル = ファイル + 1

        ファイル名 = Dir()
    Wend


    objFile.Close
    Set objFile = Nothing

    Etime = Now()
    MsgBox "処理が終了しました。" & Chr(13) & "処理時間は、" _
    & Format(Etime - Stime, "nn分ss秒") & " でした。", vbOKOnly

End Sub

Sub 変更フォルダのプロパティ取得()

   区分 = "変更後"
   Call Officeプロパティを取得
   区分 = ""

End Sub

Sub Officeプロパティを更新()
   Dim ファイルシステムオブジェクト As Object          ' FileSystemObject
   Dim データ() As Variant
   Dim 出力フォルダ As String
   Dim 出力フルパス As String


    Stime = Now()
    
   Set ファイルシステムオブジェクト = CreateObject("Scripting.FileSystemObject")

   ThisWorkbook.Worksheets("Sheet1").Activate
   ファイル区分 = Range("AD1").Value
   拡張子 = Range("AE1").Cells(ファイル区分, 1).Value
   拡張子 = "*." & 拡張子
   入力フォルダ = Range("A5").Value

   最終行 = Cells(ActiveSheet.Rows.Count, 2).End(xlUp).Row

   出力フォルダ = 入力フォルダ & "\変更"

   If ファイルシステムオブジェクト.FolderExists(出力フォルダ) = False Then
      ファイルシステムオブジェクト.CreateFolder (出力フォルダ)
   End If


   For 行 = 11 To 最終行

      データ = Range("A1").Cells(行, 1).Resize(1, 31).Value

      ファイル名 = データ(1, 1)
      入力フルパス = 入力フォルダ & "\" & ファイル名
      出力フルパス = 出力フォルダ & "\" & ファイル名

      FileCopy 入力フルパス, 出力フルパス


      Set objFile = CreateObject("DSOFile.OleDocumentProperties")
      objFile.Open (出力フルパス)

      For 列 = 3 To 31
         If データ(1, 列) <> "" Then

            If データ(1, 列) = "$" Or データ(1, 列) = "$" Then
               データ(1, 列) = ""
            End If

            Select Case 列
               Case 3
                  objFile.SummaryProperties.Author = データ(1, 列)
               Case 5
                  objFile.SummaryProperties.Category = データ(1, 列)
               Case 8
                  objFile.SummaryProperties.Comments = データ(1, 列)
               Case 9
                  objFile.SummaryProperties.Company = データ(1, 列)
               Case 14
                  objFile.SummaryProperties.Keywords = データ(1, 列)
               Case 17
                  objFile.SummaryProperties.Manager = データ(1, 列)
               Case 18
                  objFile.SummaryProperties.MultimediaClipCount = データ(1, 列)
               Case 19
                  objFile.SummaryProperties.NoteCount = データ(1, 列)
               Case 22
                  objFile.SummaryProperties.PresentationFormat = データ(1, 列)
               Case 24
                  objFile.SummaryProperties.SharedDocument = データ(1, 列)
               Case 26
                  objFile.SummaryProperties.Subject = データ(1, 列)
               Case 27
                  objFile.SummaryProperties.Template = データ(1, 列)
               Case 28
                  objFile.SummaryProperties.Title = データ(1, 列)
               Case 30
                  objFile.SummaryProperties.Version = データ(1, 列)

            End Select
         End If
         objFile.Save
      Next 列

      objFile.Close
      Set objFile = Nothing

   Next 行

   Set ファイルシステムオブジェクト = Nothing

    Etime = Now()
    MsgBox "処理が終了しました。" & Chr(13) & "処理時間は、" & Format(Etime - Stime, "nn分ss秒") & " でした。", vbOKOnly

End Sub


この種類の目次に戻る↑ 索引へ↓ トップページに戻る


指定フォルダの全てのファイルのプロパティを出力する

 指定フォルダ直下のすべてのファイルの拡張プロパティを取得して、出力するマクロです。
 サブフォルダ のファイルも対象にするバージョン もあります。

(C:\WINDOWS\System32\Shell32.dll を使います。)
 ShellClassクラス(Shell32名前空間)
 Folderインターフェイス(Shell32名前空間)
 FolderItemインターフェイス(Shell32名前空間)

Win XP の場合、取得できる属性は、以下です。
0Name名前
1Sizeサイズ
2Type種類
3Date Modified更新日時
4Date Created作成日時
5Date Accessedアクセス日時
6Attributes属性
7Status状態
8Owner所有者
9Author作成者/アーティスト
10Titleタイトル
11Subject表題
12Categoryカテゴリ/ジャンル
13Pagesページ数
14Commentsコメント
15Copyright著作権
16Artistアーティスト
17Album Titleアルバムのタイトル
18Year
19Track Numberトラック番号
20Genreジャンル
21Duration長さ
22Bit Rateビット レート
23Protected保護
24Camera Modelカメラのモデル
25Date Picture Taken写真の撮影日
26Dimensions大きさ
27Not used
28Not used
29Episode Nameこの回のタイトル
30Program Descriptionプログラムの説明
31Description
32Audio sample sizeオーディオ サンプル サイズ
33Audio sample rateオーディオ サンプル レート
34Channelsチャンネル
35Company会社名
36
説明
37Versionファイル バージョン
38
製品名
39Version製品バージョン
40
☆ タイトル

 参考にさせていただいたサイト:

 MP3ファイルからタイトルやアーティスト名などを取得するには?
(デジタルアドバンテージ 遠藤 孝信)
http://www.atmarkit.co.jp/fdotnet/dotnettips/591mp3tags/mp3tags.html

 拡張ファイル プロパティの取得
https://gallery.technet.microsoft.com/scriptcenter/91621efc-ee6a-4989-a8e8-779412a4a249

 ファイルに関する詳細な概要情報の取得
https://gallery.technet.microsoft.com/scriptcenter/720e8665-6b68-4976-a87f-a90e4dd99725

 フォルダ
 フォルダのコピーと移動、削除、フォルダに関する情報の取得、フォルダ属性の設定など、フォルダの処理に関するサンプル スクリプト
http://www.microsoft.com/japan/technet/scriptcenter/scripts/storage/folders/default.mspx

このマクロを、ダウンロードできます。FileProperty2.xls


Option Explicit

Sub ファイルプロパティ取得()

   Dim フォルダパス As Variant
   Dim objShell As Object
   Dim objFolder As Object
   Dim i As Integer
   Dim strFileName As Variant

   Dim 行 As Integer
   Dim 列 As Integer
   Dim ファイル As Integer
   Dim データ(10000, 65) As Variant
   Dim 追加シート名初期 As String
   Dim 追加シート名 As String
   Dim 重複 As Integer
   Dim シート As Worksheet
   Dim シート数 As Integer
   Dim エラーカウント As Integer
   Dim メッセージ As String
   Dim 拡張子 As String
   Dim ファイル拡張子 As String
   Dim ファイル名 As String


   ThisWorkbook.Worksheets("Sheet1").Activate

    拡張子 = LCase(Range("F5").Value)
    ファイル名 = "指定ファイル種別,*." & 拡張子


   追加シート名初期 = "ファイルプロパティ"
    追加シート名 = 追加シート名初期

    For 重複 = 1 To 100
    ' 100枚まで追加しても重複しないように追番を設定します。
        For Each シート In Worksheets
            If シート.Name = 追加シート名 Then
                追加シート名 = 追加シート名初期 & "(" & 重複 & ")"
            End If
        Next シート
    Next 重複
    シート数 = Worksheets.Count
    Worksheets("テンプレート").Copy After:=Worksheets(シート数)
    ActiveSheet.Name = 追加シート名

    ChDrive ThisWorkbook.Path 'このブックのフォルダをデフォルトにする
    ChDir ThisWorkbook.Path   'このブックのフォルダをデフォルトにする

    '[ファイルを開く]ダイアログボックスで、ファイルを指定して、パスを取得
    フォルダパス = Application.GetOpenFilename(ファイル名)

    '[ファイルを開く]で「キャンセル」した場合は、処理を終了
    If フォルダパス = "False" Then End

    'フォルダパスから、後ろのファイル名の部分を削除して、フォルダ・パスに変更
    フォルダパス = Left(フォルダパス, InStrRev(フォルダパス, "\") - 1)

    'Excelのシート構成が違ってもエラーで止まらないようにする。
    ' On Error GoTo エラー表示

    '上で指定したフォルダ内の、全ての指定拡張子のファイルを対象に検索


   Set objShell = CreateObject("Shell.Application")
   Set objFolder = objShell.Namespace(フォルダパス)

   For i = 0 To 40
       データ(0, i) = objFolder.GetDetailsOf(objFolder.Items, i)
   Next
   ファイル = 0
   For Each strFileName In objFolder.Items

      ファイル名 = CStr(strFileName)
      ファイル拡張子 = LCase(Right(ファイル名, Len(ファイル名) - InStrRev(ファイル名, ".")))
      If 拡張子 = "*" Then ファイル拡張子 = "*"

      If ファイル拡張子 = 拡張子 Then
         ファイル = ファイル + 1
          For i = 0 To 40
              データ(ファイル, i) = objFolder.GetDetailsOf(strFileName, i)
          Next
       End If
   Next

    ThisWorkbook.Worksheets(追加シート名).Activate
    Application.ScreenUpdating = True

    For 行 = 0 To ファイル
        For 列 = 0 To 40
            ThisWorkbook.Worksheets(追加シート名).Range("A2").Cells(行 + 1, 列 + 1) _
            = データ(行, 列)
        Next 列
    Next 行

End Sub

 解説:

 バリアント型 (Variant)にしないと、
実行時エラー '91':
オブジェクト変数または With ブロック変数が設定されていません。

となります。

http://technet.microsoft.com/ja-jp/magazine/cc194399.aspx
Hey, Scripting Guy! お決まりのごまかし:ファイルの最終更新日時を変更する


この種類の目次に戻る↑ 索引へ↓ トップページに戻る


指定フォルダの全てのファイルのプロパティを出力(サブ・フォルダ以下も含む)

 上は、指定フォルダ直下のファイルのみ が対象でした。
 これを拡張して、サブ・フォルダのファイルも含め、対象フォルダの全てのファイルのプロパティを取得するようにしました。
このマクロを、ダウンロードできます。FilePropertyIncludeSubfoldersVBA01.xls

Dim ファイルシステムオブジェクト As Object
Dim フォルダ_オブジェクト As Object
Dim サブフォルダ As Variant
Dim ファイル As Object
Dim フォルダパス As Variant
Dim ファイル名 As String
Dim 拡張子 As String
Dim ファイルフルパス As String
Dim ファイル拡張子 As String

Dim 開始日時 As Variant
Dim 終了日時 As Variant

Dim データ(10000, 65) As Variant
Dim 追加シート名初期 As String
Dim 追加シート名 As String
Dim 重複 As Integer
Dim シート As Worksheet
Dim シート数 As Integer
Dim 行 As Integer
Dim 列 As Integer
Dim 項目数 As Integer
Dim strFileName As Variant
Dim objShell As Object
Dim objFolder As Object
Dim ファイル数 As Integer
Dim このExcelが登録されているフォルダパス As String


Sub サブフォルダを含めてファイルプロパティを取得()

   開始日時 = Now                ' 開始時刻を変数に格納します。

   ThisWorkbook.Worksheets("Sheet1").Activate
    
   拡張子 = LCase(Range("F5").Value)
   ファイル名 = "指定ファイル種別,*." & 拡張子
   
   追加シート名初期 = "ファイルプロパティ"
   追加シート名 = 追加シート名初期

   For 重複 = 1 To 100
   ' 100枚まで追加しても重複しないように追番を設定します。
       For Each シート In Worksheets
           If シート.Name = 追加シート名 Then
               追加シート名 = 追加シート名初期 & "(" & 重複 & ")"
           End If
       Next シート
   Next 重複
   シート数 = Worksheets.Count
   Worksheets("テンプレート").Copy After:=Worksheets(シート数)
   ActiveSheet.Name = 追加シート名
   
   このExcelが登録されているフォルダパス = ThisWorkbook.Path
   
   Set ファイルシステムオブジェクト = CreateObject("Scripting.FileSystemObject")
   
   フォルダパス = ファイルシステムオブジェクト.getfolder(このExcelが登録されているフォルダパス)

    
   ファイル数 = 0

   Call フォルダ直下のデータを取得(フォルダパス)
   

   ThisWorkbook.Worksheets(追加シート名).Activate
   Application.ScreenUpdating = True

   For 行 = 0 To ファイル数
      For 列 = 0 To 41
         '配列に格納したプロパティの値をシートに書き出す
         ThisWorkbook.Worksheets(追加シート名).Range("A2").Cells(行 + 1, 列 + 1) _
         = データ(行, 列)
      Next 列
   Next 行

   終了日時 = Now
   MsgBox "処理を終了しました。" & vbNewLine & "処理時間は、" _
   & Format(終了日時 - 開始日時, "nn分ss秒") & " でした。"

End Sub


Private Sub フォルダ直下のデータを取得(フォルダパス)

   'プロパティを取得するためのオブジェクトを準備
   Set objShell = CreateObject("Shell.Application")
   Set objFolder = objShell.Namespace(フォルダパス)

   If ファイル数 = 0 Then 'プロパティの項目名を配列に格納
      For 項目数 = 0 To 40
          データ(ファイル数, 項目数 + 1) = objFolder.GetDetailsOf(objFolder.Items, 項目数)
      Next
   End If
   
   For Each strFileName In objFolder.Items
      'フォルダ直下のすべてのファイルを対象に
      ファイル名 = CStr(strFileName)
      ファイル拡張子 = LCase(Right(ファイル名, Len(ファイル名) - InStrRev(ファイル名, ".")))
       
      If 拡張子 = "*" Then ファイル拡張子 = "*"
      
      If ファイル拡張子 = 拡張子 Then
         '指定した拡張子でフィルタして、プロパティを取得
         ファイル数 = ファイル数 + 1
         データ(ファイル数, 0) = フォルダパス '一列目にフォルダ・パスを格納
         
         For 項目数 = 0 To 40 'ファイル毎のプロパティを配列に格納
           データ(ファイル数, 項目数 + 1) = objFolder.GetDetailsOf(strFileName, 項目数)
         Next
          
      End If
   Next
      
   Set フォルダ_オブジェクト = ファイルシステムオブジェクト.getfolder(フォルダパス)

   For Each サブフォルダ In フォルダ_オブジェクト.SubFolders
      'フォルダ直下のすべてのフォルダを対象に
      Debug.Print サブフォルダ.Path
      'サブフォルダを使って、再帰呼び出しする
      Call フォルダ直下のデータを取得(サブフォルダ.Path)
   Next
End Sub

この種類の目次に戻る↑ 索引へ↓ トップページに戻る


指定フォルダの全てのPDFファイルのプロパティを出力して、変更する

 PDF のプロパティを一括取得、および一括変更 で紹介している Excelマクロの内容です。
 ダウンロードは、上記で、できます。

 このマクロは、下記サイトで公開いただいている PDFDesigner Tools (pdftool.dll) を、Excel マクロで呼んで、PDFファイルのプロパティを一括抽出したり、更新したりするものです。
http://homepage3.nifty.com/e-papy/pdftool/

 注:プロパティの取得・更新ができるのは、Acrobat バージョン、3.0-5.0(PDF1.2〜1.4形式)に制限されます。

 (別に、Office ファイルのプロパティを一括抽出したり、更新したりする DLL もあります。)

Option Explicit
Option Base 1

' PDFファイルの情報構造体(取得用)
Public Type TGetPDFInfoHeader
     Title(512)    As Byte ' タイトル
     Subject(512)  As Byte ' サブタイトル
     Author(512)   As Byte ' 作成者
     Keywords(512) As Byte ' キーワード
     Creator(512)  As Byte ' 作成
     Producer(512) As Byte ' PDF変換
     CreationDate(20) As Byte ' 作成日時
     ModDate(20)      As Byte ' 更新日時
End Type

' PDFファイルの情報構造体(書き込み用)
Public Type TSetPDFInfoHeader
     Title   As String ' タイトル
     Subject  As String ' サブタイトル
     Author   As String ' 作成者
     Keywords As String ' キーワード
     Creator  As String ' 作成
     Producer As String ' PDF変換
     CreationDate As String ' 作成日時
     ModDate      As String ' 更新日時
End Type

' 構造体メンバのCreationDateとModDateは
'  1999年3月11日21時28分08秒にしたい場合は
'     (1)19990311212808
'     (2)1999.03.11 21:28:08
'     (3)1999/03/11/21/28/08
'     など20文字以内で数字が14個あればどのような形式をいれても可能です。
'     なお、GeTPDFInfoHeaderのCreationDate、ModDateでは、(2)の形式で
'     価が戻って来ます

' PDFDesigner Tools API
Public Declare Function LoadPDF Lib "pdftool.dll" (ByVal OpenFileName As String) As Long
Public Declare Sub FreePDF Lib "pdftool.dll" (ByVal pdf As Long)
Public Declare Function GetPDFPageCount Lib "pdftool.dll" (ByVal pdf As Long) As Long
Public Declare Function GetPDFVersion Lib "pdftool.dll" (ByVal pdf As String) As Long
Public Declare Function GetPDFText Lib "pdftool.dll" (ByVal OpenFileName As String, ByVal SaveFileName As String) As Long
Public Declare Function GetPDFTextEx Lib "pdftool.dll" (ByVal pdf As Long, ByVal StartPos As Long, ByVal EndPos As Long, ByVal SaveFileName As String, ByVal Windowhandle As Long, ByVal LinePage As Boolean) As Long
Public Declare Function GetPDFBookMark Lib "pdftool.dll" (ByVal pdf As Long, ByVal SaveFileName As String, ByVal CSV As Boolean) As Long
Public Declare Function WritePDFText Lib "pdftool.dll" (ByVal OpenFileName As String, ByVal SaveFileName As String) As Long
Public Declare Function WritePDFImage Lib "pdftool.dll" (ByVal OpenFileName As String, ByVal SaveFileName As String) As Long
Public Declare Function CombinePDF Lib "pdftool.dll" (ByVal pdf1 As Long, ByVal pdf2 As Long, ByVal SaveFileName As String) As Long
Public Declare Function CombinePDFEx Lib "pdftool.dll" (ByVal OpenFileListName As String, ByVal SaveFileName As String, ByVal Windowhandle As Long, ByVal UseOutLine As Boolean) As Long
Public Declare Function CutPDF Lib "pdftool.dll" (ByVal pdf As Long, ByVal StartPos As Long, ByVal EndPos As Long, ByVal SaveFileName As String) As Long
Public Declare Function RotatePDF Lib "pdftool.dll" (ByVal pdf As Long, ByVal StartPos As Long, ByVal EndPos As Long, ByVal SaveFileName As String, ByVal Rotate As Long) As Long
Public Declare Function DeletePDF Lib "pdftool.dll" (ByVal pdf As Long, ByVal StartPos As Long, ByVal EndPos As Long, ByVal SaveFileName As String) As Long
Public Declare Function GetPDFInfo Lib "pdftool.dll" (ByVal pdf As Long, ByRef GetPDFInfoHeader As TGetPDFInfoHeader) As Long
Public Declare Function WritePDFInfo Lib "pdftool.dll" (ByVal pdf As Long, ByRef SetPDFInfoHeader As TSetPDFInfoHeader, ByVal SaveFileName As String) As Long


' サンプルで使用した windowsのAPI宣言
Public Declare Sub ZeroMemory Lib "kernel32" Alias "RtlZeroMemory" (Destination As Any, ByVal Length As Long)


   Dim 行 As Integer
   Dim 列 As Integer
   Dim 最終行 As Integer
   Dim ファイル名 As String
   Dim 入力フォルダ As String
   Dim 入力フルパス As String
   Dim Stime As Variant
   Dim Etime As Variant
   Dim 前有り As String
   Dim 区分 As String

   Dim pdfG As Long
   Dim pdfS As Long
   Dim PDFIHG As TGetPDFInfoHeader

' ★★★PDFプロパティを取得★★★
Sub PDFプロパティを取得()

   Dim ファイル As Integer
   Dim データ(1, 10) As Variant
   Dim pdfver As Integer

    Stime = Now()
   ThisWorkbook.Worksheets("Sheet1").Activate
   入力フォルダ = Range("A5").Value

   If 区分 = "変更後" Then
      入力フォルダ = 入力フォルダ & "\変更"
   End If

   'シートの既存内容を削除
   最終行 = Cells(ActiveSheet.Rows.Count, 1).End(xlUp).Row 'ファイル名の列で最終行を判定

   If 最終行 >= 11 Then
      Rows("11:" & CStr(最終行)).Delete Shift:=xlUp
   End If

   'Dir 関数を使用して、
    '指定されたフォルダで、見つかった指定拡張子のファイルを開きます。

    Dim ファイル名 As String   'Dirの返り値を一時的に保存

    '初期化
    ファイル名 = Dir(入力フォルダ & "\" & "*.pdf", vbDirectory)
    ファイル = 1
'    Stop

    'ファイル名をリストアップ
    While ファイル名 <> ""

      データ(1, 1) = ファイル名
      入力フルパス = 入力フォルダ & "\" & ファイル名

      ' PDFファイルのバージョン情報を取得する
      pdfver = GetPDFVersion(入力フルパス)
         ' エディットに表示する
      データ(1, 2) = pdfver

       ' 構造体の初期化
       Call ZeroMemory(PDFIHG, Len(PDFIHG))

       pdfG = LoadPDF(入力フルパス)

       ' 文書情報の取得
       Call GetPDFInfo(pdfG, PDFIHG)
          'エディットに情報を設定する
          If Range("C9").Value = True Then
            データ(1, 3) = StrConv(PDFIHG.Title, vbUnicode)
          End If
          If Range("D9").Value = True Then
            データ(1, 4) = StrConv(PDFIHG.Subject, vbUnicode)
          End If
          If Range("E9").Value = True Then
            データ(1, 5) = StrConv(PDFIHG.Author, vbUnicode)
          End If
          If Range("F9").Value = True Then
            データ(1, 6) = StrConv(PDFIHG.Keywords, vbUnicode)
          End If
          If Range("G9").Value = True Then
            データ(1, 7) = StrConv(PDFIHG.Creator, vbUnicode)
          End If
          If Range("H9").Value = True Then
            データ(1, 8) = StrConv(PDFIHG.Producer, vbUnicode)
          End If
          If Range("I9").Value = True Then
            データ(1, 9) = StrConv(PDFIHG.CreationDate, vbUnicode)
          End If
          If Range("J9").Value = True Then
            データ(1, 10) = StrConv(PDFIHG.ModDate, vbUnicode)
          End If
        FreePDF (pdfG)

         Range("A11").Cells(ファイル, 1).Resize(1, 10).Value = データ

        ファイル = ファイル + 1

        ファイル名 = Dir()
    Wend
    Etime = Now()
    MsgBox "処理が終了しました。" & Chr(13) & "処理時間は、" _
    & Format(Etime - Stime, "nn分ss秒") & " でした。", vbOKOnly

End Sub

' ★★★変更フォルダのプロパティ取得★★★
Sub 変更フォルダのプロパティ取得()

   区分 = "変更後"
   Call PDFプロパティを取得
   区分 = ""

End Sub

' ★★★ PDFプロパティを更新 ★★★
Sub PDFプロパティを更新()
   Dim ファイルシステムオブジェクト As Object          ' FileSystemObject

   Dim データ() As Variant
   Dim PDFIHS As TSetPDFInfoHeader
   Dim 出力フォルダ As String
   Dim 出力フルパス As String

    Stime = Now()
   Set ファイルシステムオブジェクト = CreateObject("Scripting.FileSystemObject")

   ThisWorkbook.Worksheets("Sheet1").Activate
   最終行 = Cells(ActiveSheet.Rows.Count, 1).End(xlUp).Row 'ファイル名の列で最終行を判定
   入力フォルダ = Range("A5").Value

   出力フォルダ = 入力フォルダ & "\変更"

   If ファイルシステムオブジェクト.FolderExists(出力フォルダ) = False Then
      ファイルシステムオブジェクト.CreateFolder (出力フォルダ)
   End If


   For 行 = 11 To 最終行
      前有り = ""
      データ = Range("A1").Cells(行, 1).Resize(1, 10).Value

      ファイル名 = データ(1, 1)
      入力フルパス = 入力フォルダ & "\" & ファイル名
      出力フルパス = 出力フォルダ & "\" & ファイル名

      ' 構造体の初期化
      Call ZeroMemory(PDFIHG, Len(PDFIHG))

      pdfG = LoadPDF(入力フルパス)
      pdfS = LoadPDF(入力フルパス)

      ' 文書情報の取得
       Call GetPDFInfo(pdfG, PDFIHG)

      For 列 = 3 To 10
         Select Case 列
            Case 3
               If データ(1, 列) = "$" Or データ(1, 列) = "$" Then
                  データ(1, 列) = ""
               ElseIf Trim(データ(1, 列)) = "" Then
                  データ(1, 列) = StrConv(PDFIHG.Title, vbUnicode)
               End If
               PDFIHS.Title = CStr(データ(1, 列))
            Case 4
               If データ(1, 列) = "$" Or データ(1, 列) = "$" Then
                  データ(1, 列) = ""
               ElseIf Trim(データ(1, 列)) = "" Then
                  データ(1, 列) = StrConv(PDFIHG.Subject, vbUnicode)
               End If
               PDFIHS.Subject = CStr(データ(1, 列))
            Case 5
               If データ(1, 列) = "$" Or データ(1, 列) = "$" Then
                  データ(1, 列) = ""
               ElseIf Trim(データ(1, 列)) = "" Then
                  データ(1, 列) = StrConv(PDFIHG.Author, vbUnicode)
               End If
               PDFIHS.Author = CStr(データ(1, 列))
            Case 6
               If データ(1, 列) = "$" Or データ(1, 列) = "$" Then
                  データ(1, 列) = ""
               ElseIf Trim(データ(1, 列)) = "" Then
                  データ(1, 列) = StrConv(PDFIHG.Keywords, vbUnicode)
               End If
               PDFIHS.Keywords = CStr(データ(1, 列))
            Case 7
               If データ(1, 列) = "$" Or データ(1, 列) = "$" Then
                  データ(1, 列) = ""
               ElseIf Trim(データ(1, 列)) = "" Then
                  データ(1, 列) = StrConv(PDFIHG.Creator, vbUnicode)
               End If
               PDFIHS.Creator = データ(1, 列)
            Case 8
               If データ(1, 列) = "$" Or データ(1, 列) = "$" Then
                  データ(1, 列) = ""
               ElseIf Trim(データ(1, 列)) = "" Then
                  データ(1, 列) = StrConv(PDFIHG.Producer, vbUnicode)
               End If
               PDFIHS.Producer = CStr(データ(1, 列))
            Case 9
               If データ(1, 列) = "$" Or データ(1, 列) = "$" Then
                  データ(1, 列) = ""
               ElseIf Trim(データ(1, 列)) = "" Then
                  データ(1, 列) = StrConv(PDFIHG.CreationDate, vbUnicode)
               End If
               PDFIHS.CreationDate = CStr(データ(1, 列))
            Case 10
               If データ(1, 列) = "$" Or データ(1, 列) = "$" Then
                  データ(1, 列) = ""
               ElseIf Trim(データ(1, 列)) = "" Then
                  データ(1, 列) = StrConv(PDFIHG.ModDate, vbUnicode)
               End If
               PDFIHS.ModDate = CStr(データ(1, 列))
         End Select

      Next 列
      FreePDF (pdfG)

'      Stop
    ' PDFに情報を書き込む
    Call WritePDFInfo(pdfS, PDFIHS, 出力フルパス)

   FreePDF (pdfS)

'Stop
   Next 行

    Etime = Now()
    MsgBox "処理が終了しました。" & Chr(13) & "処理時間は、" _
    & Format(Etime - Stime, "nn分ss秒") & " でした。", vbOKOnly

End Sub

この種類の目次に戻る↑ 索引へ↓ トップページに戻る


ホームページのトップに戻る