Office - Ayuda a Mejorar MacroFotos

Buenas a todos.

Tengo una macro en excel para numerar fotos dependiendo del dia de creacion.

El problema se me plantea cuando he pasado fotos de un disco a otro o creo de un CD al disco duro y es que no me pone la fecha en que tome la foto sino en la que se paso al CD.

Empleo como parte del codigo este sub, pero lo uico que puedo acceder es a fecha de la ultima moidifcacion y no de creacion del archivo.

He visto sin embargo en XP que te pone en el explorador de carpetas la fecha de creacion de imagenes, pero esto no lo encuentro en codigo VBA

Alguien sabe ?

Gracias de antemano

La macro completa es esta:
Todo esto esta pensado para cuando tenemos una camara digital ya que te crea archivos del tipo pic1.jpg y claro cuando tenemos una archivo del mismo nombre lo que hace es machacar al existente aunque sen tomados en dias diferentes.

Espero que os guste y recibir la ayuda para mejorarla.


Public larchivo
Public modificado As Date
Public nnombre As String


Sub busqueda()
'***** numeracion fotos por Francisco Naranjo*****
Dim fecha As String
Dim final As String
Dim indice As String
Dim longitudarchivo
Dim prefijo As String

prefijo = InputBox("Prefijo?")
Set fs = Application.FileSearch
With fs
carpeta = .Application.ActiveWorkbook.Path
.LookIn = carpeta
.SearchSubFolders = True
.Filename = "*.jpg"
If .Execute(SortBy:=msoSortByLastModified, SortOrder:=msoSortOrderAscending, AlwaysAccurate:=True) > 0 Then

MsgBox "There were " & .FoundFiles.Count & _
" file(s) found."
For i = 1 To .FoundFiles.Count
fichero = .FoundFiles(i)
ShowFile (fichero)
fin = Right(fichero, larchivo)
longitud = Len(fichero)
inicio = Left(fichero, longitud - larchivo)
indice = i
numero = indice / 10000
fin1 = Format(numero, "###.0000")
fin2 = Right(fin1, 4)

NombreViejo = fichero: NombreNuevo = carpeta & "\ordenados\" + prefijo + nnombre + "_" + fin2 + ".jpg"

Name NombreViejo As NombreNuevo

Next i
Else
MsgBox "There were no files found."
End If
End With

End Sub



Sub ShowFile(fichero)
Dim fs, f, s
Set fs = CreateObject("Scripting.FileSystemObject")
Set f = fs.GetFile(fichero)

modificado = f.DateLastModified
nnombre = Format(modificado, "yyyy mm dd")

larchivo = Len(f.Name)

End Sub

'------------------
'By JuanC Dic-2005
'------------------

'Un método para obtener la fecha de creación de un archivo.
'También podría usarse la función GetFileTime de la API.

Option Explicit

Private Const MAX_PATH = 255

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 Type WIN32_FIND_DATA
dwFileAttributes As Long
ftCreationTime As FILETIME
ftLastAccessTime As FILETIME
ftLastWriteTime As FILETIME
nFileSizeHigh As Long
nFileSizeLow As Long
dwReserved0 As Long
dwReserved1 As Long
cFileName As String * MAX_PATH
cAlternate As String * 14
End Type

Private Const INVALID_HANDLE_VALUE = -1

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 FindFirstFile Lib "kernel32" Alias "FindFirstFileA" (ByVal lpFileName As String, lpFindFileData As WIN32_FIND_DATA) As Long
Private Declare Function FindClose Lib "kernel32" (ByVal hFindFile As Long) As Long

Sub main()
MsgBox GetFileCreationDate("C:\msdos.sys")
End Sub

Private Function GetFileCreationDate(ByVal sFileName As String) As String
Dim hFile As Long
Dim ftTime As FILETIME
Dim stTime As SYSTEMTIME
Dim wfdData As WIN32_FIND_DATA
On Error Resume Next

hFile = FindFirstFile(sFileName, wfdData)

If hFile <> INVALID_HANDLE_VALUE Then
If wfdData.ftCreationTime.dwHighDateTime And _
wfdData.ftCreationTime.dwLowDateTime Then
FileTimeToLocalFileTime wfdData.ftCreationTime, ftTime
FileTimeToSystemTime ftTime, stTime
GetFileCreationDate = stTime.wDay & "/" & stTime.wMonth & _
"/" & stTime.wYear
End If
End If

FindClose hFile
End Function

Saludos y buena suerte, desde Buenos Aires, JuanC

"La API todo lo puede!"

Muchisimas gracias ante todo por contestar sr Juan C
He probado la rutina que me has mandado, pero se me plantea el mismo problema
que tenia en un principio.
En mi codigo utilizo........

Set fs = CreateObject("Scripting.FileSystemObject")
Set f = fs.GetFile(fichero)

modificado = f.DateLastModified ' ......esto debido a que con f.datecreation (estoy escribienedo de memoria) no me daba tampoco la fecha de toma de la foto con la camara, sino la fecha de creacion del archivo en el disco duro, es por eso que probando consegui que con f.DateLastModified me diera la fecha de la ultima modificacion , supuestamente en el disco duro.

El problema principal se plantea al copiar archivos de un sitio a otro o cambiar de nombre el archivo (mas bien creo que el problema esta en copiar) alli es donde la dehca que coje no es la del dia de toma de la foto.

He visto en el explorador de Windows que al dar en el modo de vista de detalle te aparecen , nombre tamaño tipo fecha de modificacion .....etc ....si añado con boton derecho me aparece IMAGEN TOMADA EL DIA que es lo que realmente quisiera saber como conseguir, se ve que los archivos JPG almacnan de alguna manera la fecha de toma, el nombre de camara, exposicion etc... mi preguanta va orientada a eso, como puedo saber el dia de toma de esa foto.

Te agradezco de nuevo la atencion prestada.

un saludo y FELICES FIESTAS.

Francisco Naranjo.