Public Sub CmdShell_Ecrit()
Dim inta As Integer
Dim CheminProg As String
Dim CheminPhoto As String
Dim Titre As String
Dim Description As String
Dim Auteur As String
Dim astrMotsClés As String
Dim Ville As String
Dim Pays As String
Dim Copyright As String
Dim UrlCopy As String
Dim Catagorie As String
Dim ComplCat As String
Dim Ligne As Integer
CheminProg = Cells(5, 2).Value
' Select cell A10 départ de la liste
Range("A10").Select
Ligne = 10
'parcours tant que pas vide
Do While (Cells(Ligne, 1).Value <> "")
' valeurs qui changent en fonction de l'image sélectionnée
CheminPhoto = Cells(4, 2).Value + Cells(Ligne, 1).Value
Titre = Cells(Ligne, 2).Value
Description = Cells(Ligne, 2).Value
Ville = Cells(Ligne, 3).Value
Pays = Cells(Ligne, 4).Value
' paramètre fixe
Auteur = "xxxxxxxxxxxxx"
astrMotsClés = "Photographie"
Copyright = "Copyright HB - 2023"
UrlCopy = "[URL]https://photolibart.hd.free.fr[/URL]"
Catagorie = "PHO"
ComplCat = "Photographie"
ExifWrite CheminProg, CheminPhoto, Titre, Description, Auteur, 12, astrMotsClés, Ville, Pays, Copyright, UrlCopy, Catagorie, ComplCat
' Descendez d'une rangée à partir de l'emplacement actuel.
Ligne = Ligne + 1
Loop
MsgBox "Traitement terminé"
End Sub
Private Function ExifWrite(ExifToolPath As String, Fichier As String, Titre As String, _
Description As String, Auteur As String, _
Notation As Integer, MotsClés As String, _
Ville As String, Pays As String, _
Copyright As String, UrlCopy As String, _
Categorie As String, ComplCat As String) As Double
Dim strCommandLine As String
Dim inta As Integer
'Tags récupéré via commande shell
'SourceFile , IPTC: ObjectName , IPTC: Headline ,
'IPTC: Category , IPTC: SupplementalCategories ,
'IPTC: Caption -Abstract, xmp: Description , EXIF: ImageDescription ,
'IPTC: Keywords ,
'IPTC: City , IPTC: Country -PrimaryLocationName,
'xmp: Rights , IPTC: CopyrightNotice , EXIF: Copyright ,
'IPTC: By -Line, IPTC: Writer -Editor, xmp: Creator , EXIF: Artist ,
'xmp: CreatorWorkURL
' créer la ligne de commande shell avec les informations à integrer
strCommandLine = ExifToolPath & "exiftool " ' répertoire execution exiftool.exe
strCommandLine = strCommandLine & "-IPTC:ObjectName=""" & Titre & """ "
strCommandLine = strCommandLine & "-iptc:Headline=""" & Titre & """ "
strCommandLine = strCommandLine & "-title=""" & Titre & """ "
strCommandLine = strCommandLine & "-XPTitle=""" & Titre & """ "
strCommandLine = strCommandLine & "-iptc:Caption-Abstract=""" & Description & """ "
strCommandLine = strCommandLine & "-xmp:Description=""" & Description & """ "
strCommandLine = strCommandLine & "-EXIF:ImageDescription=""" & Description & """ "
strCommandLine = strCommandLine & "-iptc:by-line=""" & Auteur & """ "
strCommandLine = strCommandLine & "-IPTC:Writer-Editor=""" & Auteur & """ "
strCommandLine = strCommandLine & "-xmp:Creator=""" & Auteur & """ "
strCommandLine = strCommandLine & "-EXIF:Artist=""" & Auteur & """ "
strCommandLine = strCommandLine & "-creator=""" & Auteur & """ "
strCommandLine = strCommandLine & "-XPAuthor=""" & Auteur & """ "
Dim intNotationPourcent As Integer
Select Case Notation
Case Is = 0
intNotationPourcent = 0
Case Is = 1
intNotationPourcent = 1
Case Is = 2
intNotationPourcent = 25
Case Is = 3
intNotationPourcent = 50
Case Is = 4
intNotationPourcent = 75
Case Is = 5
intNotationPourcent = 99
Case Else
intNotationPourcent = 99
End Select
If Notation < 6 Then
strCommandLine = strCommandLine & "-Rating=""" & Notation & """ "
strCommandLine = strCommandLine & "-RatingPercent=""" & intNotationPourcent & """ "
Else
strCommandLine = strCommandLine & "-Rating=12 "
strCommandLine = strCommandLine & "-RatingPercent=""" & 99 & """ "
End If
strCommandLine = strCommandLine & "-iptc:Keywords=""" & MotsClés & """ "
strCommandLine = strCommandLine & "-iptc:city=""" & Ville & """ "
strCommandLine = strCommandLine & "-iptc:Country-PrimaryLocationName=""" & Pays & """ "
strCommandLine = strCommandLine & "-iptc:copyrightnotice=""" & Copyright & """ "
strCommandLine = strCommandLine & "-xmp:Rights=""" & Copyright & """ "
strCommandLine = strCommandLine & "-EXIF:Copyright=""" & Copyright & """ "
strCommandLine = strCommandLine & "-xmp:CreatorWorkURL=""" & UrlCopy & """ "
strCommandLine = strCommandLine & "-UserComment=""" & UrlCopy & """ "
strCommandLine = strCommandLine & "-XPComment=""" & UrlCopy & """ "
strCommandLine = strCommandLine & "-iptc:Category=""" & Categorie & """ "
strCommandLine = strCommandLine & "-iptc:SupplementalCategories=""" & ComplCat & """ "
strCommandLine = strCommandLine & " -overwrite_original " ' évite la création d'un double du fichier en extension _original
'strCommandLine = strCommandLine & "-k " '-fast " 'k pour que la fenetre ne se ferme pas, fast surement inutile en ecriture
strCommandLine = strCommandLine & " -L " '-L pour ne pas transformer le langage latin en utf8 fichier est codé en Latin1 sauf si le CodedCharacterSet enregistré est « ESC % G » (UTF8),
strCommandLine = strCommandLine & "-IPTC:CodedCharacterSet=utf8 " ' permet les accent sur les lettres Français
strCommandLine = strCommandLine & """" & Fichier & """"
'Debug.Print strCommandLine
ExifWrite = Shell(strCommandLine, vbNormalFocus)
End Function
