XL 2010 Renseigner ''titre'' de proprieté fichier

[re4]

Bonjour
Dans un repertoire il y a plusieurs fichiers, avant de les renommer, je voudrai copier le nom du fichier dans les propretés du fichier dans la description 'Titre' et ceci pour tous les fichiers.
Je pars du code ci-dessous pour lister les fichiers dans une feuille Excel (il y a peut être plus simple)
J'ai vu aussi que le code 'Titre' pour win 10 est le 21 (array(21) ?
Merci de votre aide

Option Explicit
Sub GetFileNames()
Dim xRow As Long
Dim xDirect$, xFname$, InitialFoldr$
InitialFoldr$ = "C:\"
With Application.FileDialog(msoFileDialogFolderPicker)
.InitialFileName = Application.DefaultFilePath & "\"
.Title = "Please select a folder to list Files from"
.InitialFileName = InitialFoldr$
.Show
If .SelectedItems.Count <> 0 Then
xDirect$ = .SelectedItems(1) & "\"
xFname$ = Dir(xDirect$, 7)
Do While xFname$ <> ""
ActiveCell.Offset(xRow) = xFname$
xRow = xRow + 1
xFname$ = Dir
Loop
End If
End With
End Sub

 

[Staple1600]

Bonjour le fil, le forum

Ta macro ainsi modifiée fonctionne chez moi.
(XL2013-W10)

Sub GetFileNames_V2()
Dim xDirect$, xFname$, InitialFoldr$, wb As Workbook
InitialFoldr$ = "C:\"
Application.ScreenUpdating = False
Application.EnableEvents = False
Application.Calculation = xlCalculationManual
    With Application.FileDialog(msoFileDialogFolderPicker)
        .InitialFileName = Application.DefaultFilePath & "\"
        .Title = "Merci de choisir le dossier source, svp"
        .InitialFileName = InitialFoldr$
        .Show
            If .SelectedItems.Count <> 0 Then
            xDirect = .SelectedItems(1) & "\"
            xFname = Dir(xDirect$, 7)
            Do While xFname <> ""
                DoEvents
                Set wb = Workbooks.Open(Filename:=xDirect & xFname)
                wb.BuiltinDocumentProperties("Title") = xFname
                wb.Close SaveChanges:=True
                DoEvents
            xFname = Dir
            Loop
        End If
    End With
MsgBox "Tâche terminée!"
Application.EnableEvents = True
Application.Calculation = xlCalculationAutomatic
Application.ScreenUpdating = True
End Sub

 

[re4]

Bonjour Staple1600
Merci beaucoup pour ta réponse et excuse moi du retard de la mienne.
Lorsque j'insère ton code dans un module la partie du ci-dessous est en rouge et j'ai donc un message d'erreur.

.InitialFileName = Application.DefaultFilePath & "\"
.Title = "Merci de choisir le dossier source, svp"
.InitialFileName = InitialFoldr$
.Show
If .SelectedItems.Count <> 0 Then
xDirect = .SelectedItems(1) & "\"
xFname = Dir(xDirect$, 7)
Do While xFname <> ""
DoEvents
Set wb = Workbooks.Open(Filename:=xDirect & xFname)
wb.BuiltinDocumentProperties("Title") = xFname
wb.Close SaveChanges:=True
DoEvents
xFname = Dir
Loop
End If
End With

 

[re4]

Bonjour le fil, le forum

Ta macro ainsi modifiée fonctionne chez moi.
(XL2013-W10)

Sub GetFileNames_V2()
Dim xDirect$, xFname$, InitialFoldr$, wb As Workbook
InitialFoldr$ = "C:\"
Application.ScreenUpdating = False
Application.EnableEvents = False
Application.Calculation = xlCalculationManual
    With Application.FileDialog(msoFileDialogFolderPicker)
        .InitialFileName = Application.DefaultFilePath & "\"
        .Title = "Merci de choisir le dossier source, svp"
        .InitialFileName = InitialFoldr$
        .Show
            If .SelectedItems.Count <> 0 Then
            xDirect = .SelectedItems(1) & "\"
            xFname = Dir(xDirect$, 7)
            Do While xFname <> ""
                DoEvents
                Set wb = Workbooks.Open(Filename:=xDirect & xFname)
                wb.BuiltinDocumentProperties("Title") = xFname
                wb.Close SaveChanges:=True
                DoEvents
            xFname = Dir
            Loop
        End If
    End With
MsgBox "Tâche terminée!"
Application.EnableEvents = True
Application.Calculation = xlCalculationAutomatic
Application.ScreenUpdating = True
End Sub

Si j'aligne toutes les lignes à gauche la macro se lance mais il y a des fenêtres qui s'ouvre qui demande l'accès à un serveur ''ACCES'' ou un truc comme ça! Ca mouline, puis d'autres petits soucis, comme la corruption des fichiers jpg qui ne s'ouvrent plus. c'est étrange non ?
Précision importante, je suis passé à office 2016 depuis.

 

[Staple1600]

Bonjour, le fil, le forum

Comme dit précédemment, chez moi cela fonctionne

Bonjour le fil, le forum
Ta macro ainsi modifiée fonctionne chez moi.
(XL2013-W10)

Evidemment j'ai testé dans un dossier en local (sur mon HD) qui ne contenait que des classeurs Excel.

 

[Staple1600]

Re

Suite
Cette macro aussi fonctionne sur mon PC.
Tu choisis un dossier, ensuite seuls le fichiers ayant une extension *.xls* seront traités.
(testé avec XL 2013 et W10)

Sub Selection_Tout_Type_Fichier_XL()
Dim Dossier$, Classeur$, wb As Workbook
Application.ScreenUpdating = False
Application.DisplayAlerts = False: Application.EnableEvents = False: Application.Calculation = -4135
    With Application.FileDialog(4)
    .AllowMultiSelect = False
    .Title = "Sélectionner le dossier de votre choix"
    If .Show = -1 Then
        Dossier = .SelectedItems(1)
    End If
    If Dossier = "" Then Exit Sub
    End With
    Classeur = Dir(Dossier & "\*.xls*")
    Do While Classeur <> ""
        Set wb = Workbooks.Open(Dossier & "\" & Classeur)
        DoEvents
        wb.BuiltinDocumentProperties("Title") = wb.Name: wb.Close True
        DoEvents
        Classeur = Dir
    Loop
MsgBox "Tâche terminée!"
Application.EnableEvents = True: Application.Calculation = -4105: Application.ScreenUpdating = True
End Sub

 

[re4]

Bonjour
Merci beaucoup pour vos réponses, je ne m'explique pas pourquoi une partie du code est rouge (et donc erreur) chez moi, j'ai Win10 +office 2016.
Je vous ai précisé un peu tard que mes fichiers sont des fichiers jpg mais cela n'explique pas le code en rouge.
Encore merci pour votre patience et votre aide

 

[MJ13]

Bonjour Re4, JM

Attention, ce que tu cherches à faire est très difficile à faire avec du VBA.

Il me semble que les BuiltinDocumentProperties sont dédiés aux documents Office, donc pas pour Jpg.

Sinon voir ici:

http://pyrros.fr/tutoriel/lire-ecrire-metadonnees/

 

[re4]

Re bonjour à tous,
Oui, j'utilise déjà Lightroom et EXIFManager. mais je voulais modifier le titre des photos que je reçois sans les importer dans Lightroom.
EXIFManager le fait très bien mais il faut cliquer autant de fois que de photos.
Je cherchais à simplifier mais visiblement ce n'est pas aussi simple que le pensais.
Merci quand même de vous être penché sur le problème
Bonne journée

 

[Staple1600]

Bonsoir le fil, le forum

Mon code est fait pour fonctionner avec des classeurs Excel
(ce qui me semblait logique vu que nous sommes sur un forum dédié à Excel)
Et comme le premier message ne faisait pas mention de fichier jpg...

Donc pour des fichiers jpg, voir ici
Ce lien n'existe plus
Et voir sur le net, les exemples pour piloter cet exe par VBA.

 

[re4]

Bonjour,
Pas de souci Staple1600, je suis venu ici parce que je voulais utiliser le VBA avec Excel, il est vrai que je n'avais pas précisé que les fichiers étaient des jpg.
Merci pour les infos