Publicado: 30/Abr/2001
Actualizado: 05/Ago/2003
Pulsa este link para ver la versi�n del
05/Ago/2003
Pulsa este link para
ver la versi�n anterior (del 30/Mar/1998)
En esta p�gina tienes la
�ltima versi�n del 29/Mar/2007
Aqu� tienes una nueva revisi�n de la utilidad de asignar la fecha y hora a ficheros.
En esta ocasi�n he a�adido algunas de las cosas que me hab�is pedido... como ves no siempre hago o�dos sordos a vuestras peticiones, je, je, je...Entre esas cosas es poder cambiar la fecha de creaci�n, como sabes el Visual Basic s�lo cambia la fecha de modificaci�n, pero, adem�s de esa fecha, tambi�n existen otras dos: la de creaci�n y la del �ltimo acceso.
Para poder averiguar esas fechas y por supuesto, para modificarlas, hay que usar el API de Windows, tambi�n se podr�a usar el File System Object, pero he preferido hacerlo con API.Para poder acceder a esa informaci�n proporcionada por el API, he creado una clase: cFileTime, que se encarga de hacer el trabajo sucio.
Otro de los cambios es poder procesar ficheros de s�lo lectura, antes daba error cuando el fichero ten�a ese atributo, pero en esta revisi�n se tiene en cuenta y permite procesarlo, volviendo a dejar los atributos como estaban.
En esta ocasi�n no me voy a enrollar demasiado, espero que s�lo con los comentarios del c�digo, (que est� completo), a falta de la clase para seleccionar ficheros, pero dicha clase la incluyo en el fichero zip con el c�digo completo de la utilidad, as� como el ejecutable compilado con el Visual Basic 6.0 SP4.
Aqu� tienes el link al fichero con el c�digo y el ejecutable: gsSetDT1.zip 22.7KB
Y ya, sin m�s pre�mbulos, vamos a ver el aspecto del formulario en ejecuci�n y del c�digo, tanto del formulario como el de la clase cFileTime.
El formulario en ejecuci�n
Este es el c�digo de la clase cFileTime:
'------------------------------------------------------------------------------ ' Clase para leer / asignar la fecha a los ficheros (30/Abr/01) ' ' ' Parte de la informaci�n sacada de: ' HOWTO: Get Extended File Time Information Using the Win32 API ' y de la MSDN Library ' ' �Guillermo 'guille' Som, 2001 '------------------------------------------------------------------------------ Option Explicit Private CreationTime As FILETIME Private LastAccessTime As FILETIME Private LastWriteTime As FILETIME Private tSystemTime As SYSTEMTIME Private tLocalTime As FILETIME Public UseLocalTime As Boolean ' Por defecto ser� True Public Creation As String Public LastAccess As String Public LastWrite As String ' Private Const OF_READ = &H0 Private Const OF_WRITE = &H1 Private Const OF_READWRITE = &H2 Private Const OF_SHARE_DENY_NONE = &H40 Private Const OFS_MAXPATHNAME = 128 ' OpenFile() Structure 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 Private Type FILETIME dwLowDateTime As Long dwHighDateTime As Long End Type Private 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 Private Declare Function FileTimeToLocalFileTime Lib "kernel32" _ (lpFileTime As FILETIME, lpLocalFileTime As FILETIME) As Long Private Declare Function LocalFileTimeToFileTime Lib "kernel32" _ (lpLocalFileTime As FILETIME, lpFileTime As FILETIME) As Long ' Private Declare Function SystemTimeToFileTime Lib "kernel32" _ (lpSystemTime As SYSTEMTIME, 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 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 OpenFile Lib "kernel32" _ (ByVal lpFileName As String, lpReOpenBuff As OFSTRUCT, _ ByVal wStyle As Long) As Long Private Declare Function hread Lib "kernel32" Alias "_hread" _ (ByVal hFile As Long, lpBuffer As Any, _ ByVal lBytes As Long) As Long Private Declare Function lclose Lib "kernel32" Alias "_lclose" _ (ByVal hFile As Long) As Long Public Function AsignarFechaHora(ByVal FileName As String, _ ByVal NuevaFecha As String, _ ByVal NuevaHora As String, _ Optional AsignarCreation As Boolean = True, _ Optional AsignarLastAccess As Boolean = True, _ Optional AsignarLastWrite As Boolean = True) As Boolean ' Asignar la fecha indicada al fichero ' Devuelve True si todo fue bien ' Dim sInpFile As String Dim hFile As Long Dim FileStruct As OFSTRUCT Dim iRC As Long ' AsignarFechaHora = True ' sInpFile = Trim$(FileName) ' check that the file exists If Len(Dir(sInpFile)) = 0 Then 'MsgBox "Can't find the file", vbExclamation AsignarFechaHora = False Exit Function End If ' ' Leer las fechas que tiene actualmente el fichero ' para que se asignen las variables del tipo FILETIME Call LeerFechaHora(FileName) ' ' Open it to get a stream handle hFile = OpenFile(sInpFile, FileStruct, OF_WRITE Or OF_SHARE_DENY_NONE) If hFile = 0 Then 'MsgBox "Can't open the file", vbExclamation AsignarFechaHora = False Exit Function End If ' With tSystemTime .wDay = Day(NuevaFecha) .wMonth = Month(NuevaFecha) .wYear = Year(NuevaFecha) .wHour = Hour(NuevaHora) .wMinute = Minute(NuevaHora) .wSecond = Second(NuevaHora) End With ' If UseLocalTime Then Call SystemTimeToFileTime(tSystemTime, tLocalTime) If AsignarCreation Then _ Call LocalFileTimeToFileTime(tLocalTime, CreationTime) If AsignarLastWrite Then _ Call LocalFileTimeToFileTime(tLocalTime, LastWriteTime) If AsignarLastAccess Then _ Call LocalFileTimeToFileTime(tLocalTime, LastAccessTime) Else If AsignarCreation Then _ Call SystemTimeToFileTime(tSystemTime, CreationTime) If AsignarLastWrite Then _ Call SystemTimeToFileTime(tSystemTime, LastWriteTime) If AsignarLastAccess Then _ Call SystemTimeToFileTime(tSystemTime, LastAccessTime) End If ' If SetFileTime(hFile, CreationTime, LastAccessTime, LastWriteTime) = 0 Then 'MsgBox "No se ha podido guardar la informaci�n" AsignarFechaHora = False End If iRC = lclose(hFile) End Function Public Function LeerFechaHora(ByVal FileName As String) As Boolean ' Lee la fecha del fichero indicado ' Devuelve True si todo fue bien ' Dim sInpFile As String Dim hFile As Long Dim FileStruct As OFSTRUCT Dim iRC As Long ' LeerFechaHora = True ' sInpFile = Trim$(FileName) ' check that the file exists If Len(Dir(sInpFile)) = 0 Then 'MsgBox "Can't find the file", vbExclamation LeerFechaHora = False Exit Function End If ' Open it to get a stream handle hFile = OpenFile(sInpFile, FileStruct, OF_READ Or OF_SHARE_DENY_NONE) If hFile = 0 Then 'MsgBox "Can't open the file", vbExclamation LeerFechaHora = False Exit Function End If If GetFileTime(hFile, CreationTime, LastAccessTime, LastWriteTime) Then If UseLocalTime Then Call FileTimeToLocalFileTime(CreationTime, tLocalTime) Else LSet tLocalTime = CreationTime End If ' massage time into format that we can use If Not FileTimeToSystemTime(tLocalTime, tSystemTime) Then Creation = tSystemTime.wDay & "/" & tSystemTime.wMonth & "/" & tSystemTime.wYear & " " & _ tSystemTime.wHour & ":" & tSystemTime.wMinute & ":" & tSystemTime.wSecond End If If UseLocalTime Then Call FileTimeToLocalFileTime(LastWriteTime, tLocalTime) Else LSet tLocalTime = LastWriteTime End If If Not FileTimeToSystemTime(tLocalTime, tSystemTime) Then LastWrite = tSystemTime.wDay & "/" & tSystemTime.wMonth & "/" & tSystemTime.wYear & " " & _ tSystemTime.wHour & ":" & tSystemTime.wMinute & ":" & tSystemTime.wSecond End If If UseLocalTime Then Call FileTimeToLocalFileTime(LastAccessTime, tLocalTime) Else LSet tLocalTime = LastAccessTime End If If Not FileTimeToSystemTime(tLocalTime, tSystemTime) Then LastAccess = tSystemTime.wDay & "/" & tSystemTime.wMonth & "/" & tSystemTime.wYear & " " & _ tSystemTime.wHour & ":" & tSystemTime.wMinute & ":" & tSystemTime.wSecond End If Else 'MsgBox "GetFileTime Failed" LeerFechaHora = False End If iRC = lclose(hFile) End Function Private Sub Class_Initialize() UseLocalTime = True End SubEste es el c�digo del formulario:
'------------------------------------------------------------------------------ ' gsSetDT Utilidad para asignar la fecha y hora (15/Mar/98) ' ' Revisado: 26/Mar/1998 ' Revisado: 26/Abr/2001, 29/Abr/2001 ' Revisado: 30/Abr/2001 (usando API) ' Posibilidad de modificar la fecha de creaci�n, modificado y acceso ' ' �Guillermo 'guille' Som, 1998-2001 '------------------------------------------------------------------------------ Option Explicit Private Sub cmdA�adir_Click() ' Si hay algo en el textBox, a�adirlo Dim sTmp As String ' sTmp = Trim$(txtFichero) If Len(sTmp) Then List1.AddItem sTmp txtFichero.Text = "" End If If List1.ListCount > 0 Then cmdBorrarLista.Enabled = True Else cmdBorrarLista.Enabled = False End If cmdAsignar.Enabled = cmdBorrarLista.Enabled End Sub Private Sub cmdAsignar_Click() 'Asignar la fecha/hora indicada a los ficheros de la lista Dim vFecha As Date Dim vHora As Date Dim i As Long Dim sTmp As String Dim Ficheros As Long Dim Fallos As Long Dim TotalFicheros As Long Dim TotalFallos As Long Dim Procesados As Double ' On Local Error Resume Next ' If List1.ListCount = 0 Then MsgBox "No hay ficheros a procesar" txtFichero.SetFocus Else If Len(Trim$(txtFecha)) = 0 Then vFecha = Format$(Now, "dd/mm/yyyy") Else vFecha = txtFecha End If vFecha = Format$(vFecha, "dd/mm/yyyy") If Err Then MsgBox "La fecha introducida no es correcta" txtFecha.SetFocus Else If Len(Trim$(txtHora)) = 0 Then vHora = Format$(Now, "hh:mm") Else vHora = txtHora End If vHora = Format$(vHora, "hh:mm") If Err Then MsgBox "La hora no es correcta" txtHora.SetFocus Else For i = 0 To List1.ListCount - 1 sTmp = List1.List(i) Procesados = ProcesaEspec(sTmp, vFecha, vHora) Ficheros = Fix(Procesados) sTmp = CStr(Procesados - Ficheros) Fallos = Val(Mid$(sTmp, 3)) TotalFicheros = TotalFicheros + Ficheros TotalFallos = TotalFallos + Fallos Next MsgBox "Se han procesado un total de " & TotalFicheros & vbCrLf & "se han producido " & TotalFallos & " fallos" End If End If End If Err = 0 End Sub Private Sub cmdBorrarLista_Click() ' Borrar la selecci�n del ListBox BorrarDeLista List1 End Sub Private Sub cmdExaminar_Click() ' Seleccionar los ficheros a a�adir a la lista Dim CommonDialog1 As cComDlg Set CommonDialog1 = New cComDlg ' On Local Error Resume Next ' ' a�adir archivo With CommonDialog1 .hWnd = Me.hWnd .CancelError = True .FileName = txtFichero ' Seleccionar ficheros a a�adir a la lista .DialogTitle = "Seleccionar archivos" .Filter = "Todos los archivos (*.*)|*.*" '.Flags = OFN_HIDEREADONLY Or OFN_ALLOWMULTISELECT _ Or OFN_LONGNAMES Or OFN_EXPLORER Or OFN_PATHMUSTEXIST Or OFN_FILEMUSTEXIST .ShowOpen If Err = 0 Then ' A�adimos la selecci�n al List1 .AgregarALista .FileName, List1 End If End With Err = 0 ' Set CommonDialog1 = Nothing ' If List1.ListCount > 0 Then cmdBorrarLista.Enabled = True Else cmdBorrarLista.Enabled = False End If cmdAsignar.Enabled = cmdBorrarLista.Enabled End Sub Private Sub cmdSalir_Click() Unload Me 'End End Sub Private Function ProcesaEspec(ByVal sFic As String, ByVal vFecha As Date, ByVal vHora As Date) As Double ' Procesar los ficheros especificados y asignar la fecha/hora Dim sTmp As String Dim Ficheros As Long Dim Fallos As Long Dim sDir As String ' On Local Error Resume Next ' ' Obtener el path de este fichero especificaci�n sDir = elPath(sFic) sTmp = Dir$(sFic) If Err Then Ficheros = 1 Fallos = 1 Else Do While Len(sTmp) Ficheros = Ficheros + 1 If AsignarHora(sDir & sTmp, vFecha, vHora) Then Fallos = Fallos + 1 End If sTmp = Dir$ Loop End If sTmp = CStr(Ficheros) & "." & CStr(Fallos) ProcesaEspec = Val(sTmp) Err = 0 End Function Private Function elPath(ByVal sTodo As String) As String '-------------------------------------------------------------------------- ' Divide el nombre recibido en la ruta, nombre y extensi�n ' (c)Guillermo Som, 1997 ( 1/Mar/97) ' ' Par�metros: ' sTodo Valor de entrada con la ruta completa ' ' VERSI�N REDUCIDA: S�lo devuelve el Path '-------------------------------------------------------------------------- Dim i As Integer Dim sPath As String sPath = "" ' Buscar el �ltimo \ For i = Len(sTodo) To 1 Step -1 If Mid$(sTodo, i, 1) = "\" Then 'El path devuelto incluye el \ sPath = Left$(sTodo, i) Exit For End If Next ' elPath = sPath End Function Private Function AsignarHora(ByVal sFic As String, _ ByVal vFecha As Date, _ ByVal vHora As Date) As Boolean ' Asignar la fecha y hora al fichero indicado ' Devuelve True si se ha producido un error ' ' Se tendr� en cuenta si es de solo lectura (26/Abr/01) Dim SoloLectura As Boolean Dim i As Long ' On Local Error Resume Next ' ' Si es de s�lo lectura, cambiar el atributo (26/Abr/01) i = GetAttr(sFic) If Err Then Err = 0 AsignarHora = True Exit Function End If ' If i And vbReadOnly Then SoloLectura = True i = i Xor vbReadOnly SetAttr sFic, i End If ' ' Usando API y la clase cFileTime Dim tFileTime As cFileTime Set tFileTime = New cFileTime ' With tFileTime .UseLocalTime = CBool(chkUseLocalTime.Value) .AsignarFechaHora sFic, vFecha, vHora, chkCreation, chkLastAccess, chkLastWrite End With ' ' Restaurar los atributos anteriores If SoloLectura Then i = i Or vbReadOnly SetAttr sFic, i End If ' AsignarHora = CBool(Err) ' Err = 0 End Function Private Sub Add2Lista(Data As DataObject, unaLista As Control, Optional ByVal sExtension As String = "") 'A�adir los archivos soltados a la lista (16/Nov/97) Dim i As Long Dim conExt As Boolean If Len(Trim$(sExtension)) Then conExt = True End If With Data.Files For i = 1 To .Count ' A�adir a la lista ' Si se especifica la extensi�n... If conExt Then If InStr(.Item(i), sExtension) Then unaLista.AddItem .Item(i) End If Else unaLista.AddItem .Item(i) End If Next End With End Sub Private Sub Form_Load() Caption = "Asignar Fecha y Hora a ficheros - �Guillermo 'guille' Som, 1998-" & IIf(Year(Now) > 2001, CStr(Year(Now)), "2001") Label1(4).Caption = " �Guillermo 'guille' Som, 1998-" & IIf(Year(Now) > 2001, CStr(Year(Now)), "2001") ' Move (Screen.Width - Width) \ 2, -30 ' ' poner la fecha y hora actual txtFecha = Format$(Now, "dd/mm/yyyy") txtHora = Format$(Now, "hh:mm") ' cmdA�adir.Enabled = False cmdBorrarLista.Enabled = False cmdAsignar.Enabled = cmdBorrarLista.Enabled End Sub Private Sub Form_Resize() If WindowState <> vbMinimized Then Line1(0).X1 = 0 Line1(0).X2 = ScaleWidth Line1(1).X1 = Line1(0).X1 Line1(1).X2 = Line1(0).X2 End If End Sub Private Sub Form_Unload(Cancel As Integer) Set Form1 = Nothing End Sub Private Sub List1_KeyDown(KeyCode As Integer, Shift As Integer) 'Si se pulsa la tecla de suprimir If KeyCode = vbKeyDelete Then BorrarDeLista List1 End If End Sub Private Sub BorrarDeLista(unaLista As Control) ' Si se pulsa la tecla de suprimir Dim i As Long Dim j As Long ' ' borrar los elementos seleccionados With unaLista j = .ListCount - 1 For i = j To 0 Step -1 If .Selected(i) Then .RemoveItem i End If Next If .ListCount > 0 Then cmdBorrarLista.Enabled = True Else cmdBorrarLista.Enabled = False End If cmdAsignar.Enabled = cmdBorrarLista.Enabled End With End Sub Private Sub List1_OLEDragDrop(Data As DataObject, Effect As Long, Button As Integer, Shift As Integer, X As Single, Y As Single) ' A�adir a la lista los ficheros soltados Add2Lista Data, List1 End Sub Private Sub txtFichero_Change() If Len(txtFichero.Text) Then cmdA�adir.Enabled = True Else cmdA�adir.Enabled = False End If End Sub Private Sub txtFichero_OLEDragDrop(Data As DataObject, Effect As Long, Button As Integer, Shift As Integer, X As Single, Y As Single) On Error Resume Next ' txtFichero.Text = Data.Files(1) ' Err = 0 End SubComo es habitual, espero tus comentarios, de esta forma se pueden arreglar los posibles errores (bugs) y, por supuesto mejorar la utilidad.
�Que lo disfrutes!
Nos vemos.
Guillermo