タイムスタンプの更新の方法２

前回の質問の方法が悪かったので改めて質問させていただきます。よろしくお願い致します。
現在開いていないファイルのタイムスタンプを任意の日時にエクセルVBAから変更する方法をご伝授頂けないでしょうか？タイムスタンプの取得は簡単に出来そうなんですが、書き込み方法が解らず困っています。
宜しくお願い致します。

No.4 ベストアンサー 回答者： KenKen_SP 回答日時： 2005/11/28 12:22

すみません、、、

#3 の SetTIMESTAMP 関数で、

　Dim FSO As New FileSystemObject

は参照設定でコードを書いていたなごりです。
このまま参照設定しないとエラーになりますので、

　Dim FSO As Object

に修正いたします。

この回答への補足

すごい！すごい！すごい！の言葉しかでてきません！
私が、質問をアップしたのが、21:28！
第一回目のご指導が、日が変わって間もない1:44！
それを、ライブラリー化したのが、11:41！
更に、訂正を加えたのが、12:22！
サスペンスドラマなら、この短時間で一人で犯行を犯すのは絶対に不可能！！この事件は、複数犯であると警部が断定し迷宮入りとなるでしょう！
横に、見本があって、単に打ち込むだけでも、同じぐらいの時間がかかります。私は！しかも、内容の大部分が私の知っているベーシックではなく、ウルトラ文字で書いたてあり、辞書を片手に１字１字調べなきゃ読めん！！でも、使い方まで書いてある！！
あっ！判った！21:28以前に私が質問するのを察知していたのだなぁ？
って、感じです。感服致します。密かに、いつの日か？KenKen_SPのコードも素晴らしいのだけど、こんな表記もありますよ！！って、答える側に回ることを夢見ていましたが、現実を見ました。やはり、ガリバーには、カナイマセン！！師匠についていきます！何処までも！！
ショックが大きすぎて、お礼はまたの機会にします。ほんとうにありがとう御座いました。コードを打ち出して、壁に貼っておきます。今後とも宜しくお願いします。なんだか？質問が数行だけなのが申し訳ないです！！
(絶対に、読破してやる～！！)

補足日時：2005/11/28 21:00

No.3 回答者： KenKen_SP 回答日時： 2005/11/28 11:41

再びこんにちは。

KenKen_SP です。

自分でも使うだろうからタイムスタンプの取得・設定をライブラリー化して
みました。ちょっと仰々しいコードですが、ご参考までで。

フォルダのタイムスタンプにも対応してます。（設定はNT系OSのみ）
詳しい説明は省略しますが、末尾のサンプルコードを見て下さい。


Option Explicit

'// Win32API ファイルを作成またはオープン
Private Declare Function CreateFile Lib "kernel32.dll" _
　　Alias "CreateFileA" ( _
　　ByVal lpFileName As String, _
　　ByVal dwdesiredAccess As Long, _
　　ByVal dwShareMode As Long, _
　　ByRef lpSecurityAttributes As SECURITY_ATTRIBUTES, _
　　ByVal dwCreationDisposition As Long, _
　　ByVal dwFlagsAndAttributes As Long, _
　　ByVal hTemplateFile As Long) As Long

'// Win32API ファイルやディレクトリの属性を取得
Private Declare Function GetFileAttributes Lib "kernel32.dll" _
　　Alias "GetFileAttributesA" ( _
　　ByVal lpFileName$) As Long
　
'// Win32API 開かれているオブジェクトのハンドルを開放
Private Declare Function CloseHandle Lib "kernel32.dll" ( _
　　ByVal hObject As Long) As Long

'// Win32API システムタイムをファイルタイムに変換する
Private Declare Function SystemTimeToFileTime Lib "kernel32.dll" ( _
　　ByRef lpSystemTime As SYSTEMTIME, _
　　ByRef lpFileTime As FILETIME) As Long

'// Win32API ローカルファイルタイムをUTCファイルタイム形式で取得する
Private Declare Function LocalFileTimeToFileTime Lib "kernel32.dll" ( _
　　ByRef lpLocalFileTime As FILETIME, _
　　ByRef lpFileTime As FILETIME) As Long

'// Win32API ファイルのファイルタイムを設定する
Private Declare Function SetFileTime Lib "kernel32.dll" ( _
　　ByVal hFile As Long, _
　　ByRef lpCreationTime As FILETIME, _
　　ByRef lpLastAccessTime As FILETIME, _
　　ByRef lpLastWriteTime As FILETIME) As Long

'// SECURITY_ATTRIBUTES 構造体
Private Type SECURITY_ATTRIBUTES
　　nLength　　　　　　　As Long '構造体のバイト数
　　lpSecurityDescriptor As Long 'セキュリティデスクリプタ(Win95,98では無効)
　　bInheritHandle　　　 As Long '1のとき属性を継承する
End Type

'// SYSTEMTIME 構造体
Private Type SYSTEMTIME
　　wYear　　　　 As Integer '年
　　wMonth　　　　As Integer '月
　　wDayOfWeek　　As Integer '曜日(日=0, 月=1 ...)
　　wDay　　　　　As Integer '日
　　wHour　　　　 As Integer '時
　　wMinute　　　 As Integer '分
　　wSecond　　　 As Integer '秒
　　wMilliseconds As Integer 'ミリ秒
End Type

'// FILETIME 構造体
Private Type FILETIME
　　dwLowDateTime　As Long　 '下位32ビット値
　　dwHighDateTime As Long　 '上位32ビット値
End Type

'// 定数
Private Const FILE_FLAG_BACKUP_SEMANTICS As Long = &H2000000　'NT系OSのみ
Private Const GENERIC_READ　　　　　　　 As Long = &H80000000
Private Const GENERIC_WRITE　　　　　　　As Long = &H40000000
Private Const FILE_SHARE_READ　　　　　　As Long = &H1
Private Const FILE_ATTRIBUTE_NORMAL　　　As Long = &H80
Private Const OPEN_EXISTING　　　　　　　As Long = 3
Private Const OPEN_ALWAYS　　　　　　　　As Long = 4
Private Const INVALID_HANDLE_VALUE　　　 As Long = &HFFFFFFFF

'// ファイルまたはフォルダのタイムスタンプ設定関数 2005/11/28
Public Function SetTIMESTAMP( _
　　ByVal strFULLPATH As String, _
　　Optional ByVal datCREATETIME As Date, _
　　Optional ByVal datACCESSTIME As Date, _
　　Optional ByVal datMODIFYTIME As Date) As Boolean
　　
　　Dim lngHANDLE As Long
　　Dim lngFLAG　 As Long
　　Dim lngRET　　As Long
　　Dim udtCREATE As FILETIME
　　Dim udtACCESS As FILETIME
　　Dim udtMODIFY As FILETIME
　　Dim udtSEQRTY As SECURITY_ATTRIBUTES
　　Dim FSO As New FileSystemObject
　　Dim OBJ As Object
　　
　　'// 対象の存在チェックとdwFlagsAndAttributes の設定
　　Set FSO = CreateObject("Scripting.FileSystemObject")
　　If FSO.FileExists(strFULLPATH) Then
　　　　'ファイルの場合
　　　　Set OBJ = FSO.GetFile(strFULLPATH)
　　　　lngFLAG = FILE_ATTRIBUTE_NORMAL
　　ElseIf FSO.FolderExists(strFULLPATH) Then
　　　　'フォルダの場合(NT系のOSのみ可能)
　　　　If InStr(Application.OperatingSystem, "NT") > 0 Then
　　　　　　Set OBJ = FSO.GetFolder(strFULLPATH)
　　　　　　lngFLAG = FILE_ATTRIBUTE_NORMAL Or FILE_FLAG_BACKUP_SEMANTICS
　　　　Else
　　　　　　GoTo TERMINATE
　　　　End If
　　Else
　　　　'ファイルもフォルダも見つからない場合
　　　　GoTo TERMINATE
　　End If
　　
　　'// オプション引数が省略された場合は現状のものを補完
　　With OBJ
　　　　If datCREATETIME = 0 Then datCREATETIME = .DateCreated
　　　　If datACCESSTIME = 0 Then datACCESSTIME = .DateLastAccessed
　　　　If datMODIFYTIME = 0 Then datMODIFYTIME = .DateLastModified
　　End With

　　'// SECURITY_ATTRIBUTES構造体初期化
　　With udtSEQRTY
　　　　.nLength = LenB(udtSEQRTY)
　　　　.lpSecurityDescriptor = 0&
　　　　.bInheritHandle = 0&
　　End With
　　
　　'// ファイルまたはフォルダハンドルを取得
　　lngHANDLE = CreateFile(strFULLPATH, GENERIC_WRITE, _
　　　　FILE_SHARE_READ, udtSEQRTY, OPEN_EXISTING, lngFLAG, vbNull)
　　If lngHANDLE = INVALID_HANDLE_VALUE Then GoTo TERMINATE
　　　　
　　'// ファイルタイムに変換し、設定する
　　udtCREATE = GetFILETIME(datCREATETIME)
　　udtACCESS = GetFILETIME(datACCESSTIME)
　　udtMODIFY = GetFILETIME(datMODIFYTIME)
　　lngRET = SetFileTime(lngHANDLE, udtCREATE, udtCREATE, udtMODIFY)
　　If lngRET <> 0 Then SetTIMESTAMP = True
　　
　　'// ファイルまたはフォルダハンドル開放
　　CloseHandle lngHANDLE

TERMINATE:
　　Set OBJ = Nothing
　　Set FSO = Nothing

End Function

'// ファイルまたはフォルダのタイムスタンプ取得関数 2005/11/28
Public Function GetTIMESTAMP( _
　　ByVal strFULLPATH As String, _
　　ByRef datCREATETIME As Date, _
　　ByRef datACCESSTIME As Date, _
　　ByRef datMODIFYTIME As Date) As Boolean
　　　　
　　Dim FSO As Object 'New FileSystemObject
　　Dim OBJ As Object

　　Set FSO = CreateObject("Scripting.FileSystemObject")
　　If FSO.FileExists(strFULLPATH) Then
　　　　Set OBJ = FSO.GetFile(strFULLPATH)
　　ElseIf FSO.FolderExists(strFULLPATH) Then
　　　　Set OBJ = FSO.GetFolder(strFULLPATH)
　　Else
　　　　GoTo TERMINATE
　　End If
　　With OBJ
　　　　datCREATETIME = CDate(.DateCreated)
　　　　datACCESSTIME = CDate(.DateLastAccessed)
　　　　datMODIFYTIME = CDate(.DateLastModified)
　　End With
　　GetTIMESTAMP = True
　　
TERMINATE:
　　Set OBJ = Nothing
　　Set FSO = Nothing
　　Exit Function
　　
ERROR_HANDLER:
　　GetTIMESTAMP = 0
　　GoTo TERMINATE
　　
End Function

'// UTCファイルタイム変換関数 2005/11/28
Private Function GetFILETIME(ByVal datPARAM As Date) As FILETIME
　　
　　Dim udtSysTime As SYSTEMTIME
　　Dim udtLclTime As FILETIME
　　With udtSysTime
　　　　.wYear = Year(datPARAM)
　　　　.wMonth = Month(datPARAM)
　　　　.wDayOfWeek = Weekday(datPARAM)
　　　　.wDay = Day(datPARAM)
　　　　.wHour = Hour(datPARAM)
　　　　.wMinute = Minute(datPARAM)
　　　　.wSecond = Second(datPARAM)
　　　　.wMilliseconds = 0
　　End With
　　Call SystemTimeToFileTime(udtSysTime, udtLclTime)
　　Call LocalFileTimeToFileTime(udtLclTime, GetFILETIME)

End Function

'// 使い方サンプル
Sub SampleCode()

　　Dim strPATH As String
　　Dim datCREATETIME As Date
　　Dim datACCESSTIME As Date
　　Dim datMODIFYTIME As Date
　　
　　strPATH = Application.GetOpenFilename("ファイル (*.*), *.*")
　　If UCase$(strPATH) = "FALSE" Then
　　　　Exit Sub
　　End If

　　'// タイムスタンプ取得サンプル
　　If GetTIMESTAMP(strPATH, datCREATETIME, datACCESSTIME, datMODIFYTIME) Then
　　　　
　　　　MsgBox "タイムスタンプを取得しました" & vbCrLf & _
　　　　　　　 "CREATE:= " & CStr(datCREATETIME) & vbCrLf & _
　　　　　　　 "MODIFY:= " & CStr(datMODIFYTIME) & vbCrLf & _
　　　　　　　 "ACCESS:= " & CStr(datACCESSTIME) & vbCrLf, vbInformation
　　Else
　　　　MsgBox "タイムスタンプ取得に失敗しました", vbCritical
　　　　Exit Sub
　　End If
　　
　　MsgBox "更新日時を現在（Now関数の戻り値）に設定します", vbInformation
　　　　
　　'// タイムスタンプ設定サンプル
　　'更新日時を現在（Now関数の戻り値）に設定します
　　If SetTIMESTAMP(strPATH, , , Now()) Then
　　　　Call GetTIMESTAMP(strPATH, datCREATETIME, datACCESSTIME, datMODIFYTIME)
　　　　MsgBox "タイムスタンプを更新しました。" & vbCrLf & _
　　　　　　　 "CREATE:= " & CStr(datCREATETIME) & vbCrLf & _
　　　　　　　 "MODIFY:= " & CStr(datMODIFYTIME) & vbCrLf & _
　　　　　　　 "ACCESS:= " & CStr(datACCESSTIME) & vbCrLf, vbInformation
　　Else
　　　　MsgBox "タイムスタンプ設定に失敗しました", vbCritical
　　End If

End Sub

No.2 回答者： KenKen_SP 回答日時： 2005/11/28 01:44

こんにちは。

KenKen_SP です。

タイムスタンプは VBA の FileDateTime 関数でも取得できますが、FileSystemObject でも取得できます。ファイルシステムに関する処理には非常に便利ですから、こちらも覚えておいて損はないです。今回の関数内でも使用しています。

タイムスタンプの設定については、残念ながら VBA と VB6までには関数が用意されてません。これを実現するためには Win32Api を使うことになりますが、結構面倒くさいですね。関数化してみましたが、結構長いコードになってしまいました。

国内で使用する場合は問題ないと思いますが、ひょっとするとタイムゾーンの相違とか、OS とファイルシステムの組み合わせなどが原因となってコケる可能性があります。（手抜きです）

一番下に使い方サンプルを書いておきましたが、仕様は次のとおりです。

　　SetTIMESTAMP(ファイルのフルパス,作成日時,最終アクセス日時,更新日時）

戻り値は成功すると True、失敗で False を返します。ファイルパス以外はオプションですから指定しなくても構いません。例えば、作成日時だけを現在時刻にするなら、

　　Call SetTIMESTAMP("C:\Test.xls",Now())

だし、更新日時のみを設定するなら、

　　Call SetTIMESTAMP("C:\Test.xls", , ,Now())

です。省略された部分は変更前のタイムスタンプがそのまま維持されます。なお、ファイルが既に開かれていたり、読み取り専用属性などがついているとタイムスタンプの変更に失敗しますが、エラートラップしてありますので、関数の実行結果としては False が返ります。

では。


Option Explicit

'// Win32Api ファイルを作成またはオープン
Private Declare Function CreateFile Lib "kernel32.dll" Alias "CreateFileA" ( _
　　ByVal lpFileName As String, _
　　ByVal dwdesiredAccess As Long, _
　　ByVal dwShareMode As Long, _
　　ByRef lpSecurityAttributes As SECURITY_ATTRIBUTES, _
　　ByVal dwCreationDisposition As Long, _
　　ByVal dwFlagsAndAttributes As Long, _
　　ByVal hTemplateFile As Long) As Long
　　
'// Win32Api 開かれているオブジェクトのハンドルを開放
Private Declare Function CloseHandle Lib "kernel32.dll" ( _
　　ByVal hObject As Long) As Long

'// Win32Api システムタイムをファイルタイムに変換する
Private Declare Function SystemTimeToFileTime Lib "kernel32.dll" ( _
　　ByRef lpSystemTime As SYSTEMTIME, _
　　ByRef lpFileTime As FILETIME) As Long

'// Win32Api ローカルファイルタイムをUTCファイルタイム形式で取得する
Private Declare Function LocalFileTimeToFileTime Lib "kernel32.dll" ( _
　　ByRef lpLocalFileTime As FILETIME, _
　　ByRef lpFileTime As FILETIME) As Long

'// Win32Api ファイルのファイルタイムを設定する
Private Declare Function SetFileTime Lib "kernel32.dll" ( _
　　ByVal hFile As Long, _
　　ByRef lpCreationTime As FILETIME, _
　　ByRef lpLastAccessTime As FILETIME, _
　　ByRef lpLastWriteTime As FILETIME) As Long

'// SECURITY_ATTRIBUTES構造体
Private Type SECURITY_ATTRIBUTES
　　nLength As Long　　　　　　　'構造体のバイト数
　　lpSecurityDescriptor As Long 'セキュリティデスクリプタ(Win95,98では無効)
　　bInheritHandle As Long　　　 '1のとき属性を継承する
End Type

'// SYSTEMTIME構造体
Private Type SYSTEMTIME
　　wYear　　　　 As Integer '現在の年
　　wMonth　　　　As Integer '月
　　wDayOfWeek　　As Integer '曜日(日=0, 月=1 ...)
　　wDay　　　　　As Integer '日
　　wHour　　　　 As Integer '時
　　wMinute　　　 As Integer '分
　　wSecond　　　 As Integer '秒
　　wMilliseconds As Integer 'ミリ秒
End Type

'// FILETIME構造体
Private Type FILETIME
　　dwLowDateTime　As Long　 '下位32ビット値
　　dwHighDateTime As Long　 '上位32ビット値
End Type

'// 定数
Private Const GENERIC_READ　　　　　As Long = &H80000000
Private Const GENERIC_WRITE　　　　 As Long = &H40000000
Private Const FILE_SHARE_READ　　　 As Long = &H1
Private Const FILE_ATTRIBUTE_NORMAL As Long = &H80
Private Const OPEN_EXISTING　　　　 As Long = 3
Private Const OPEN_ALWAYS　　　　　 As Long = 4

'// ファイルタイム変換
Private Function GetFILETIME(ByVal datPARAM As Date) As FILETIME
　　
　　Dim udtSysTime As SYSTEMTIME
　　Dim udtLclTime As FILETIME
　　With udtSysTime
　　　　.wYear = Year(datPARAM)
　　　　.wMonth = Month(datPARAM)
　　　　.wDayOfWeek = Weekday(datPARAM)
　　　　.wDay = Day(datPARAM)
　　　　.wHour = Hour(datPARAM)
　　　　.wMinute = Minute(datPARAM)
　　　　.wSecond = Second(datPARAM)
　　　　.wMilliseconds = 0
　　End With
　　Call SystemTimeToFileTime(udtSysTime, udtLclTime)
　　Call LocalFileTimeToFileTime(udtLclTime, GetFILETIME)

End Function

'// ファイルのタイムスタンプを設定
Public Function SetTIMESTAMP(ByVal strFILE_FULLPATH As String, _
　　Optional ByVal datCREATETIME As Date, _
　　Optional ByVal datACCESSTIME As Date, _
　　Optional ByVal datMODIFYTIME As Date) As Boolean
　　
　　Dim lngFILEHL As Long
　　Dim lngRET　　As Long
　　Dim udtCREATE As FILETIME
　　Dim udtACCESS As FILETIME
　　Dim udtMODIFY As FILETIME
　　Dim udtSEQRTY As SECURITY_ATTRIBUTES
　　
　　If Dir(strFILE_FULLPATH) = "" Then Exit Function
　　
　　'// SECURITY_ATTRIBUTES構造体初期化
　　With udtSEQRTY
　　　　.nLength = LenB(udtSEQRTY)
　　　　.lpSecurityDescriptor = 0&
　　　　.bInheritHandle = 0&
　　End With

　　'// ファイルハンドル取得
　　lngFILEHL = CreateFile( _
　　　　strFILE_FULLPATH, _
　　　　GENERIC_WRITE, _
　　　　FILE_SHARE_READ, _
　　　　udtSEQRTY, _
　　　　OPEN_EXISTING, _
　　　　FILE_ATTRIBUTE_NORMAL, _
　　　　vbNull)
　　If lngFILEHL = &HFFFFFFFF Then Exit Function 'Invalid Handle
　　
　　'// オプション引数が省略された場合は現状のものを補完
　　Dim FSO As Object
　　Set FSO = CreateObject("Scripting.FileSystemObject")
　　With FSO.GetFile(strFILE_FULLPATH)
　　　　If datCREATETIME = 0 Then datCREATETIME = .DateCreated
　　　　If datACCESSTIME = 0 Then datACCESSTIME = .DateLastAccessed
　　　　If datMODIFYTIME = 0 Then datMODIFYTIME = .DateLastModified
　　End With
　　Set FSO = Nothing
　　
　　'// ローカルタイムをUTCファイルタイム形式に変換
　　udtCREATE = GetFILETIME(datCREATETIME)
　　udtACCESS = GetFILETIME(datACCESSTIME)
　　udtMODIFY = GetFILETIME(datMODIFYTIME)
　　
　　'// タイムスタンプ設定
　　lngRET = SetFileTime(lngFILEHL, udtCREATE, udtACCESS, udtMODIFY)
　　If lngRET <> 0 Then SetTIMESTAMP = True
　　
　　'// ファイルハンドルを開放
　　CloseHandle lngFILEHL

End Function

'// 使い方サンプル
Sub SampleCode()
　　
　　'現在（Now関数の戻り値）に変更してみます
　　If SetTIMESTAMP("C:\test.txt", Now(), Now(), Now()) Then
　　　　MsgBox "タイムスタンプを設定しました", vbInformation
　　Else
　　　　MsgBox "タイムスタンプの設定に失敗しました", vbCritical
　　End If
　　
End Sub

No.1 回答者： Wendy02 回答日時： 2005/11/27 22:15

こんばんは。

Wendy02です。

＞ディレクトリーに記載されているタイムスタンプをバージョン表記にしたいと考えています。

通常、私などは、Office製品では、

BuiltinDocumentProperties
や
CustomDocumentProperties

を使いますね。以下のように使います。

Sub RevisionSetting()
'版の設定
　ThisWorkbook.BuiltinDocumentProperties(8) = 1 'Revision number
End Sub
'終了ごとに、0.1 を足すなどすればよいでしょう。

Sub RevisionShowUp()
'版の閲覧
　MsgBox ThisWorkbook.BuiltinDocumentProperties(8)
End Sub

設定すると、プロパティの統計（タブ）の改定番号という場所に記載されます。

それと、私は、Win32 APIのApiViewer のアドインは使っていますし、資料もいくつかはあるのですが、今のところ、自力では組めないので、以下をご覧になってください。それは、私の範囲外です。

SetFileTime 関数を使うようですが。

http://www31.ocn.ne.jp/~heropa/vb02.htm
ファイルのタイムスタンプの取得・設定

http://jeanne.wankuma.com/tips/file/09-settimest …
ファイルのタイムスタンプを設定する

この回答への補足

いつも、いつもありがとう御座います。
BuiltinDocumentProperties？stomDocumentProperties
？また、新しい言葉が出てきました！！
いつもながら、学ぶこと一杯です。最終的には、ＶＢとＶＣを一緒に習得していかなきゃ、マスター(何を持ってマスターと言うかは別にして・・)出来ないのかも？って思いはじめました。構造体や、API、クラス、プロパティプロシージャーなんてあまり、VBAの本には載っていないですから？この上、次のエクセルが.NETに対応すると、もう、雲の上の存在になるんでしょうか？VBAが無くなってしまったらどうしよう？って思います。早く、初心者を卒業して初級者になれるように、もっと、ガンバロウ！！って思います。ますますのご指導のほどよろしくお願い致します。本当にありがとう御座いました。

補足日時：2005/11/28 21:04