Soyez le premier à donner votre avis sur cette source.
Vue 30 963 fois - Téléchargée 1 583 fois
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
Bravo pour ce code !
J'en avais eu un qui ne comprenait pas le Closehandle(), du coup, XP n'acceptait pas de le supprimer par exemple en disant "Une autre application utilise actuellement ce fichier".
Encore bravo et merci.
Joss.
Je n'arrive pas à trouver !!
Merci
wx
Vous n'êtes pas encore membre ?
inscrivez-vous, c'est gratuit et ça prend moins d'une minute !
Les membres obtiennent plus de réponses que les utilisateurs anonymes.
Le fait d'être membre vous permet d'avoir un suivi détaillé de vos demandes et codes sources.
Le fait d'être membre vous permet d'avoir des options supplémentaires.