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 版 と同じです。
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 の場合、取得できる属性は、以下です。
0 Name 名前
1 Size サイズ
2 Type 種類
3 Date Modified 更新日時
4 Date Created 作成日時
5 Date Accessed アクセス日時
6 Attributes 属性
7 Status 状態
8 Owner 所有者
9 Author 作成者/アーティスト
10 Title タイトル
11 Subject 表題
12 Category カテゴリ/ジャンル
13 Pages ページ数
14 Comments コメント
15 Copyright 著作権
16 Artist アーティスト
17 Album Title アルバムのタイトル
18 Year 年
19 Track Number トラック番号
20 Genre ジャンル
21 Duration 長さ
22 Bit Rate ビット レート
23 Protected 保護
24 Camera Model カメラのモデル
25 Date Picture Taken 写真の撮影日
26 Dimensions 大きさ
27 Not used
28 Not used
29 Episode Name この回のタイトル
30 Program Description プログラムの説明
31 Description
32 Audio sample size オーディオ サンプル サイズ
33 Audio sample rate オーディオ サンプル レート
34 Channels チャンネル
35 Company 会社名
36 説明
37 Version ファイル バージョン
38 製品名
39 Version 製品バージョン
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
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! お決まりのごまかし:ファイルの最終更新日時を変更する
指定フォルダの全てのファイルのプロパティを出力(サブ・フォルダ以下も含む)
上は、指定フォルダ直下のファイルのみ が対象でした。
これを拡張して、サブ・フォルダのファイルも含め、対象フォルダの全てのファイルのプロパティを取得するようにしました。
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