Opgelost Datum bestanden aanpassen

[Frits M]

Goedendag,
Na het moeten verplaatsen van mijn fotobestanden zijn alle data aangepast naar de wijzigingsdatum. Graag zou ik deze bestanden met behulp van een vba code van 'laatst gewijzigd' naar 'aangemaakt op' willen wijzigen.
Helaas lukt dit mij niet rechtstreeks met een macromodule. Ik heb begrepen dat hiervoor een api code noodzakelijk is. Daar heb ik geen verstand van. Kan iemand mij op weg helpen met een benodigde code?
Ik gebruik excel 2019, Windows 11
Alvast dank.

 

[edmoor]

Dat kan bijvoorbeeld met een stukje VB Script in plaats van VBA:

Pad = "C:\Users\Ed\Pictures"
Bst = "Auto.jpg"

Set objShell = CreateObject("Shell.Application")
Set objFolder = objShell.NameSpace(Pad)
Set objFolderItem = objFolder.ParseName(Bst)

objFolderItem.ModifyDate = GetDateCreated (Pad & "\" & Bst)

Function GetDateCreated(filespec)
   Dim fso, f
   Set fso = CreateObject("Scripting.FileSystemObject")
   Set f = fso.GetFile(filespec)
   GetDateCreated = f.DateCreated
End Function

Overigens kan je VB Script met wat aanpassingen ook in VBA toepassen.

 

[Frits M]

Alvast bedankt, niet eerder met scrips gewerkt, dus ga het proberen om te zetten in een vba loop. (Het gaat om ca 4000 bestanden)
Kom hierop terug (met vragen of ik hoop een bericht dat het gelukt is}

 

[snb]

Sub M_snb()
  Set sa = CreateObject("shell.application").Namespace("D:\SNB_\foto\").Items
     
  With CreateObject("scripting.filesystemobject")
    For Each it In .getfolder("D:\SNB_\foto").Files
      sa.Item(it.Name).ModifyDate = it.DateCreated
    Next
  End With
End Sub

 

[snb]

Of zo:

Sub M_snb()
  With CreateObject("shell.application").Namespace("D:\SNB_\foto\")
    For Each it In .Items
      it.ModifyDate = .GetDetailsOf(it, 4)
    Next
  End With
End Sub

 

[Frits M]

Bedankt! De eerste code vanavond geprobeerd, werkt, maar het resultaat dat (in een proef mapje) laatst gewijzigde en aanmaakdatum naar vandaag gingen.
Code wat aangepast waarna 'laatst gewijzigd' de aanmaakdatum werd, maar de aanmaakdatum op vandaag werd gezet.
Riskant voor wanneer m'n microsd nog eens defect raakt. Dan is de oorspronkelijke datum weg.
Morgen denk ik 2e code proberen.
...
Je hoort, maar kan even duren mede door naderende vakantie. Bedankt!

 

[OctaFish]

Ik snap eerlijk gezegd niet waar je je druk om maakt: de opnamedatum is een vast onderdeel van de EXIF informatie van je foto en wordt in de camera al vastgelegd. Kun je altijd opvragen en bekijken (ook in Verkenner waar je dan uiteraard op kan sorteren), en verandert (uiteraard) niet als je een foto naar een andere locatie verplaatst of kopieert.

 

[Frits M]

Begin juni was mijn micro sd kaart defect en ging in alleen-lezen stand. Gekopieerd naar een nieuwe sd kaart staan alle foto's op 3 juni en ontbreekt de juiste sortering. In de bestandsinfo (Google foto's omhoog scrollen) of windows verkenner 'opgenomen op' staat de 'opgenomen op' datum. Inmiddels heb ik m'n fotos in verkenner welliswaar gesorteerd oo deze datum. Ik wil deze datum uiteraard behouden, maar de laatst gewijzigde datum hetzelfde als deze datum instellen zodat je gewoon direct ziet op welke datum de foto is genomen zónder eerst omhoog te scrollen

 

[Frits M]

@snb
weet je misschien ook de code voor niet de aanmaakdatum, maar de code uit de bestandsinfo "genomen op"? niet dateCreated maar date...... in de onderstaande coderegel
sa.Item(it.Name).ModifyDate = it.DateCreated

 

[OctaFish]

Van mij mag je op snb wachten, dan mag je deze post negeren

Exif.Image.DateTimeOriginal

The date and time when the original image data was generated.

 

[Frits M]

Haha, daar was ik zojuist ook al achter gekomen. Alleen krijg ik data met vraagtekens erin. Zoals: ?14-?08-2004.
Was nog aan het zoeken naar de replace code, maar krijg bij replace ~? etc een foutmelding.
(Voor m'n pensionering zat ik dag en nacht in vba, maar de laatste 4 jaar vrijwel nooit meer; ben een hoop kwijt. 't is weer ff wennen)

 

[edmoor]

Daarom had ik m'n bericht alweer verwijderd

 

[OctaFish]

Ik heb een forumbericht gevonden waarin een module (eigenlijk 3) wordt gebruikt om de EXIF uit te lezen in Excel. De modules komen uit een Access database, maar kun je simpel overzetten.
Hier de database, en hier het forumbericht.

 

[edmoor]

De vraagtekens die je ziet zijn andere tekens.
In plaats van Replace kan je dit gebruiken:

      msg = .GetDetailsOf(it, 12)
      For i = 1 To Len(msg)
        Select Case Asc(Mid(msg, i, 1))
            Case 32, 45, 48 To 58
                DateTaken = DateTaken & Mid(msg, i, 1)
        End Select
      Next i

 

[Frits M]

Dankjewel, ga er naar kijken. Maar was nu net gestart met het eerste antwoord van edmoor te testen. Als ik daarin ook vast loop ga ik deze proberen
Blij met zoveel hulp!

 

[Frits M]

@snb @edmoor
Het werkt (bij de meeste foto's)
2e code snb in combinatie met de correctie code edmoor
Ik laat de topic nog even open staan omdat er van de 4200 bestanden een stuk of 300 niet zijn gewijzigd terwijl er wel een 'genomen op' datum in staat.
dus misschien volgt er nog een vraag. Voor vandaag ff "klaar mee"
In ieder geval heel hartelijk bedankt !!
uiteindelijke code (nauwelijks gewijzigd)

Sub M_snb()
Dim msg
With CreateObject("shell.application").Namespace("E:\DCIM\Camera\foto's met naam\")
For Each it In .Items
msg = .GetDetailsOf(it, 12)
For i = 1 To Len(msg)
Select Case Asc(Mid(msg, i, 1))
Case 32, 45, 48 To 58
datetaken = datetaken & Mid(msg, i, 1)
End Select
Next i
If datetaken <> "" Then it.ModifyDate = datetaken
datetaken = ""
Next
End With
MsgBox "klaar"
End Sub

 

[edmoor]

Wat komt er bij die 300 bestanden voor de correctie dan uit?

PS:
Als je hier code plaatst, zet deze dan in codetags.
Zie mijn handtekening.

 

[Frits M]

Even niet duidelijk, is dat bij code hierboven aangegeven met </>?

De ca 300 bestanden blijven op 3-6 staan. Moet dit nog even uitzoeken. Heb ze in een aparte map geplaatst en ga (stap voor stap) bekijken wat hiermee gebeurt.
Was er voor vandaag even klaar mee, hoofdpijn.
Kom er op terug, bedankt

 

[edmoor]

Zo dus:

[ CODE]
coderegels
[ /CODE]

Maar dan zonder de spatie na het [ teken.

 

[Frits M]

Het heeft even geduurd, maar nu werkt alles in map en submappen (totaal ca 18.000 bestanden aangepast)
De bestanden die geen opnamedatum of op 3-6 bleven staan bleken screenshots, mp4 bestanden etc te zijn. Ook zonder opnamedatum een flink aantal jpg bestanden met minimaal geheugen, geen idee wat dit is, maar laat het zo (de macro zet ze op 1-1-2000)
Nogmaals heel hartelijk dank voor de hulp.

Dim objFSO As Object, objFolder As Object, objFile As Object
 Dim objSubFolder As Object
  Dim strFilePath As String
  Dim msg As String
Sub HoofdMacro() 'incl alle submappen wijzigen
  Dim startMap As String
  ' Geef de map op waar je wilt beginnen met verwerken
  startMap = "E:\DCIM\Camera\" 'Pas dit aan naar je gewenste map
  ' Roep de functie aan
  Call VerwerkMapEnSubmappen(startMap)
  MsgBox "Macro voltooid."
End Sub

Sub Laatstgewijzigd_Naar_Opnamedatum1()
Dim msg
Dim msg1
msg1 = objFolder
  With CreateObject("shell.application").Namespace(msg1)
    For Each it In .Items
    msg = .GetDetailsOf(it, 12)

    For i = 1 To Len(msg)
        Select Case Asc(Mid(msg, i, 1))
            Case 32, 45, 48 To 58
                datetaken = datetaken & Mid(msg, i, 1)
        End Select
      Next i
  If datetaken = "" Then datetaken = "01-01-2000 01:01"
      If datetaken <> "" Then it.ModifyDate = datetaken
      datetaken = ""
    Next
  End With
 
End Sub

Sub VerwerkMapEnSubmappen(ByVal startMap As String)
  ' Maak een FileSystemObject aan
  Set objFSO = CreateObject("Scripting.FileSystemObject")

    Set objFolder = objFSO.GetFolder(startMap)
Laatstgewijzigd_Naar_Opnamedatum1
  ' Verwerk de submappen
  For Each objSubFolder In objFolder.SubFolders
    ' Roep de functie recursief aan voor de submap
    Call VerwerkMapEnSubmappen(objSubFolder.Path)
  Next objSubFolder
  ' Opschonen
  Set objFSO = Nothing
  Set objFolder = Nothing
  Set objFile = Nothing
  Set objSubFolder = Nothing
End Sub