LIRE ET MODIFIER LES ATTRIBUTS DE DATE D'UN FICHIER

Option Explicit


'==============================================================================
'   Constantes

Public Const cstrAppTitle = "Dates de fichier"

Private Const GENERIC_READ = &H80000000             'Accès en lecture
Private Const GENERIC_WRITE = &H40000000            'Acces en écriture
Private Const INVALID_HANDLE_VALUE = -1             'Identificateur non valide
Private Const MAX_PATH = 260                        'Longueur de chemin maximum
Private Const OFN_HIDEREADONLY = &H4                'Masquer "Lecture seule"
Private Const OFN_NODEREFERENCELINKS = &H100000     'Ouvrir le fichier .LNK
                                                    'et non le fichier pointé
Private Const OPEN_EXISTING = 3                     'Ne créée pas de fichier


'==============================================================================
'   Structures

'Date fichier
Private Type FILETIME
        dwLowDateTime As Long
        dwHighDateTime As Long
End Type

'Informations ouverture/sauvegarde de fichier
Private Type OPENFILENAME
        lStructSize As Long
        hWndOwner As Long
        hInstance As Long
        lpstrFilter As String
        lpstrCustomFilter As String
        nMaxCustFilter As Long
        nFilterIndex As Long
        lpstrFile As String
        nMaxFile As Long
        lpstrFileTitle As String
        nMaxFileTitle As Long
        lpstrInitialDir As String
        lpstrTitle As String
        flags As Long
        nFileOffset As Integer
        nFileExtension As Integer
        lpstrDefExt As String
        lCustData As Long
        lpfnHook As Long
        lpTemplateName As String
End Type

'Attributs de sécurité (inutile sous Windows 9x)
Private Type SECURITY_ATTRIBUTES
        nLength As Long
        lpSecurityDescriptor As Long
        bInheritHandle As Long
End Type

'Date fichier, format converti
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

'==============================================================================
'   Déclarations API

Private Declare Function CloseHandle Lib "kernel32" (ByVal hObject As Long) As Long
Private Declare 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 Long) As Long
Private Declare Function CommDlgExtendedError Lib "comdlg32.dll" () 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 GetFileTime Lib "kernel32" (ByVal hFile As Long, lpCreationTime As FILETIME, lpLastAccessTime As FILETIME, lpLastWriteTime As FILETIME) As Long
Private Declare Function GetLastError Lib "kernel32" () As Long
Private Declare Function GetOpenFileName Lib "comdlg32.dll" Alias "GetOpenFileNameA" (pOpenfilename As OPENFILENAME) As Long
Private Declare Function LocalFileTimeToFileTime Lib "kernel32" (lpLocalFileTime As FILETIME, lpFileTime As FILETIME) As Long
Private Declare Function SetFileTime Lib "kernel32" (ByVal hFile As Long, lpCreationTime As FILETIME, lpLastAccessTime As FILETIME, lpLastWriteTime As FILETIME) As Long
Private Declare Function SystemTimeToFileTime Lib "kernel32" (lpSystemTime As SYSTEMTIME, lpFileTime As FILETIME) As Long


'==============================================================================
'   Fonctions membres

Public Function GetOpenFile(ByVal hWndOwner As Long) As String
'Affiche la boîte "Ouvrir", retourne le chemin d'accès ou une chaîne vide sur
'annulation, consulter la doc pour les infos sur les paramètres, sinon il y en
'a pour 12 pages de commentaires

    Dim ofn As OPENFILENAME
    Dim strFile As String * MAX_PATH, lngFile As Long
    Dim lngFileExtension As Long
    Dim lngFileOffset As Long, lngError As Long
       
    lngFile = MAX_PATH
    
    ofn.lStructSize = Len(ofn)
    ofn.hWndOwner = hWndOwner   'Propriétaire de la fenêtre
    ofn.hInstance = 0&
    ofn.lpstrFilter = "Tous les fichiers (*.*)" + vbNullChar + "*.*" + _
        vbNullChar + vbNullChar
    ofn.lpstrCustomFilter = vbNullString
    ofn.nMaxCustFilter = 0&
    ofn.nFilterIndex = 1
    ofn.lpstrFile = strFile
    ofn.nMaxFile = lngFile
    ofn.lpstrFileTitle = vbNullString
    ofn.nMaxFileTitle = 0&
    ofn.lpstrInitialDir = vbNullString
    ofn.lpstrTitle = "Ouvrir un fichier"
    ofn.flags = OFN_HIDEREADONLY Or OFN_NODEREFERENCELINKS
    ofn.nFileOffset = lngFileOffset
    ofn.nFileExtension = lngFileExtension
    ofn.lpstrDefExt = vbNullString
    ofn.lCustData = 0&
    ofn.lpfnHook = 0&
    ofn.lpTemplateName = 0&
    
    lngFile = GetOpenFileName(ofn)
    If lngFile <> 0 Then
        'On a cliqué sur OK
        'Un peu galère en VB de trouver la fin d'une chaîne C.
        'Dans l'instruction InStr, on part de l'indicateur de l'extension pour
        'aller plus vite
        GetOpenFile = Left(ofn.lpstrFile, InStr(ofn.nFileExtension, _
            ofn.lpstrFile, vbNullChar) - 1)
    Else
        'Information de débogage. Consulter CDERR.H pour une info sur le
        'code d'erreur (si <> 0)
        lngError = CommDlgExtendedError()
        
        GetOpenFile = ""
        If lngError <> 0 Then
            'lngError contient le code d'erreur
            Debug.Assert False
        End If
    End If
    
End Function

Public Function GetFileTimes(strFile As String, stCreation As SYSTEMTIME, _
    stLastAccess As SYSTEMTIME, stLastWrite As SYSTEMTIME) As Boolean
    'Récupération des dates du fichier, renvoie True si OK
    'Les informations de date sont renvoyés par référence
    
    Dim ftCreation As FILETIME, ftLastAccess As FILETIME
    Dim ftLastWrite As FILETIME, lnghFile As Long
    
    Debug.Assert strFile <> ""
    
    lnghFile = OpenFile(strFile, False)
    If lnghFile = INVALID_HANDLE_VALUE Then
        MsgBox "Impossible d'ouvrir le fichier " + strFile, vbExclamation
        'Voir la fonction OpenFile() en mode débogage pour le code d'erreur
        Exit Function
    End If
    
    'Bon, ben maintenant ça roule tout seul
    GetFileTime lnghFile, ftCreation, ftLastAccess, ftLastWrite
    CloseHandle lnghFile
    
    'Conversion Temps Universel -> Temps local
    FileTimeToLocalFileTime ftCreation, ftCreation
    FileTimeToLocalFileTime ftLastAccess, ftLastAccess
    FileTimeToLocalFileTime ftLastWrite, ftLastWrite
    
    'Conversion temps binaire -> temps "humain" (voir les structures FILETIME
    'et SYSTEMTIME pour comprendre ce que je veux dire)
    FileTimeToSystemTime ftCreation, stCreation
    FileTimeToSystemTime ftLastAccess, stLastAccess
    FileTimeToSystemTime ftLastWrite, stLastWrite
    
    GetFileTimes = True
    
End Function

Private Function OpenFile(strFileName As String, blnAccess As Boolean) As Long
    'Ouverture d'un fichier strFileName avec blnAccess à True pour l'écriture,
    'à False pour lecture seule.
    'Renvoi de l'identificateur de fichier
    
    Dim sa As SECURITY_ATTRIBUTES
    Dim lngError As Long, lnghFile As Long
    
    Debug.Assert strFileName <> ""
    
    'Sécurité par défaut (non utilisé sous Windows 9x).
    sa.nLength = Len(sa)
    sa.bInheritHandle = 0&
    
    'Le fichier est ouvert en accès exclusif.
    'Modifier le paramètre dwShareMode pour modifier ou lire des fichiers déjà
    'ouverts par d'autres programmes
    lnghFile = CreateFile(strFileName + vbNullChar, _
        IIf(blnAccess, GENERIC_WRITE, GENERIC_READ), 0&, sa, _
        OPEN_EXISTING, 0&, 0&)
        
    'Code de débogage, voir WINERROR.H pour la signification
    lngError = GetLastError()
    
    OpenFile = lnghFile
End Function


Public Function SetFileTimes(strFile As String, stCreation As SYSTEMTIME, _
    stLastAccess As SYSTEMTIME, stLastWrite As SYSTEMTIME) As Boolean
    'Affectation des dates du fichier, renvoie True si OK
    
    Dim ftCreation As FILETIME, ftLastAccess As FILETIME
    Dim ftLastWrite As FILETIME, lnghFile As Long
    Dim blnSuccess As Boolean
    
    Debug.Assert strFile <> ""  'Alors, on a perdu sa maman ?
    
    'Conversion Temps "humain" -> Temps machine
    SystemTimeToFileTime stCreation, ftCreation
    SystemTimeToFileTime stLastAccess, ftLastAccess
    SystemTimeToFileTime stLastWrite, ftLastWrite
    
    'Conversion temps local -> Temps universel
    LocalFileTimeToFileTime ftCreation, ftCreation
    LocalFileTimeToFileTime ftLastAccess, ftLastAccess
    LocalFileTimeToFileTime ftLastWrite, ftLastWrite
    
    lnghFile = OpenFile(strFile, True)
    If lnghFile = INVALID_HANDLE_VALUE Then
        MsgBox "Impossible d'ouvrir le fichier " + strFile, vbExclamation, _
            cstrAppTitle
        'Voir la fonction OpenFile en débogage pour le code d'erreur
        Exit Function
    End If
    
    'SetFileTime renvoie True si OK
    blnSuccess = SetFileTime(lnghFile, ftCreation, ftLastAccess, ftLastWrite) <> 0
    
    'Fermeture du fichier
    CloseHandle lnghFile
    
    SetFileTimes = blnSuccess
    
End Function

Télécharger le zip