Есть необходимость устанавливать любые даты файлу. Вот этот код почему-то не работает. Option Explicit 'Модуль для изменения даты модификации файлов Private Const OFS_MAXPATHNAME = 128 Private Const OF_READ = &H0 Private Declare Function SetFileTime Lib "kernel32" (ByVal hfile As Long, _ lpCreationTime As FILETIME, _ lpLastAccessTime As FILETIME, _ lpLastWriteTime As FILETIME) As Long Private Declare Function OpenFile Lib "kernel32" (ByVal lpFileName As String, _ lpReOpenBuff As OFSTRUCT, _ ByVal wStyle As Long) As Long 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 OFSTRUCT cBytes As Byte fFixedDisk As Byte nErrCode As Integer Reserved1 As Integer Reserved2 As Integer szPathName(OFS_MAXPATHNAME) As Byte End Type ' Функция задает файлу дату создания, модификации и последнего доступа ' *использование API-функции совместно с FSO Function SetDateAsIWant(ByVal FilePath As String, _ Optional ByVal DateCreate As Date, _ Optional ByVal DateModify As Date, _ Optional ByVal DateAccess As Date, _ Optional ByVal MessageOn As Boolean) As Boolean ' Обработка ошибок If IsNull(FilePath) Or FilePath = "" Then SetDateAsIWant = False Exit Function End If If IsEmpty(DateCreate) And IsEmpty(DateModify) And IsEmpty(DateAccess) Then SetDateAsIWant = False Exit Function End If SetDateAsIWant = False 'Вроде особых ошибок нет - продолжим... Dim fsoFile As Scripting.File Dim fso As Scripting.FileSystemObject Set fso = CreateObject("Scripting.FileSystemObject") 'Microsoft Scripting Runtime 'Проверка существования файла If fso.FileExists(FilePath) Then Set fsoFile = fso.GetFile(FilePath) Dim FTCreate As FILETIME Dim FTModify As FILETIME Dim FTAccess As FILETIME Dim tOFSTRUCT As OFSTRUCT Dim hfile As Long '*в структуры записываются текущие значения дат FTCreate.dwHighDateTime = CLng(fsoFile.DateCreated) FTCreate.dwLowDateTime = CLng(fsoFile.DateCreated) FTModify.dwHighDateTime = CLng(fsoFile.DateLastModified) FTModify.dwLowDateTime = CLng(fsoFile.DateLastModified) FTAccess.dwHighDateTime = CLng(fsoFile.DateLastAccessed) FTAccess.dwLowDateTime = CLng(fsoFile.DateLastAccessed) '*используется API-функция открытия файла, поскольку 'для установки дат нужен дескриптор этого файла hfile = OpenFile(FilePath, tOFSTRUCT, OF_READ) If Not IsEmpty(MessageOn) And MessageOn Then MsgBox "tOFSTRUCT.cBytes = " & tOFSTRUCT.cBytes & vbNewLine & _ "tOFSTRUCT.fFixedDisk = " & tOFSTRUCT.fFixedDisk & vbNewLine & _ "tOFSTRUCT.nErrCode = " & tOFSTRUCT.nErrCode & vbNewLine & _ "tOFSTRUCT.Reserved1 = " & tOFSTRUCT.Reserved1 & vbNewLine & _ "tOFSTRUCT.Reserved2 = " & tOFSTRUCT.Reserved2 & vbNewLine & _ "tOFSTRUCT.szPathName(OFS_MAXPATHNAME) = " & tOFSTRUCT.szPathName(OFS_MAXPATHNAME) End If If Not IsEmpty(DateCreate) Then FTCreate.dwHighDateTime = CLng(DateCreate) FTCreate.dwLowDateTime = CLng(DateCreate) End If If Not IsEmpty(DateModify) Then FTModify.dwHighDateTime = CLng(DateModify) FTModify.dwLowDateTime = CLng(DateModify) End If If Not IsEmpty(DateAccess) Then FTAccess.dwHighDateTime = CLng(DateAccess) FTAccess.dwLowDateTime = CLng(DateAccess) End If SetFileTime hfile, FTCreate, FTModify, FTAccess SetDateAsIWant = True Else SetDateAsIWant = False End If If Not IsEmpty(MessageOn) And MessageOn Then MsgBox "Дата создания : " & fsoFile.DateCreated & vbNewLine & _ "Дата модификации : " & fsoFile.DateLastModified & vbNewLine & _ "Дата последнего доступа : " & fsoFile.DateLastAccessed End If Set fsoFile = Nothing Set fso = Nothing On Error Resume Next CloseHandle hfile End Function Ну и, например, такой вызов SetDateAsIWant("\\mainmash\rab98\prv\kassa\350\" & sName,Date, Date, Date, True) не сработает как надо. В чем может быть проблема? Спасибо за внимание.
Ответить
|