LoginSignup
0
0

Delete article

Deleted articles cannot be recovered.

Draft of this article would be also deleted.

Are you sure you want to delete this article?

More than 5 years have passed since last update.

@Q11Q

VBA Win32API使用タイムスタンプ更新の方法 VBA7版

Last updated at Posted at 2018-08-29

教えてGoo!の記事

https://oshiete.goo.ne.jp/qa/1805400.html
のVBA7 64 32 共用版にする

参考

ユーザー定義型を渡す

  • 通常、データ構造を必要とする引数は、"long ポインタ" として宣言されます。
  • long ポインタは、32 ビットの数値で、メモリ内のデータ構造をポイントします。
  • long ポインタで一般的に使用されているプリフィックスは "lp" です。
  • また、引数のデータ型はデータ構造の名前になります。

入手可能な Windows SDK について

重要な注意

このVBAは必ずどうでもいいフォルダやファイルを作って実験しましょう
また、ほかのDeclareの入っているVBAマクロとは一緒にしないでください。
なぜかというとPublicで宣言している部分があるためです。
これをPrivateに変えれば一応大丈夫ですが、それでもエラーが出ます。
エラーが出るだけならまだしもExcelがダウンします。
とくに設定に失敗しました、エラーが出た場合にはExcelがファイルを握って解放しなくなるため、いったんExcelを終了させることを推奨します。

サマータイムがたぶん対応できない

このVBAではタイムゾーン判定がありません。
もし日本政府が安倍晋三と経団連などの超国家資本主義に乗っ取られ、サマータイムが決定された場合にはこのシステムは再度チェックしなおさないと無理です。

コード

ポイント

Declare Dimの書き換え

いくつかのものはVBA7にするときにさらに、Win64に書き換える必要がある。
特にFileHandleがLongPtrになるため、そこで、変数（DIM）、構造体（Type）の書き換えが生じる。

CreateFileAの謎

Win32API_PtrSafe.TXT -- Declare statements for Visual Basic for Applications and Microsoft Office 2010
では


Declare PtrSafe Function CreateFile Lib "kernel32" Alias "CreateFileA" (ByVal lpFileName As String, ByVal dwDesiredAccess As Long, ByVal dwShareMode As Long, lpSecurityAttributes As SECURITY_ATTRIBUTES, ByVal dwCreationDisposition As Long, ByVal dwFlagsAndAttributes As Long, ByVal hTemplateFile As LongPtr) As LongPtr

lpSecurityAttributes As SECURITY_ATTRIBUTES
となっています。

教えて！Gooのサイトでは、

'// 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

この行をみてください
　　ByRef lpSecurityAttributes As SECURITY_ATTRIBUTES, _
こうしている場合、Subプロシージャでは

CreateFileAはSecurite_Attribute初期化

    '// SECURITY_ATTRIBUTES構造体初期化
    With udtSEQRTY
        .nLength = LenB(udtSEQRTY)
        .lpSecurityDescriptor = 0&
        .bInheritHandle = 0&
    End With

をしないと
lpSecurityAttributes As SECURITY_ATTRIBUTES
で Byref 引数の型が一致しません
とエラーになります。
このエラーを回避する方法としてDeclareでlpSecurityAttributes As Longにする方法があります。
Chip Pearsonはこの方法をとっています。
Get/Set File Times - Chip Pearson Pearson Software Consulting Services


Private Declare Function CreateFile Lib "kernel32" Alias "CreateFileA" _
    (ByVal lpFilename As String, _
    ByVal dwDesiredAccess As Long, _
    ByVal dwShareMode As Long, _
    ByVal lpSecurityAttributes As Long, _
    ByVal dwCreationDisposition As Long, _
    ByVal dwFlagsAndAttributes As Long, _
    ByVal hTemplateFile As Long) As Long

# If VBA7 Then
'lpSecurityAttributes As SECURITY_ATTRIBUTES をLongに変更
Private Declare PtrSafe Function CreateFile Lib "kernel32" Alias "CreateFileA" _
            (ByVal lpFileName As String, _
             ByVal dwDesiredAccess As Long, _
             ByVal dwShareMode As Long, _
             lpSecurityAttributes As Long, _
             ByVal dwCreationDisposition As Long, _
             ByVal dwFlagsAndAttributes As Long, _
             ByVal hTemplateFile As LongPtr) As LongPtr
# Else

Private Declare Function CreateFile Lib "kernel32" Alias "CreateFileA" _
    (ByVal lpFilename As String, _
    ByVal dwDesiredAccess As Long, _
    ByVal dwShareMode As Long, _
    ByVal lpSecurityAttributes As Long, _
    ByVal dwCreationDisposition As Long, _
    ByVal dwFlagsAndAttributes As Long, _
    ByVal hTemplateFile As Long) As Long
# End IF

この場合は下記のコード中SetTIMESTAMPは

'// ファイルまたはフォルダのタイムスタンプ設定関数 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
    #If VBA7 Then
    Dim lngHANDLE As LongPtr
    #Else
    Dim lngHANDLE As Long
    #End If
    Dim lngFLAG   As Long
    Dim lngRET    As Long
    Dim udtCREATE As FileTime
    Dim udtACCESS As FileTime
    Dim udtMODIFY As FileTime
    Dim udtSEQRTY As Long
    '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(lpFileName:=strFULLPATH, dwDesiredAccess:=GENERIC_WRITE, _
      dwShareMode:=FILE_SHARE_READ, lpSecurityAttributes:=udtSEQRTY, dwCreationDisposition:=OPEN_EXISTING, dwFlagsAndAttributes:=lngFLAG, hTemplateFile:=vbNull)
      If lngHANDLE = INVALID_HANDLE_VALUE Then
      GoTo TERMINATE
    End If
    '// ファイルタイムに変換し、設定する
    udtCREATE = GetFILETIME_By_Kenken(datCREATETIME)
    udtACCESS = GetFILETIME_By_Kenken(datACCESSTIME)
    udtMODIFY = GetFILETIME_By_Kenken(datMODIFYTIME)
    lngRET = SetFileTime(lngHANDLE, udtCREATE, udtCREATE, udtMODIFY)
    If lngRET <> 0 Then SetTIMESTAMP = True

    '// ファイルまたはフォルダハンドル開放
    CloseHandle lngHANDLE

TERMINATE:
    Set obj = Nothing
    Set fso = Nothing

End Function

コード

Option Explicit

'FILETIME構造体です。 このタイプには、2つのLong 32ビット整数が含まれ、64ビット整数を作成します。 この64ビット整数の値は、1601年1月1日以降に経過した100ナノ秒の間隔の数です。
'FILETIMEの定義を以下に示します。
Public Type FileTime
    dwLowDateTime As Long
    dwHighDateTime As Long
End Type

'SYSTEMTIMEのwDayOfWeek要素はSunday = 0?Saturday = 6に基づいていることに注意してください。
'これはWeekday VBとは異なりますので、wDayOfWeek要素を設定するときはWeekday関数の結果から1を減算するか、 wDayOfWeek要素を取得するときにwDayOfWeekを返します。

Public 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
'参照設定するScripting.FileSystem用の構造体
Private Type fsoTime
DateCreate As Date
DateAccess As Date
LastModifi As Date
End Type
'' セキュリティを定義する構造体
'// SECURITY_ATTRIBUTES 構造体
# If VBA7 Then
Public Type SECURITY_ATTRIBUTES
        nLength As Long '構造体のバイト数
        lpSecurityDescriptor As LongPtr 'セキュリティデスクリプタ(Win95,98では無効)
        bInheritHandle As Long '1のとき属性を継承する
End Type
# Else
Public Type SECURITY_ATTRIBUTES
  nLength As Long '構造体のバイト数
  lpSecurityDescriptor As Long 'セキュリティデスクリプタ(Win95,98では無効)
  bInheritHandle As Long '1のとき属性を継承する
End Type
# End If

'''''''''''''''''''''''''''''''''''
' Misc Constants
'''''''''''''''''''''''''''''''''''
Private Const NULL_LONG As Long = 0&
Private Const C_ERROR As Long = -1&
' 定数の定義
Public Const FILE_ATTRIBUTE_NORMAL As Long = &H80
Public Const FILE_FLAG_BACKUP_SEMANTICS As Long = &H2000000  'NT系OSのみ


'''''''''''''''''''''''''''''''''''
' used by CreateFile
'''''''''''''''''''''''''''''''''''
Private Const OPEN_EXISTING = &H3
Private Const FILE_SHARE_READ = &H1
Private Const FILE_SHARE_WRITE = &H2
Private Const CREATE_ALWAYS = &H2
Private Const OPEN_ALWAYS = &H4
Private Const INVALID_HANDLE_VALUE = -1
Private Const ERROR_ALREADY_EXISTS = &HB7
Private Const GENERIC_ALL = &H10000000
Private Const GENERIC_EXECUTE = &H20000000
Private Const GENERIC_READ = &H80000000
Private Const GENERIC_WRITE = &H40000000

'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
'システムがFILETIMEとしてファイル時間を格納し、GetFileTimeおよびSetFileTime Windows API関数の結果はFILETIME形式を使用し、これらの時間をGMT時間値として保存します。
'SetFileDateTime関数とGetFileDateTime関数の入出力は、VB / VBAシリアル日付形式です。
'これらの関数は、GetFileTimeとSetFileTimeの結果をGMTから現地時間に調整し、夏時間を勘案して現地時間を考慮します（GMTでは夏時間が観測されません）。
'FileDateToProcessというenum変数を使用して､読み書きする日付を指定します｡ この列挙型は以下の通りです:

'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
Public Enum FileDateToProcess
    FileDateCreate = 1
    FileDateLastAccess = 2
    FileDateLastModified = 3
End Enum
' 日付と時刻を定義する構造体
Public Type TIME_ZONE_INFORMATION
    Bias As Long
    StandardName(0 To 31) As Integer
    StandardDate As SYSTEMTIME
    StandardBias As Long
    DaylightName(0 To 31) As Integer
    DaylightDate As SYSTEMTIME
    DaylightBias As Long
End Type
'' ファイルなどの作成やオープンや切り捨てを行う関数の宣言
# If VBA7 Then
'lpSecurityAttributes As SECURITY_ATTRIBUTES をLongに変更
Private Declare PtrSafe Function CreateFile Lib "kernel32" Alias "CreateFileA" _
            (ByVal lpFileName As String, _
             ByVal dwDesiredAccess As Long, _
             ByVal dwShareMode As Long, _
             lpSecurityAttributes As SECURITY_ATTRIBUTES, _
             ByVal dwCreationDisposition As Long, _
             ByVal dwFlagsAndAttributes As Long, _
             ByVal hTemplateFile As LongPtr) As LongPtr
Private Declare PtrSafe Function SetFileTime Lib "kernel32" (ByVal hFile As LongPtr, lpCreationTime As FileTime, lpLastAccessTime As FileTime, lpLastWriteTime As FileTime) As Long

# Else
Private Declare Function CreateFile Lib "kernel32" Alias "CreateFileA" _
    (ByVal lpFilename As String, _
    ByVal dwDesiredAccess As Long, _
    ByVal dwShareMode As Long, _
    ByVal lpSecurityAttributes As Long, _
    ByVal dwCreationDisposition As Long, _
    ByVal dwFlagsAndAttributes As Long, _
    ByVal hTemplateFile As Long) As Long
# End If

Const DELETE = &H10000
Const READ_CONTROL = &H20000
Const WRITE_DAC = &H40000
Const WRITE_OWNER = &H80000
Const SYNCHRONIZE = &H100000

Const STANDARD_RIGHTS_READ = (READ_CONTROL)
Const STANDARD_RIGHTS_WRITE = (READ_CONTROL)
Const STANDARD_RIGHTS_EXECUTE = (READ_CONTROL)
Const STANDARD_RIGHTS_REQUIRED = &HF0000
Const STANDARD_RIGHTS_ALL = &H1F0000
Const INVALID_FILE_ATTRIBUTES As Long = -1
'https://stackoverflow.com/questions/27532207/network-file-path-not-opening-in-vba-msaccess
'// Win32API ファイルやディレクトリの属性を取得
# If VBA7 Then ' Win API Declarations for 32 and 64 bit versions of Office 2010 and later
  Public Declare PtrSafe Function GetFileAttributes Lib "kernel32" Alias "GetFileAttributesW" (ByVal lpFileName As LongPtr) As Long
# Else ' WIN API Declarations for Office 2007
  public Declare Function GetFileAttributes Lib "kernel32" Alias "GetFileAttributesW" (ByVal lpFileName As Long) As Long
# End If

' システム時間をファイル時間に変換する関数の宣言 SystemTimetoFileTime
'// Win32API システムタイムをファイルタイムに変換する
'https://social.msdn.microsoft.com/Forums/sqlserver/en-US/a28a32c6-df4e-41b9-94ce-6260812dd92f/problem-trying-to-run-32-bit-vba-program-on-a-64-bit-machine?forum=exceldev
# If VBA7 Then
Private Declare PtrSafe Function SystemTimeToFileTime Lib "kernel32" (lpSystemTime As SYSTEMTIME, lpFileTime As FileTime) As Long
# Else
Private Declare Function SystemTimeToFileTime Lib "kernel32.dll" _
　 (lpSystemTime As SYSTEMTIME, _
　　lpFileTime As FILETIME) As Long
# End If


' オープンされているオブジェクトハンドルをクローズする
' 関数の宣言
# If VBA7 Then
Private Declare PtrSafe Function CloseHandle Lib "kernel32" (ByVal hObject As LongPtr) As Long
# Else
Private Declare Function CloseHandle Lib "kernel32.dll" _
　 (ByVal hObject As Long) As Long
# End If
' LocalFileTimeToFileTime 関数
# If VBA7 Then
'Win32Api_PtrSafe.txtからコピペすると、Aliasが消えてしまう
'Declare PtrSafe Function LocalFileTimeToFileTime Lib "kernel32" Alias "LocalFileTimeToFileTime" (lpLocalFileTime As FILETIME, lpFileTime As FILETIME) As Long

Private Declare PtrSafe Function LocalFileTimeToFileTime Lib "kernel32" (lpLocalFileTime As FileTime, lpFileTime As FileTime) As Long
Private Declare PtrSafe Function FileTimeToLocalFileTime Lib "kernel32" (lpFileTime As FileTime, lpLocalFileTime As FileTime) As Long
Private Declare PtrSafe Function FileTimeToSystemTime Lib "kernel32" (lpFileTime As FileTime, lpSystemTime As SYSTEMTIME) As Long
Private Declare PtrSafe Function CompareFileTime Lib "kernel32" (lpFileTime1 As FileTime, lpFileTime2 As FileTime) As Long
Private Declare PtrSafe Function GetVolumeInformation Lib "kernel32" Alias "GetVolumeInformationA" (ByVal lpRootPathName As String, ByVal lpVolumeNameBuffer As String, ByVal nVolumeNameSize As Long, lpVolumeSerialNumber As Long, lpMaximumComponentLength As Long, lpFileSystemFlags As Long, ByVal lpFileSystemNameBuffer As String, ByVal nFileSystemNameSize As Long) As Long
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
' SetFileTime* and GetFileTime* Declares
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
# Else
Private Declare Function LocalFileTimeToFileTime Lib "kernel32" _
    (lpLocalFileTime As FileTime, _
     lpFileTime As FileTime) As Long
Private Declare Function FileTimeToLocalFileTime Lib "kernel32" ( _
    lpFileTime As FileTime, _
    lpLocalFileTime As FileTime) As Long
Private Declare Function FileTimeToSystemTime Lib "kernel32" ( _
    lpFileTime As FileTime, _
    lpSystemTime As SYSTEMTIME) As Long
Private Declare Function CompareFileTime Lib "kernel32" ( _
    lpFileTime1 As FileTime, _
    lpFileTime2 As FileTime) As Long
Private Declare Function GetVolumeInformation Lib "kernel32" Alias "GetVolumeInformationA" ( _
    ByVal lpRootPathName As String, _
    ByVal lpVolumeNameBuffer As String, _
    ByVal nVolumeNameSize As Long, _
    lpVolumeSerialNumber As Long, _
    lpMaximumComponentLength As Long, _
    lpFileSystemFlags As Long, _
    ByVal lpFileSystemNameBuffer As String, _
    ByVal nFileSystemNameSize As Long) As Long
# End If
' String Length Maximums
Private Const MAX_LEADBYTES = 12  '  5 ranges, 2 bytes ea., 0 term.

Private Const FILE_READ_DATA = (&H1)                     '  file pipe
Private Const FILE_LIST_DIRECTORY = (&H1)                '  directory

Private Const FILE_WRITE_DATA = (&H2)                    '  file pipe
Private Const FILE_ADD_FILE = (&H2)                      '  directory

Private Const FILE_APPEND_DATA = (&H4)                   '  file
Private Const FILE_ADD_SUBDIRECTORY = (&H4)              '  directory
Private Const FILE_CREATE_PIPE_INSTANCE = (&H4)          '  named pipe

Private Const FILE_READ_EA = (&H8)                       '  file directory
Private Const FILE_READ_PROPERTIES = FILE_READ_EA

Private Const FILE_WRITE_EA = (&H10)                     '  file directory
Private Const FILE_WRITE_PROPERTIES = FILE_WRITE_EA

Private Const FILE_EXECUTE = (&H20)                      '  file
Private Const FILE_TRAVERSE = (&H20)                     '  directory

Private Const FILE_DELETE_CHILD = (&H40)                 '  directory
Private Const FILE_READ_ATTRIBUTES = (&H80)              '  all
Private Const FILE_WRITE_ATTRIBUTES = (&H100)            '  all

Private Const FILE_ALL_ACCESS = (STANDARD_RIGHTS_REQUIRED Or SYNCHRONIZE Or &H1FF)
Private Const FILE_ATTRIBUTE_READONLY = &H1
Private Const FILE_ATTRIBUTE_HIDDEN = &H2
Private Const FILE_ATTRIBUTE_SYSTEM = &H4
Private Const FILE_ATTRIBUTE_DIRECTORY = &H10
Private Const FILE_ATTRIBUTE_ARCHIVE = &H20
Private Const FILE_ATTRIBUTE_TEMPORARY = &H100
Private Const FILE_ATTRIBUTE_COMPRESSED = &H800
Private Const FILE_NOTIFY_CHANGE_FILE_NAME = &H1
Private Const FILE_NOTIFY_CHANGE_DIR_NAME = &H2
Private Const FILE_NOTIFY_CHANGE_ATTRIBUTES = &H4
Private Const FILE_NOTIFY_CHANGE_SIZE = &H8
Private Const FILE_NOTIFY_CHANGE_LAST_WRITE = &H10
Private Const FILE_NOTIFY_CHANGE_SECURITY = &H100
Private Const MAILSLOT_NO_MESSAGE = (-1)
Private Const MAILSLOT_WAIT_FOREVER = (-1)
Private Const FILE_CASE_SENSITIVE_SEARCH = &H1
Private Const FILE_CASE_PRESERVED_NAMES = &H2
Private Const FILE_UNICODE_ON_DISK = &H4
Private Const FILE_PERSISTENT_ACLS = &H8
Private Const FILE_FILE_COMPRESSION = &H10
Private Const FILE_VOLUME_IS_COMPRESSED = &H8000&
Private Const IO_COMPLETION_MODIFY_STATE = &H2
Private Const IO_COMPLETION_ALL_ACCESS = (STANDARD_RIGHTS_REQUIRED Or SYNCHRONIZE Or &H3)
Private Const DUPLICATE_CLOSE_SOURCE = &H1
Private Const DUPLICATE_SAME_ACCESS = &H2
'' オブジェクトへのアクセスの種類を指定する定数の宣言
Private Const FILE_GENERIC_READ = (STANDARD_RIGHTS_READ Or FILE_READ_DATA Or FILE_READ_ATTRIBUTES Or FILE_READ_EA Or SYNCHRONIZE)
Private Const FILE_GENERIC_WRITE = (STANDARD_RIGHTS_WRITE Or FILE_WRITE_DATA Or FILE_WRITE_ATTRIBUTES Or FILE_WRITE_EA Or FILE_APPEND_DATA Or SYNCHRONIZE)
Private Const FILE_GENERIC_EXECUTE = (STANDARD_RIGHTS_EXECUTE Or FILE_READ_ATTRIBUTES Or FILE_EXECUTE Or SYNCHRONIZE)

# If VBA7 Then
''''''''''''''''''''''''
' SetFileTime functions.
''''''''''''''''''''''''
Private Declare PtrSafe Function SetFileTimeCreate Lib "kernel32" Alias "SetFileTime" _
   (ByVal hFile As LongPtr, _
    CreateTime As FileTime, _
    ByVal LastAccessTime As Long, _
    ByVal LastModified As Long) As Long

Private Declare PtrSafe Function SetFileTimeLastAccess Lib "kernel32" Alias "SetFileTime" _
   (ByVal hFile As LongPtr, _
    ByVal CreateTime As Long, _
    LastAccessTime As FileTime, _
    ByVal LastModified As Long) As Long

Private Declare PtrSafe Function SetFileTimeLastModified Lib "kernel32" Alias "SetFileTime" _
   (ByVal hFile As LongPtr, _
    ByVal CreateTime As Long, _
    ByVal LastAccessTime As Long, _
    LastModified As FileTime) As Long

''''''''''''''''''''''''
' GetFileTime functions.
''''''''''''''''''''''''
Private Declare PtrSafe Function GetFileTimeCreate Lib "kernel32" Alias "GetFileTime" ( _
    ByVal hFile As LongPtr, _
    CreateTime As FileTime, _
    ByVal LastAccessTime As Long, _
    ByVal LastModified As Long) As Long

Private Declare PtrSafe Function GetFileTimeLastAccess Lib "kernel32" Alias "GetFileTime" ( _
    ByVal hFile As LongPtr, _
    ByVal CreateTime As Long, _
    LastAccessTime As FileTime, _
    ByVal LastModified As Long) As Long

Private Declare PtrSafe Function GetFileTimeLastModified Lib "kernel32" Alias "GetFileTime" ( _
    ByVal hFile As LongPtr, _
    ByVal CreateTime As Long, _
    ByVal LastAccessTime As Long, _
    LastModified As FileTime) As Long
# Else
''''''''''''''''''''''''
' SetFileTime functions.
''''''''''''''''''''''''
Private Declare Function SetFileTimeCreate Lib "kernel32" Alias "SetFileTime" _
   (ByVal hFile As Long, _
    CreateTime As FileTime, _
    ByVal LastAccessTime As Long, _
    ByVal LastModified As Long) As Long

Private Declare Function SetFileTimeLastAccess Lib "kernel32" Alias "SetFileTime" _
   (ByVal hFile As Long, _
    ByVal CreateTime As Long, _
    LastAccessTime As FileTime, _
    ByVal LastModified As Long) As Long

Private Declare Function SetFileTimeLastModified Lib "kernel32" Alias "SetFileTime" _
   (ByVal hFile As Long, _
    ByVal CreateTime As Long, _
    ByVal LastAccessTime As Long, _
    LastModified As FileTime) As Long

''''''''''''''''''''''''
' GetFileTime functions.
''''''''''''''''''''''''
Private Declare Function GetFileTimeCreate Lib "kernel32" Alias "GetFileTime" ( _
    ByVal hFile As Long, _
    CreateTime As FileTime, _
    ByVal LastAccessTime As Long, _
    ByVal LastModified As Long) As Long

Private Declare Function GetFileTimeLastAccess Lib "kernel32" Alias "GetFileTime" ( _
    ByVal hFile As Long, _
    ByVal CreateTime As Long, _
    LastAccessTime As FileTime, _
    ByVal LastModified As Long) As Long

Private Declare Function GetFileTimeLastModified Lib "kernel32" Alias "GetFileTime" ( _
    ByVal hFile As Long, _
    ByVal CreateTime As Long, _
    ByVal LastAccessTime As Long, _
    LastModified As FileTime) As Long
# End If

'// ファイルまたはフォルダのタイムスタンプ設定関数 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
    #If VBA7 Then
    Dim lngHANDLE As LongPtr
    #Else
    Dim lngHANDLE As Long
    #End If
    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(lpFileName:=strFULLPATH, dwDesiredAccess:=GENERIC_WRITE, _
      dwShareMode:=FILE_SHARE_READ, lpSecurityAttributes:=udtSEQRTY, dwCreationDisposition:=OPEN_EXISTING, dwFlagsAndAttributes:=lngFLAG, hTemplateFile:=vbNull)
      If lngHANDLE = INVALID_HANDLE_VALUE Then
      GoTo TERMINATE
    End If
    '// ファイルタイムに変換し、設定する
    udtCREATE = GetFILETIME_By_Kenken(datCREATETIME)
    udtACCESS = GetFILETIME_By_Kenken(datACCESSTIME)
    udtMODIFY = GetFILETIME_By_Kenken(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_By_Kenken(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_By_Kenken)

End Function

Sub SampleCodeFolder()
'D:\sssというフォルダのタイムスタンプ
    '現在（Now関数の戻り値）に変更してみます
    If SetTIMESTAMP("D:\sss", #1/1/2018 12:00:00 PM#, #1/1/2016 12:00:00 PM#, #1/1/2016 12:00:00 PM#) Then
        MsgBox "タイムスタンプを設定しました", vbInformation
    Else
        MsgBox "タイムスタンプの設定に失敗しました", vbCritical
    End If

End Sub

Sub SampleCodeFile()
'D:\test.txtというフォルダのタイムスタンプ
Dim fso As Object: Set fso = CreateObject("Scripting.FileSystemObject") 'New Scripting.FileSystemObject
Dim strFullpathfileName As String
Dim objTimeStmp As fsoTime
strFullpathfileName = "D:\test.txt" '<<<ここでファイルを指定
'ファイルの有無を判定
If Dir(strFullpathfileName) = vbNullString Then Exit Sub
On Error GoTo Terminator
With fso.GetFile(strFullpathfileName)
objTimeStmp.DateCreate = .DateCreated
objTimeStmp.LastModifi = .DateLastModified
objTimeStmp.DateAccess = .DateLastAccessed
End With
On Error GoTo 0
With objTimeStmp
Debug.Print "Creationtime : " & .DateCreate
Debug.Print "LastModified(LastWriteTIme) : " & .LastModifi
Debug.Print "Lastaccess : " & .DateAccess
End With
'作成日時だけ指定した値にしてみます
    If SetTIMESTAMP("D:\test.txt", #1/1/2000 8:08:08 AM#, objTimeStmp.DateAccess, objTimeStmp.LastModifi) Then
        MsgBox "タイムスタンプを設定しました", vbInformation
    Else
        MsgBox "タイムスタンプの設定に失敗しました", vbCritical
        GoTo Terminator
    End If

'現在（Now関数の戻り値）に変更してみます
    If SetTIMESTAMP("D:\test.txt", Now(), Now(), Now()) Then
        MsgBox "タイムスタンプを設定しました", vbInformation
    Else
        MsgBox "タイムスタンプの設定に失敗しました", vbCritical
        GoTo Terminator
    End If
'もとに戻します
    If SetTIMESTAMP("D:\test.txt", objTimeStmp.DateCreate, objTimeStmp.DateAccess, objTimeStmp.LastModifi) Then
        MsgBox "タイムスタンプを設定しました", vbInformation
    Else
        MsgBox "タイムスタンプの設定に失敗しました", vbCritical
    End If
GoTo Terminator
Exit Sub
Terminator:
If Not fso Is Nothing Then Set fso = Nothing
End Sub
0
0
0

Register as a new user and use Qiita more conveniently

  1. You get articles that match your needs
  2. You can efficiently read back useful information
  3. You can use dark theme
What you can do with signing up
Sign upLogin
0
0

Delete article

Deleted articles cannot be recovered.

Draft of this article would be also deleted.

Are you sure you want to delete this article?