btinc.jp 発表会演目一覧
演目2. デジカメJPEGファイルの日付を書き換える (演目1続編) Excel 2003 on WindowsXP

演目1で撮影日付と呼んでいたのは、DateTimeOriginal と仕様書で記載されたものです。「原画像データが生成された日付と時間」と説明されています。実は日付データはほかにもあります。Exifタグとしては、DateTimeDigitized (画像がディジタルデータ化された日付と時間)、DateTime (画像の作成された日付と時間。ファイル変更日時)の2つ。もう一つ、エクスプローラなどで表示されるファイル属性としての更新日時というのがあります。
私のようにカメラの日付設定を間違えて後から訂正しようという場合4つとも変更しないとつじつまが合いませんから、4つとも変更できるようにするという方針で進めたいと思います。

ファイル属性としての更新日時というのが実は曲者でした。VBAで、そうでなくても Scripting.FileSystemObject を使えば変更できると思っていたのですが Win32API が必要でした。

演目1についても同様ですが、題材としたJPEGはオリンパス(2001年か2002年くらいの製品)とAU携帯のカメラで撮影したものです。他の題材では試しておりません。

なお、最終更新日付(ファイル属性)変更のためのプロパティ(ChangedatetimeLastModified)の扱い方に誤りがあったため訂正しました。(2010/7/27)

1. JpegExif クラスの変更

拡大した JpegExif クラスのプロパティとメソッドを示します。
青字斜体が演目1からの追加プロパティ、メソッドです。

JpegExif クラス
プロパティ
NameStringrファイル名 (拡張子含む)
PathStringrフルパス (ファイル名含む)
FileSizeLongrファイルサイズ (byte単位)
DateTimeLastModifiedDater最終更新日付(ファイル属性)
DateTimeOriginalDater撮影日付
DateTimeDigitizedDaterディジタルデータ作成日付
DateTimeDaterファイル変更日付(Exifタグ)
ChangeDateTimeLastModifiedDaterw変更する最終更新日付(ファイル属性)
ChangeDateTimeOriginalDaterw変更する撮影日付
ChangeDateTimeDigitizedDaterw変更するディジタルデータ作成日付
ChangeDateTimeDaterw変更するファイル変更日付(Exifタグ)
MakeStringrメーカー名
ModelStringr機種名
ExifVersionStringrExifバージョン
ExposureTimeStringr露出時間 (秒単位)。分数形式 例) 1/30
FlashBooleanr発光したか否
FNumberStringrFナンバー。分数形式 例) 28/10
ImageLengthLongr画像縦サイズ (ピクセル単位)
ImageWidthLongr画像横サイズ (ピクセル単位)
メソッド
InitSet
ファイルフルパスを受け取り、プロパティなどの値取得を行う。
引数Stringファイルフルパス
戻り値Integer
0JpegExifファイルである
2Jpegファイルであるが、Exifではない
-1ファイルが見つからない
-2ファイルが開けない
-3Jpegファイルではない
-11格納データにエラーがあるみたい
SaveChanged
出力ファイル名(フルパス)を受け取り、日付を変更し出力する。同名ファイルが存在する場合は削除する
引数Stringフォルダフルパス
戻り値Integer
一の位最終更新日付(ファイル属性)
十の位撮影日付
百の位ディジタルデータ作成日付
千の位ファイル更新日付
各桁は、作為不要=1 正常変更=2 変更失敗=3 情報なし=9
ファイル出力失敗は-1

変更する日付を格納するプロパティはクラス外部から指定することになりますから書き換え可能です。

InitSetメソッドを実行すると、3つのExif日付変更プロパティは元ファイルと同じ値になります。(ChangeDateTimeOriginal, ChangeDateTimeDigitized, ChangeDateTime)
一方、最終更新日付変更プロパティ(ChangeDateTimeLastModified)は、VBA日付型変数の初期値0(1900/1/0 00:00:00)とします。

4つの日付のうち変更したいプロパティに変更日付を設定した上で SaveChangedメソッドを実行することになります。4つ全部の変更も1つだけの変更も可能です。
3つのExif日付は、元の日付と「Change」の日付が一致する場合は作為不要(1)と判断します。
一方、ファイル日付の方は「Change」がVBA初期値のままであれば作為不要(1)と判断することにします。その場合SaveChangedメソッドで出力された日時になります。つまり作為しないということです。
元ファイルと同じ最終更新日付にしたい場合は「Change」の方に元ファイルの日付を設定してやります。

ただし、元ファイルを書き換えるのは怖いので別ファイルとして出力するようにしました。
(同名ファイルを指定した場合は、ファイル出力失敗:-1 が返ります。)

SaveChangedメソッドの戻り値は一から千の各位を見ることで判断できるようにしました。「情報なし」というのは該当するタグが見つからなかったか、タグはあっても日付が格納されていなかったということです。この場合、タグを設けて出力したり正しく格納し直すということはしません。
最終更新日付(ファイル属性)については情報なしということは考えられないので 9 となることはありません。

2. 新しい JpegExif クラスを使ってみる

実装の話は後回しにして使い方からご披露します。
新しい JpegExifクラスを使って日付を変更する手順は、次のようになります。

 (1) JpegExifオブジェクト作成
 (2) InitSetメソッドを実行し、ファイル情報を与える。
 (3) 変更したい日付プロパティ(Change...)に日付を設定する。
 (4) 出力ファイル名を引数にSaveChangedメソッド実行。

それでは、実際に日付変更作業をやってみることにします。

次の図は変更前のファイルをエクスプローラで見たものです。
今夏、山へ出かけて一日撮りためたものですが、日付が 2008/5/8 となっています。本当の日付は 2009/8/8 です。

エクスプローラ 変更前

1) ファイルリストをこしらえる

演目1でご紹介したマクロ「JPEGファイルリスト作成」だと日付変更に必要のない項目も付いてきますので、少しマクロを改造してリストを作ります。 (マクロのソースは割愛します)

日付変更のためのリスト

2) ファイルリストの加工

リストを読み込んで一気に日付を変更するマクロを作るつもりですので、必要な情報を付け加えていきます。

日付変更のためのリストに加工

加工1. 日付欄は秒まで表示

デフォルトでは分までしか表示されませんので。

加工2. 2行目に出力フォルダ欄を設ける

1行挿入して2列目に設け、フォルダをフルパスで入力します。

加工3. 本当の日付を入力

入力といっても全部手作業で入力するわけではありません。手入力するのは先頭(4行目)だけです。
F2セルで日付の差 (F4-D4) を計算させるようにし、残りの「本当の日付」は撮影日時に差を加えます(D5+F$2...等々)。

加工4. 新ファイル名を設定

筆者のオリンパスカメラのファイル名は、P + [月(1桁)] + [日(2桁)] + [連番(4桁)] + .JPG という形式ですので、 日付を変更したらファイル名も変更しないとつじつまがあいません。
月が1桁というのは、16進数を使うからです。
G4以下の埋め込み式は、CONCATENATE("P",DEC2HEX(MONTH(F4),1),TEXT(DAY(F4),"00"),MID(A4,5,8)) ...等々
 ※ DEC2HEX関数は「分析ツール」アドインを有効にしないと使えません。

加工5. 処理結果の欄を設ける

最後に、処理の結果を表示させる欄を端っこに付けておきます。これから作るマクロが結果をここに書き込む予定です。

ファイル日付(OS)と撮影日付が1秒ほど違うものもありますが、撮影日付に一致させることにします。
これでリストの準備が整いました。いよいよ日付変更マクロを作成して実行です。

3) 日付変更マクロの作成

'********************************************************* ' Sheet2のリストに従い日付を変更する ' 1行目: 入力フォルダ(2列目) ' 2行目: 出力フォルダ(2列目) ' 3行目: リスト見出し ' 4行目以下: ファイルリスト本文 ' F(6)列: 変更日付 ' G(7)列: 出力ファイル名 ' H(8)列に結果値を書き込む '********************************************************* Public Sub JPEGファイル日付変更() Dim tSheet As String Dim sFolder As String Dim tFolder As String Dim fileName As String Dim tRow As Long Dim maxRow As Long Dim changeDate As Date Dim outFileName As String Dim tmpRet As Integer tSheet = "Sheet2" With ThisWorkbook.Worksheets(tSheet) maxRow = .UsedRange.Rows.Count If maxRow > 3 Then sFolder = .Cells(1, 2).Text tFolder = .Cells(2, 2).Text If Len(sFolder) > 0 And Len(tFolder) > 0 Then If Right(sFolder, 1) <> "\" Then sFolder = sFolder & "\" If Right(tFolder, 1) <> "\" Then tFolder = tFolder & "\" For tRow = 4 To maxRow tmpRet = 0 fileName = .Cells(tRow, 1).Text outFileName = .Cells(tRow, 7).Text If Len(fileName) > 0 And Len(outFileName) > 0 Then If IsDate(.Cells(tRow, 6).Value) Then changeDate = .Cells(tRow, 6).Value '(1) JpegExifオブジェクト作成 Dim objJpeg As New JpegExif '(2) InitSetメソッドを実行し、ファイル情報を与える If objJpeg.InitSet(sFolder & fileName) = 0 Then '(3) 変更したい日付プロパティ(Change...)に日付を設定する ' 4つとも同じ日付にする With objJpeg .ChangeDateTime = changeDate .ChangeDateTimeDigitized = changeDate .ChangeDateTimeLastModified = changeDate .ChangeDateTimeOriginal = changeDate End With '(4) 出力ファイル名を引数にSaveChangedメソッド実行 tmpRet = objJpeg.SaveChanged(tFolder & outFileName) End If Set objJpeg = Nothing End If End If .Cells(tRow, 8).Value = tmpRet Next tRow End If End If End With End Sub

4) 日付変更マクロの実行

実行前に出力フォルダを作成しておきます。

変更後のファイルをエクスプローラで確認してみました。

エクスプローラ 変更後

3. JpegExif クラスの実装

今回のバージョンアップクラスの実装作業は大きく分けて4つあります。

 1) プロパティの追加  …クラス変数を設け Getter/Letterを書く退屈な作業
 2) Exif情報取得時に日付記入位置を記憶する  …このためにクラス変数を用意。readIFDの改修
 3) 元ファイルを読み出し書き換えながら出力
 4) 出力ファイルの更新日付変更

1) プロパティの追加

クラス変数を定義しGetter/Letterを作成しました。
JavaやC#などではGetter/Setterですが、VBAにはプロパティの書込み用アクセッサが Property Let と Property Set二つあります。
値渡しの場合はLet、参照渡しの場合はSetという使い分けが必要なようです。 かんたんに言えば、代入文でsetをつけるデータ型の場合はSet、つけないデータ型の場合はLetということです。
今回書込みを許可するプロパティは日付型ですので Property Let をこしらえます。

2) Exif情報取得時に日付記入位置を記憶

日付記入アドレス(cAddrDateTimeOriginal, cAddrDateTimeDigitized, cAddrDateTime)と長さ(cLenDateTimeOriginal, cLenDateTimeDigitized, cLenDateTime)をLong型のクラス変数として定義します。
アドレスはファイル先頭を0とするため、0を初期値にするわけにはいきません。クラスの初期化時(Initializeイベント)に-1を代入するようにしています。
また、長さは yyyy:mm:dd HH:MM:SS 形式に文字列終端のChr(0)を加え常に20のはずですが、万一20でない場合には日付変更は実施しないことにします。

Exif情報取得の現場はプライベート関数 readIFD()です。一つのIFDの内部にあるすべてのタグをあたり、タグごとに定められた処理を行います。これまでは撮影日付以外無視していましたから読み出すように改修する必要があります。
記入アドレスと長さは読み出すときに必ず求めますから、これをクラス変数に保存することは容易です。

3) 元ファイルを読み出し書き換えながら出力

書き出しは、元ファイルを適当な分量ずつ読み込み、読み込んだ中に記入位置があれば新しい日付で書き直した上で行うようにします。
問題は記入開始位置と終了位置が分離した状態で読み込まないようにすることです。

読み込みサイズの既定値(MAX_BUFLEN定数)を決めておき、現在のシークポイント + MAX_BUFLENが3つの日付のひとつを分断するようであれば、分断日付の記入(開始)位置直前までの読み込みに切り替えるという具合に処理します。
神経を使うばかりのプログラミングで楽しい作業ではありませんでした。MAX_BUFLEN=20 として正しく処理できるか確かめました。

MAX_BUFLEN=20000 や 30000 としても動作するので、ほとんど使われることのないロジックではあります。

これがSaveChangedメソッドの主たる処理ですが、次に述べるファイル更新日付の変更もこのメソッド内で行っています。
(changeTimeStamp というプライベート関数を呼び出す)

4) 出力ファイルの更新日付変更

目的とするファイルのフルパスを引数とする changeTimeStamp()というプライベート関数を作成することにします。
SaveChangedメソッド内に直接書くとややこしくなりますから。

5つのWin32API関数を使います。
大雑把にいいますと、ファイルを開き (CreateFile())、日付を変更し(SetFileTime())、ファイルを閉じる(CloseHandle())、となります。
この3つで済めばいいのですが、SetFileTime()関数が引数として要求する日付データの型とVBAのそれとが異なっており、なおかつ、ファイルに記録する日付はUTC(グリニッジ標準時)でなければなりません。データ型を変換するAPIとローカルタイムをUTCに直すAPIが必要となります。

【日付データ型について】

VBA の日付型(Date)は浮動小数点形式をとっており、整数部で年月日を、小数部で時刻を表すようになっています。ちなみに起点は 1899/12/30 00:00:00
一方、SetFileTimeでファイルに書き込まれる日付は64ビット整数(Long二つ)形式です。1601年1月1日0時0分0秒000ナノ秒を起点とする経過時間(単位100ナノ秒)を表しています。これはクラスモジュールの冒頭で FILETIME型としてType宣言します。

したがって、Date → FILETIME 変換が必要になるわけで、ここでAPI関数を一つ使います。
ただし、直接変換できるわけではなく Windows OSが内部で使用しているSYSTEMTIME構造体(これもType宣言します)を経由しなければなりません。

SYSTEMTIME構造体は年、月、日、時、分、秒などをそれぞれ独立したフィールド(16ビット整数)として持つ構造ですから、VBAのYear()関数やMonth()関数を使って各フィールド値を設定することができます。
そして、SYSTEMTIME → FILETIME 変換にAPI関数 SystemTimeToFileTime()を使います。

【ローカルタイム → UTC】

日本時間から9時間を引けばUTCになるわけですが、この計算もAPI関数 LocalFileTimeToFileTime()でやってもらいます。
名前からおわかりかと思いますが、FILETIME型で計算するものです。整数型ですから時差計算に繰り上がり・繰り下がりなど考慮不要ということで適任です!?

JpegExif クラスモジュール全コード

'//////////////////////////////////////////////////////////////////////// ' JpegExifクラス ' ver 1.00 2009-10-16 読み出し専用 ' ver 1.10 2009-11-24 日付変更機能追加 ' ver 1.11 2010-07-25 ファイル日付変更実施の条件を変える '//////////////////////////////////////////////////////////////////////// Option Explicit Const TAG_DATETIMEORIGINAL = 36867 Const TAG_MAKE = 271 Const TAG_MODEL = 272 Const TAG_EXIFVERSION = 36864 Const TAG_EXPOSURETIME = 33434 Const TAG_FLASH = 37385 Const TAG_FNUMBER = 33437 '----- 追加 ver 1.10 Const TAG_DATETIME = 306 Const TAG_DATETIMEDIGITIZED = 36868 Const TAG_EXIF_IFD = 34665 '----- 追加 ver 1.10 'SaveChangedにおける入出力バッファサイズ(バイト) ' In/Outテストのためのサイズ 実際には20000あたりでOK Const MAX_BUFLEN = 20000 'プロパティのクラス変数 Private cName As String Private cPath As String 'ファイル名まで含めたフルパス Private cFileSize As Long 'byte単位 Private cDateTimeLastModified As Date Private cDateTimeOriginal As Date Private cMake As String Private cModel As String Private cExifVersion As String Private cExposureTime As String Private cFlash As Boolean Private cFNumber As String Private cImageWidth As Long Private cImageLength As Long '----- 追加 ver 1.10 Private cDateTime As Date Private cDateTimeDigitized As Date Private cChangeDateTimeLastModified As Date Private cChangeDateTimeOriginal As Date Private cChangeDateTime As Date Private cChangeDateTimeDigitized As Date ' 記入位置 (ファイル先頭を0とする) Private cAddrDateTimeOriginal As Long Private cAddrDateTime As Long Private cAddrDateTimeDigitized As Long ' 記入文字列長さ(Byte) ' 文字列終端のchr(0)を含め常時20のはず。 ' 20でない場合は日付変更を行わないものとする。 Private cLenDateTimeOriginal As Long Private cLenDateTime As Long Private cLenDateTimeDigitized As Long Private cEndian As Integer 'IFDにおける整数格納形式 1:BigEndian -1:LittleEndian Private cAddrTifHead As Long 'Tifヘッドアドレス 'IFDのオフセットはすべてここを基準とする '********************************************************** ' ファイルのタイムスタンプ変更のためのAPI関数 '********************************************************** '***** ファイル操作 ***** '--- ファイルオープン Private Declare Function CreateFile Lib "kernel32" Alias "CreateFileA" _ (ByVal lpFileName As String, _ ByVal dwDesiredAccess As Long, _ ByVal dwShareMode As Long, _ ByVal lpSecurityAttributes As String, _ ByVal dwCreationDisposition As Long, _ ByVal dwFlagsAndAttributes As Long, _ ByVal hTemplateFile As Long) As Long '第1引数 文字列(変数)をそのまま引数にすれば適切なアドレスを伝えてくれる ' 仕組みになっているらしい。 '第2引数 Const GENERIC_WRITE = &H40000000 '第3引数 0:排他 '第4引数について ' 本来は、lpSecurityAttributes As SECURITY_ATTRIBUTES として ' 取得したハンドルの子プロセスへの継承を許可するかどうかを決定する構造体へのポインタを指定。 ' Type SECURITY_ATTRIBUTES ' nLength As Long ' lpSecurityDescriptor As Long ' bInheritHandle As Long ' End Type ' 必要ないのでString とし、vbNullStringを渡す '第5引数 Const OPEN_EXISTING = 3 '第6引数 Const FILE_ATTRIBUTE_ARCHIVE = &H20 '第7引数 0 '戻り値 Const INVALID_HANDLE_VALUE = &HFFFFFFFF '--- ファイルクローズ Private Declare Function CloseHandle Lib "kernel32" _ (ByVal hObject As Long) As Long '***** 日付操作 ***** Private Type FILETIME dwLowDateTime As Long dwHighDateTime As Long End Type Private Type SYSTEMTIME wYear As Integer wMonth As Integer wDayOfWeek As Integer wDay As Integer wHour As Integer wMinute As Integer wSecond As Integer wMilliseconds As Integer End Type '----- ファイルタイム設定 Private Declare Function SetFileTime Lib "kernel32" _ (ByVal hFile As Long, _ lpCreationTime As String, _ lpLastAccessTime As String, _ lpLastWriteTime As FILETIME) As Long 'lpCreationTime, lpLastAccessTimeは本来FILETIME型だが 'かまう必要がないのでStringとし、vbNullStringを渡すようにする '----- 時差調整 (FILETIME型) 'Local -> UTC Private Declare Function LocalFileTimeToFileTime Lib "kernel32" _ (lpLocalFileTime As FILETIME, lpFileTime As FILETIME) As Long '----- 型変換 'SYSTEMTIME -> FILETIME Private Declare Function SystemTimeToFileTime Lib "kernel32" _ (lpSystemTime As SYSTEMTIME, lpFileTime As FILETIME) As Long '----------------------------------------------------------------- ' インスタンスが作成されるときInitializeイベントが発生する '----------------------------------------------------------------- Private Sub Class_Initialize() cEndian = 1 '0は有効なアドレスになるため-1で初期化 cAddrDateTimeOriginal = -1 cAddrDateTime = -1 cAddrDateTimeDigitized = -1 End Sub '***** プロパティ ***** '***** ファイル名 Public Property Get Name() As String Name = cName End Property '***** フルパス Public Property Get Path() As String Path = cPath End Property '***** ファイルサイズ(byte単位) Public Property Get FileSize() As Long FileSize = cFileSize End Property '***** ファイル最終更新日付 (ファイル属性) Public Property Get DateTimeLastModified() As Date DateTimeLastModified = cDateTimeLastModified End Property '***** 撮影日付 Public Property Get DateTimeOriginal() As Date DateTimeOriginal = cDateTimeOriginal End Property '***** メーカー Public Property Get Make() As String Make = cMake End Property '***** モデル Public Property Get Model() As String Model = cModel End Property '***** Exifバージョン Public Property Get ExifVersion() As String ExifVersion = cExifVersion End Property '***** 露出時間 Public Property Get ExposureTime() As String ExposureTime = cExposureTime End Property '***** 発光 Public Property Get Flash() As Boolean Flash = cFlash End Property '***** Fナンバー Public Property Get FNumber() As String FNumber = cFNumber End Property '***** 画像サイズたて (ピクセル単位) Public Property Get ImageLength() As Long ImageLength = cImageLength End Property '***** 画像サイズよこ (ピクセル単位) Public Property Get ImageWidth() As Long ImageWidth = cImageWidth End Property '----- 追加 ver 1.10 '***** ファイル変更日時 (タグ登録) Public Property Get DateTime() As Date DateTime = cDateTime End Property '***** ディジタルデータ作成日時 Public Property Get DateTimeDigitized() As Date DateTimeDigitized = cDateTimeDigitized End Property '***** 変更要望 ファイル最終更新日付 (ファイル属性) Public Property Get ChangeDateTimeLastModified() As Date ChangeDateTimeLastModified = cChangeDateTimeLastModified End Property Public Property Let ChangeDateTimeLastModified(ByVal newValue As Date) cChangeDateTimeLastModified = newValue End Property '***** 変更要望 撮影日付 Public Property Get ChangeDateTimeOriginal() As Date ChangeDateTimeOriginal = cChangeDateTimeOriginal End Property Public Property Let ChangeDateTimeOriginal(ByVal newValue As Date) cChangeDateTimeOriginal = newValue End Property '***** 変更要望 ファイル変更日時 (タグ登録) Public Property Get ChangeDateTime() As Date ChangeDateTime = cChangeDateTime End Property Public Property Let ChangeDateTime(ByVal newValue As Date) cChangeDateTime = newValue End Property '***** 変更要望 ディジタルデータ作成日時 Public Property Get ChangeDateTimeDigitized() As Date ChangeDateTimeDigitized = cChangeDateTimeDigitized End Property Public Property Let ChangeDateTimeDigitized(ByVal newValue As Date) cChangeDateTimeDigitized = newValue End Property '***** メソッド ***** '************************************************************************* ' 変更要望日付(ChangeDateTime*プロパティ)に従い日付を書き換え、 ' 指定ファイル名(フルパス)に出力する。 ' 既存の同名ファイルは削除する。 ' 引数 newFile: 出力ファイルフルパス。cPathと同一の場合はエラーとなる ' ret -1: 出力失敗 ' 2: 最終更新日付(DateTimeLastModified)正常変更 ' 3:同上変更失敗 1:同上変更要望なし ' 20: 撮影日付(DateTimeOriginal)正常変更 ' 30:同上変更失敗 10:同上変更要望なし 90:タグなし ' 200: ディジタルデータ作成日付(DateTimeDigitized)正常変更 ' 300:同上変更失敗 100:同上変更要望なし 900:タグなし ' 2000: ファイル更新日付(DateTime)正常変更 ' 3000:同上変更失敗 1000:同上変更要望なし 9000:タグなし '************************************************************************* Public Function SaveChanged(ByVal newFile As String) As Integer Dim ret As Integer Dim inFlNum As Integer Dim outFlNum As Integer Dim pos As Long Dim nextPos As Long Dim bufLen As Long Dim buf() As Byte Dim remain As Long Dim addrChange As Long Dim dateChange As Date Dim strDate As String Dim i As Integer Dim rc As Integer If Len(cPath) > 0 Then '入出力ファイルオープン ' newFileが空文字であったりcPathと等しい場合はここでエラーとなる On Error GoTo Er1_SaveChanged inFlNum = FreeFile Open cPath For Binary Access Read As #inFlNum outFlNum = FreeFile Open newFile For Binary Access Write As #outFlNum On Error GoTo 0 '+++++ 主処理 +++++ pos = 0 Do 'バッファサイズ初期値 remain = cFileSize - pos '未処理バイト数 If remain <= 0 Then Exit Do ElseIf remain < MAX_BUFLEN Then bufLen = remain Else bufLen = MAX_BUFLEN End If '読み出し後のファイルポインタが日付記入範囲をまたぐなら 'bufLenを小さくして範囲の直前までを読み出すようにする nextPos = pos + bufLen If nextPos >= cAddrDateTime And _ nextPos < cAddrDateTime + cLenDateTime Then bufLen = bufLen - (nextPos - cAddrDateTime) ElseIf nextPos >= cAddrDateTimeOriginal And _ nextPos < cAddrDateTimeOriginal + cLenDateTimeOriginal Then bufLen = bufLen - (nextPos - cAddrDateTimeOriginal) ElseIf nextPos >= cAddrDateTimeDigitized And _ nextPos < cAddrDateTimeDigitized + cLenDateTimeDigitized Then bufLen = bufLen - (nextPos - cAddrDateTimeDigitized) End If ReDim buf(0 To bufLen - 1) Get #inFlNum, , buf '読み出し分の中に日付記入位置が含まれるかどうか nextPos = pos + bufLen If cAddrDateTime >= pos And cAddrDateTime < nextPos Then If cDateTime = cChangeDateTime Then '書き換え不要 ret = ret + 1000 Else addrChange = cAddrDateTime - pos strDate = Format(cChangeDateTime, "yyyy:mm:dd HH:MM:SS") If Len(strDate) = 19 And cLenDateTime = 20 Then For i = 0 To 18 buf(addrChange + i) = Asc(Mid(strDate, i + 1, 1)) Next i ret = ret + 2000 Else ret = ret + 3000 End If End If End If If cAddrDateTimeOriginal >= pos And cAddrDateTimeOriginal < nextPos Then If cDateTimeOriginal = cChangeDateTimeOriginal Then '書き換え不要 ret = ret + 10 Else addrChange = cAddrDateTimeOriginal - pos strDate = Format(cChangeDateTimeOriginal, "yyyy:mm:dd HH:MM:SS") If Len(strDate) = 19 And cLenDateTimeOriginal = 20 Then For i = 0 To 18 buf(addrChange + i) = Asc(Mid(strDate, i + 1, 1)) Next i ret = ret + 20 Else ret = ret + 30 End If End If End If If cAddrDateTimeDigitized >= pos And cAddrDateTimeDigitized < nextPos Then If cDateTimeDigitized = cChangeDateTimeDigitized Then '書き換え不要 ret = ret + 100 Else addrChange = cAddrDateTimeDigitized - pos strDate = Format(cChangeDateTimeDigitized, "yyyy:mm:dd HH:MM:SS") If Len(strDate) = 19 And cLenDateTimeDigitized = 20 Then For i = 0 To 18 buf(addrChange + i) = Asc(Mid(strDate, i + 1, 1)) Next i ret = ret + 200 Else ret = ret + 300 End If End If End If '出力 Put #outFlNum, , buf 'シークポイント移動 pos = Seek(inFlNum) - 1 Loop 'ファイルクローズ Close inFlNum Close outFlNum If cChangeDateTimeLastModified > 0 Then 'If cChangeDateTimeLastModified <> cDateTimeLastModified Then 'ファイル日付を書き換える rc = changeTimeStamp(newFile) If rc = 1 Then ret = ret + 2 Else ret = ret + 3 End If Else ret = ret + 1 End If '戻り値に9(タグなし)セット ret = CInt(Replace(Format(ret, "0000"), "0", "9")) Else 'パス未定 (元ファイル未設定) ret = -1 End If Ex_SaveChanged: On Error Resume Next Close inFlNum Close outFlNum On Error GoTo 0 SaveChanged = ret Exit Function Er1_SaveChanged: 'ファイルオープン失敗 ret = -1 Resume Ex_SaveChanged: End Function '********************************************************************* ' ファイル名を渡しそのファイルの実在確認と情報取得を行う。 ' fullPathはコンストラクタの引数にしたいところだが、 ' 引数付きコンストラクタを作成できないのでこのメソッドを用意した。 ' ret 0: JpegExifファイルである ' 2: JpegファイルであるがExifではない (画像サイズは取得できる) ' -1: ファイルが存在しない ' -2: (存在はするが)オープンできない ' -3: Jpegファイルではない ' -11: 格納データのフォーマットにエラーがある '********************************************************************* Public Function InitSet(ByVal fullPath As String) As Integer Dim ret As Integer Dim fso As Object Set fso = CreateObject("Scripting.FileSystemObject") If fso.FileExists(fullPath) Then With fso.GetFile(fullPath) cName = .Name cPath = .Path 'ファイル名も含めたフルパス cDateTimeLastModified = .DateLastModified End With ret = readJPEG() Else ret = -1 End If Set fso = Nothing InitSet = ret End Function '----- プライベート関数 ----- '---------------------------------------------------- ' Jpegファイルを読む ' ret 0: JpegExifである ' 2: JpegファイルではあるがExif形式ではない ' -2: ファイルオープン失敗 ' -3: Jpegファイルではない ' -11: データエラーあり '---------------------------------------------------- Private Function readJPEG() As Integer Dim ret As Integer Dim i As Integer Dim fnum As Integer Dim b1 As Byte Dim b2(0 To 1) As Byte Dim b4(0 To 3) As Byte Dim ba() As Byte Dim fPointer As Long 'ファイル先頭を0とする Dim segSize As Long Dim segStart As Long Dim offset As Long fnum = FreeFile On Error GoTo Er_readJPEG Open cPath For Binary Access Read As #fnum On Error GoTo 0 cFileSize = LOF(fnum) '1. SOI(StartOfImage)マーカ の確認 ' ファイル先頭が ffd8 であること fPointer = Seek(fnum) - 1 'seek関数はファイル先頭を1とするので If fPointer + 2 > cFileSize Then '読み出し不可 ret = -3 Else Get #fnum, , b2 fPointer = fPointer + 2 If Not (b2(0) = &HFF And b2(1) = &HD8) Then ret = -3 End If End If If ret < 0 Then GoTo Ex_readJPEG '2. 最初の「データ部を持つJPEGマーカ」を読む ' SOIマーカの直後 ' ff MM SS SS ' MM: マーカ識別子。Exif用のAPP1マーカの場合は e1 ' SS SS: このマーカセグメントのサイズ(上位のSSを基点とする) 符合なしBigEndian If fPointer + 4 > cFileSize Then '読み出し不可 ret = -3 Else ReDim ba(0 To 3) Get #fnum, , ba fPointer = fPointer + 4 If ba(0) = &HFF Then 'JPEGマーカ segStart = fPointer - 2 segSize = CLng(ba(2)) * 256 + CLng(ba(3)) If ba(1) = &HE1 Then '3. Exif証明書の確認 'APP1マーカであるなら続く6バイトが固定 ' 45 78 69 66 00 00 ' E x i f If fPointer + 6 > cFileSize Then ret = -11 Else ReDim ba(0 To 5) Get #fnum, , ba fPointer = fPointer + 6 If Not (ba(0) = &H45 And ba(1) = &H78 And ba(2) = &H69 And ba(3) = &H66 _ And ba(4) = 0 And ba(5) = 0) Then ret = -11 End If End If Else 'JPEGではあるが、Exif情報は持っていない ret = 2 End If Else 'JPEGファイルではない ret = -3 End If End If If ret < 0 Then GoTo Ex_readJPEG If ret = 0 Then 'Exif情報の読み出し ' Exif情報はTIFFのタグ形式。Exif証明書の直後から始まる '4. Tifヘッダの読み出し ' NN NN TT TT XX XX XX XX ' NN NN : 整数格納形式 4d4d=BigEndian 4949=LittleEndian ' TT TT : TIFF番号(整数。何を意味するかは不明) 値は &h2a (42) ' XX XX XX XX : 最初のIFD(ImageFileDirectory)へのオフセット ' 通常はTifヘッダの直後だから8 If fPointer + 8 > cFileSize Then ret = -11 Else 'Endian取得 Get #fnum, , b2 If b2(0) = &H49 And b2(1) = &H49 Then cEndian = -1 '既定値は1 End If 'TIFF番号の確認 Get #fnum, , b2 If bytesUnsignedToLong(b2) <> 42 Then 'TIFFヘッダではない ret = -11 Else 'Tiffタグ認定ができたと言うことで cAddrTifHead = fPointer 'IFD0へのオフセット値取得 Get #fnum, , b4 offset = bytesUnsignedToLong(b4) If offset > 0 Then 'IFD0 処理 offset = readIFD(fnum, offset) '次のIFD1はサムネイルに関する情報なので読まない 'IFD1で連鎖終了 Else 'オフセット値がおかしい。 '負数の場合はオフセット値が扱える範囲を超えているということだが、 '取得済みのファイルサイズ(符号あり長整数)を超えるというのはおかしい。 '0の場合は全く先に進めない。 ret = -11 End If End If End If If ret < 0 Then GoTo Ex_readJPEG End If '5. 画像サイズ取得 ' JPEGマーカ(ffc0)より取得する ' APP1タグとしてImageWidth, ImageLengthは定義されているが、 ' JPEGマーカとの重複になるので記載しないことになっている。 'ffc0マーカまでマーカ連鎖をたどる 'JPEGマーカフォーマット ' ff MM SS SS ReDim ba(0 To 3) Do Until ret < 0 Or segSize = 0 fPointer = segStart + segSize If fPointer + 4 > cFileSize Then ret = -11 Else Get #fnum, fPointer + 1, ba fPointer = fPointer + 4 If ba(0) = &HFF Then If ba(1) = &HC0 Then '目的のJPEGマーカに到達 'サイズに続く部分はマーカごとに異なる。 'ffcoマーカの場合は 'PP LL LL WW WW XX XX... ' PP: サンプル精度。通常は08 ' LL LL: イメージの縦サイズ、符合なし整数、BigEndian ' WW WW: イメージの横サイズ、同上 '5バイトだけ読み出す If fPointer + 5 > cFileSize Then ret = -11 Else Get #fnum, , b1 'PP 空読み Get #fnum, , ba cImageLength = CLng(ba(0)) * 256 + CLng(ba(1)) cImageWidth = CLng(ba(2)) * 256 + CLng(ba(3)) segSize = 0 End If Else segStart = fPointer - 2 segSize = CLng(ba(2)) * 256 + CLng(ba(3)) End If Else ret = -11 End If End If Loop Ex_readJPEG: On Error Resume Next Close fnum On Error GoTo 0 readJPEG = ret Exit Function Er_readJPEG: 'ファイルオープン失敗 ret = -2 Resume Ex_readJPEG End Function '--------------------------------------------------------------------------- ' ひとつのIFDを読み出し処理する ' ret: 次のIFDへのオフセット (次がない場合は0) ' IFDのフォーマット ' PP PP [エントリ群] NN NN ' PP PP: タグ個数 ' [エントリ群]: [エントリ](12byte)×タグ個数 ' NN NN: 次のIFDのオフセット(Tifヘッダ基点) ' エントリのフォーマット ' TT TT YY YY UU UU UU UU VV VV VV VV ' TT TT: タグ(番号) ' YY YY: データタイプ ' UU UU UU UU: 値の個数 ' VV VV VV VV: 値または値へのオフセット(Tifヘッダ基点) '--------------------------------------------------------------------------- Private Function readIFD(ByVal fnum As Integer, ByVal offset As Long) As Long Dim ret As Long Dim b2(0 To 1) As Byte Dim b4(0 To 3) As Byte Dim fPointer As Long '0基点 Dim tagCount As Long Dim tagInfo_Id() As Long Dim tagInfo_ValType() As Long Dim tagInfo_ValCount() As Long Dim tagInfo_Val() As Long Dim i As Long Dim nextIFD As Long Dim tmpStr As String fPointer = cAddrTifHead + offset 'タグ数の取得 Get #fnum, fPointer + 1, b2 tagCount = bytesUnsignedToLong(b2) If tagCount > 0 Then 'タグのエントリ情報取得 ' seekポインタはエントリ情報ブロック先頭(タグ数の直後)にある ReDim tagInfo_Id(0 To tagCount - 1) ReDim tagInfo_ValType(0 To tagCount - 1) ReDim tagInfo_ValCount(0 To tagCount - 1) ReDim tagInfo_Val(0 To tagCount - 1) For i = 0 To tagCount - 1 'タグID取得 Get #fnum, , b2 tagInfo_Id(i) = bytesUnsignedToLong(b2) '値の種類 Get #fnum, , b2 tagInfo_ValType(i) = bytesUnsignedToLong(b2) '値の個数 Get #fnum, , b4 tagInfo_ValCount(i) = bytesUnsignedToLong(b4) '値または値へのオフセット Get #fnum, , b4 Select Case tagInfo_ValType(i) Case 1 '1バイト符号なし整数 tagInfo_Val(i) = CLng(b4(0)) Case 2 'ASCII文字列へのオフセット tagInfo_Val(i) = bytesUnsignedToLong(b4) Case 3 '2バイト符号なし整数 b2(0) = b4(0) b2(1) = b4(1) tagInfo_Val(i) = bytesUnsignedToLong(b2) Case 4 '4バイト符号なし整数 tagInfo_Val(i) = bytesUnsignedToLong(b4) Case 5 '4バイト符号なし整数2個。オフセット tagInfo_Val(i) = bytesUnsignedToLong(b4) Case 7 '未定義のバイト列。タグにより扱い方が異なる If tagInfo_Id(i) = TAG_EXIFVERSION Then cExifVersion = Chr(b4(0)) & Chr(b4(1)) & Chr(b4(2)) & Chr(b4(3)) End If Case 9 '4バイト符号あり整数 tagInfo_Val(i) = bytesSignedToLong(b4) Case 10 '4バイト符号あり整数2個。オフセット tagInfo_Val(i) = bytesUnsignedToLong(b4) Case Else tagInfo_Val(i) = bytesUnsignedToLong(b4) End Select Next i '次のIFDへのオフセット取得(2byte!!) Get #fnum, , b2 ret = bytesUnsignedToLong(b2) 'エントリを順次処理 For i = 0 To tagCount - 1 If tagInfo_Id(i) = TAG_EXIF_IFD Then 'Exif IFDを処理する '取得した値はIFDへのオフセット nextIFD = tagInfo_Val(i) Do While nextIFD > 0 nextIFD = readIFD(fnum, nextIFD) Loop Else '取得の必要なTagのみ処理する Select Case tagInfo_Id(i) Case TAG_DATETIMEORIGINAL, TAG_DATETIME, TAG_DATETIMEDIGITIZED '----- 日付に関する2つのタグ追加 ver 1.10 '日付データの格納形式 'yyyy:mm:dd HH:MM:SS If tagInfo_ValType(i) = 2 And tagInfo_Val(i) > 0 Then tmpStr = readASCIIAt(cAddrTifHead + tagInfo_Val(i), tagInfo_ValCount(i), fnum) If Len(tmpStr) = 19 Then ' 日付の区切りをスラッシュに変更 Mid(tmpStr, 5, 1) = "/" Mid(tmpStr, 8, 1) = "/" On Error Resume Next Select Case tagInfo_Id(i) Case TAG_DATETIMEORIGINAL cDateTimeOriginal = CDate(tmpStr) cChangeDateTimeOriginal = cDateTimeOriginal cAddrDateTimeOriginal = cAddrTifHead + tagInfo_Val(i) cLenDateTimeOriginal = tagInfo_ValCount(i) Case TAG_DATETIME cDateTime = CDate(tmpStr) cChangeDateTime = cDateTime cAddrDateTime = cAddrTifHead + tagInfo_Val(i) cLenDateTime = tagInfo_ValCount(i) Case TAG_DATETIMEDIGITIZED cDateTimeDigitized = CDate(tmpStr) cChangeDateTimeDigitized = cDateTimeDigitized cAddrDateTimeDigitized = cAddrTifHead + tagInfo_Val(i) cLenDateTimeDigitized = tagInfo_ValCount(i) End Select On Error GoTo 0 End If End If Case TAG_MAKE 'メーカー If tagInfo_ValType(i) = 2 And tagInfo_Val(i) > 0 Then cMake = readASCIIAt(cAddrTifHead + tagInfo_Val(i), tagInfo_ValCount(i), fnum) End If Case TAG_MODEL 'モデル If tagInfo_ValType(i) = 2 And tagInfo_Val(i) > 0 Then cModel = readASCIIAt(cAddrTifHead + tagInfo_Val(i), tagInfo_ValCount(i), fnum) End If Case TAG_EXIFVERSION 'Exifバージョン 'すでに処理済み Case TAG_EXPOSURETIME '露出時間 If tagInfo_ValType(i) = 5 And tagInfo_Val(i) > 0 Then cExposureTime = readRationalAt(cAddrTifHead + tagInfo_Val(i), fnum) End If Case TAG_FLASH '発光 最下位ビットのオン・オフで判断する。 If tagInfo_Val(i) Mod 2 <> 0 Then cFlash = True Case TAG_FNUMBER 'Fナンバー If tagInfo_ValType(i) = 5 And tagInfo_Val(i) > 0 Then cFNumber = readRationalAt(cAddrTifHead + tagInfo_Val(i), fnum) End If End Select End If Next i End If readIFD = ret End Function '----------------------------------------------------------------------------- ' タグValue読み出し Type: 5(Rational)対応 ' 指定位置から符合なし4バイト整数2個を読み出す。分子・分母に相当。 ' 結果は2数をそれぞれ文字列に変換し、スラッシュで連結したもの。 ' ex) 28/10 ' 分子>=0かつ分母>0 が成り立たなければ空文字列を返す ' 引数 pos: 読み出し開始位置(ファイル先頭を0とする) ' fnum: 対象ファイルのオープン番号 '----------------------------------------------------------------------------- Private Function readRationalAt(ByVal pos As Long, ByVal fnum As Integer) As String Dim ret As String Dim b4(0 To 3) As Byte Dim tmpLong As Long Dim tmpRet As String If pos + 8 <= cFileSize Then Get #fnum, pos + 1, b4 tmpLong = bytesUnsignedToLong(b4) If tmpLong >= 0 Then tmpRet = CStr(tmpLong) Get #fnum, , b4 tmpLong = bytesUnsignedToLong(b4) If tmpLong > 0 Then ret = tmpRet & "/" & CStr(tmpLong) End If End If End If readRationalAt = ret End Function '-------------------------------------------------------------- ' タグValue読み出し Type: 2(ASCII)対応 ' 指定位置からASCII文字としてlength個読み出す。 ' ただし、Nullが出現した位置で読み出しを終了し、 ' Nullの直前までを戻り値とする。 ' 引数 pos: 読み出し開始位置(ファイル先頭を0とする) ' length: 読み出しバイト数 ' fnum: 対象ファイルのオープン番号 '-------------------------------------------------------------- Private Function readASCIIAt(ByVal pos As Long, ByVal length As Long, ByVal fnum As Integer) As String Dim ret As String Dim ba() As Byte Dim i As Long If length > 0 Then If pos + length <= cFileSize Then ReDim ba(0 To length - 1) Get #fnum, pos + 1, ba For i = 0 To length - 1 If ba(i) = 0 Then Exit For ret = ret & Chr(ba(i)) Next i End If End If readASCIIAt = ret End Function '----------------------------------------------------------------------------- ' 符号なし整数とみなすバイト配列を4バイト符号あり整数に変換 ' 引数の配列は0基底とする。 ' 4次元を超える配列はインデクス0〜3までを用いる。 ' 4次元の場合、戻り値が符号あり4バイト整数なので最上位ビットがonの場合は、 ' オーバーフローになってしまう。この場合は-1 を返す。 ' すなわち、2^31以上の格納値は扱えないということ。 '----------------------------------------------------------------------------- Private Function bytesUnsignedToLong(ba() As Byte) As Long Dim ret As Long Dim i As Integer Dim iMax As Integer iMax = UBound(ba) If iMax < 1 Then Exit Function If iMax > 3 Then iMax = 3 On Error GoTo Er_bytesUnsignedToLong If cEndian = -1 Then For i = 0 To iMax ret = ret + ba(i) * (256 ^ i) Next i Else For i = 0 To iMax ret = ret + ba(i) * (256 ^ (iMax - i)) Next i End If Ex_bytesUnsignedToLong: On Error GoTo 0 bytesUnsignedToLong = ret Exit Function Er_bytesUnsignedToLong: ret = -1 Resume Ex_bytesUnsignedToLong End Function '--------------------------------------------------------------------- ' 符合あり整数とみなすバイト配列を4バイト符合あり整数に変換 ' 引数の配列は0基底とする。 ' 4次元を超える配列はインデクス0〜3までを用いる。 '--------------------------------------------------------------------- Private Function bytesSignedToLong(ba() As Byte) As Long Dim ret As Long Dim bt() As Integer Dim i As Integer Dim iMax As Integer Dim s As Long Dim carry As Integer iMax = UBound(ba) If iMax < 1 Then Exit Function If iMax > 3 Then iMax = 3 'Little Endianとして処理を行うために配列を移し替える ReDim bt(0 To iMax) If cEndian = -1 Then For i = 0 To iMax bt(i) = CInt(ba(i)) Next i Else For i = 0 To iMax bt(i) = CInt(ba(iMax - i)) Next i End If '最上位バイトの最上位ビットを調べ結果値の符号を求める If bt(iMax) < 128 Then s = 1 Else s = -1 End If '負の場合のみ符号反転処理実施 If s = -1 Then '最下位バイトから順に繰り上げを考慮しながら2の補数に変換 carry = 0 '繰り上げ For i = 0 To iMax bt(i) = bt(i) + carry 'この操作でByte型の範囲を逸脱する可能性 'があるのでInteger型に変換してある If bt(i) > 0 Then bt(i) = &H100 - bt(i) carry = 1 End If Next i End If For i = 0 To iMax ret = ret + bt(i) * (256 ^ i) Next i bytesSignedToLong = ret * s End Function '---------------------------------------------------------------- ' ファイル日付変更 ファイルはクローズしてから呼び出すこと ' 最終更新日 (LastWriteTime)のみ変更する ' 引数 tFile: 変更するファイルフルパス ' ret 1: 正常終了 ' 0: ファイル開けない ' -1: 日付不正 '---------------------------------------------------------------- Private Function changeTimeStamp(ByVal tFile As String) As Integer Dim ret As Integer Dim rc As Long Dim lpSystemTime As SYSTEMTIME Dim lpLocalFileTime As FILETIME Dim lpFileTime As FILETIME Dim hFile As Long '変更日付をSYSTEMTIME型変数に格納 With lpSystemTime .wYear = Year(ChangeDateTimeLastModified) .wMonth = Month(ChangeDateTimeLastModified) .wDay = Day(ChangeDateTimeLastModified) .wHour = Hour(ChangeDateTimeLastModified) .wMinute = Minute(ChangeDateTimeLastModified) .wSecond = Second(ChangeDateTimeLastModified) End With '型変換 SYSTEMTIME -> FILETIME rc = SystemTimeToFileTime(lpSystemTime, lpLocalFileTime) If rc Then 'ローカルタイム -> UTC rc = LocalFileTimeToFileTime(lpLocalFileTime, lpFileTime) If rc Then 'ファイルを開く hFile = CreateFile(tFile, GENERIC_WRITE, 0, vbNullString, OPEN_EXISTING, FILE_ATTRIBUTE_ARCHIVE, 0) If hFile <> INVALID_HANDLE_VALUE Then 'ファイルタイムセット rc = SetFileTime(hFile, vbNullString, vbNullString, lpFileTime) If rc Then '日付変更成功 ret = 1 Else '失敗 ret = -1 End If 'ファイルクローズ rc = CloseHandle(hFile) Else 'ファイルが開けない ret = 0 End If Else 'どういうエラーなのかわからない ret = -1 End If Else '日付不正? ' ファイル日付には使えない日付だということだろう ret = -1 End If changeTimeStamp = ret End Function
【参考サイト・文献】
Windows98 API リファレンス for Visual Basic Programmers 河北潤二 (株)秀和システム
【改訂履歴】
2009/11/24
2009/12/01 本文の文字を少し小さくしました。
2010/07/27 最終更新日付変更のためのプロパティ(ChangeDateTimeLastModifies)の扱いを訂正しました。
btinc.jp ページ先頭 発表会演目一覧