gsSetDT

Utilidad para cambiar la fecha y hora de los ficheros, usando API

 

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 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


ir al índice