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 Sub
Este 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 Sub
Como 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
