[VBS et HTA] Ajout, modification des commentaires d'un fichier image .jpg

Salut

Petite méthode pour créer ou modifier le commentaire d'une image .jpg
Pièce jointe 182126
Prés requis, Windows XP et suivant.
Le lien qui m'a permis de mettre au point le code Utiliser la librairie Windows Image Acquisition en VBA merci à SilkyRoad

Code:

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
Function LireTag(ChemNomImg)
    Dim Img 'As Object ' ImageFile
    'Création conteneur de l'image pour la recherche de l'information "Commentaires"
    Set Img = CreateObject("WIA.imageFile")
    On Error Resume Next
    'Chargement de l'image dans le conteneur
    Img.LoadFile (ChemNomImg)
    If Err Then LireTag = Err.Description: Exit Function
    LireTag = Img.Properties("40092").Value.String
    If Err Then LireTag = Err.Number & vbNewLine & Err.Description: Exit Function
    Set Img = Nothing
End Function
Function EcrireTag(ChemNomImg, NewInfos)
    Dim Img 'As Object ' ImageFile
    Dim ImgProcess' As Object 'ImageProcess
    Dim ImgVector' As Object 'Vector
 
    'Création conteneur de l'image pour la recherche de l'information "Commentaires"
    Set Img = CreateObject("WIA.imageFile")
    On Error Resume Next
    'Chargement de l'image dans le conteneur
    Img.LoadFile (ChemNomImg)
    If Err Then EcrireTag = Err.Description: Exit Function
    EcrireTag = Img.Properties("40092").Value.String 'provoque une erreur si le tag commentaires n'existe pas encore
    If Err.Number <> -2145320857 And Err.Number <> 0 Then EcrireTag = Err.Description: Exit Function
 
    On Error GoTo 0
    ' si Err.Number = -2145320857 création du TAG, si Err.Number = 0 on le modifi
    Set ImgProcess = CreateObject("WIA.imageProcess") 'création du gestionnaire de filtre
    Set ImgVector = CreateObject("WIA.Vector") 'création d'un vecteur
    ImgProcess.Filters.Add ImgProcess.FilterInfos("Exif").FilterID
    ImgProcess.Filters(1).Properties("ID") = 40092
    ImgProcess.Filters(1).Properties("Type") = 1101 'VectorOfBytesImagePropertyType
    ImgVector.SetFromString NewInfos 'stocke une chaine de caractères dans le vecteur
    ImgProcess.Filters(1).Properties("Value") = ImgVector 'applique au filtre le contenu du vecteur
    Set ImgVector = Nothing
    Set Img = ImgProcess.Apply(Img) 'application du filtre dans l'image
    Set ImgProcess = Nothing
	fso.DeleteFile(ChemNomImg)'car Img.SaveFile ne veux pas écraser le fichier
    'sauvegarde de l'image
    Img.SaveFile ChemNomImg
    Set Img = Nothing
    EcrireTag = "OK"
End Function
 
Dim fso,DossierDuProg
Set fso = CreateObject("Scripting.FileSystemObject")
DossierDuProg = fso.GetParentFolderName(wscript.ScriptFullName)
 
msgbox LireTag(DossierDuProg & "\DscEssais.JPG"),64,"Lecture sans le commentaire"
EcrireTag DossierDuProg & "\DscEssais.JPG", "Je pense que cela fonctionne pour la modification du TAG Commentaires"
msgbox LireTag(DossierDuProg & "\DscEssais.JPG"),64,"Lecture après ajout du commentaire"
EcrireTag DossierDuProg & "\DscEssais.JPG", "Voilà pour la démo"
msgbox LireTag(DossierDuProg & "\DscEssais.JPG"),64,"Lecture après modification du commentaire"
Set fso = Nothing

Code:

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
        <HEAD>
                <TITLE> Créer ou modifier un commentaire </TITLE>
                <HTA:APPLICATION
                        applicationname="RecupModifComm"
                        version="1"
                        id="RecupModifComm"
                        >
        </HEAD>
        <SCRIPT language="VBScript">
                ' Déclarations utilisables dans toute la partie VBScript
                Dim DossierDuProg, Cpt
        '----------------------------------------------------------------------------------------------------------------------
        Sub Window_Onload()
                Dim ChemNomComplet
                ChemNomComplet = RecupModifComm.CommandLine ' ChemNomComplet = Id du programme.CommandLine
                DossierDuProg = RecupNomChemin(ChemNomComplet)
                DossierDuProg = Replace(DossierDuProg,Chr(34),"")
        End Sub
        '----------------------------------------------------------------------------------------------------------------------
        Function RecupNomChemin(StrSoumis)
                RecupNomChemin = Left(StrSoumis, (InStrRev(StrSoumis, "\", -1, vbTextCompare)))
        End Function
        '------------------------------------------------------------------------------------------------------------------
        Function LireTag(ChemNomImg)
                Dim Img 'As Object ' ImageFile
                'Création conteneur de l'image pour la recherche de l'information "Commentaires"
                Set Img = CreateObject("WIA.imageFile")
                On Error Resume Next
                'Chargement de l'image dans le conteneur
                Img.LoadFile (ChemNomImg)
                If Err Then LireTag = Err.Description: Exit Function
                LireTag = Img.Properties("40092").Value.String
                If Err Then LireTag = Err.Number & vbNewLine & Err.Description: Exit Function
                Set Img = Nothing
        End Function
        '------------------------------------------------------------------------------------------------------------------
        Function EcrireTag(ChemNomImg, NewInfos)
                Dim Img 'As Object ' ImageFile
                Dim ImgProcess' As Object 'ImageProcess
                Dim ImgVector' As Object 'Vector
 
                'Création conteneur de l'image pour la recherche de l'information "Commentaires"
                Set Img = CreateObject("WIA.imageFile")
                On Error Resume Next
                'Chargement de l'image dans le conteneur
                Img.LoadFile (ChemNomImg)
                If Err Then EcrireTag = Err.Description: Exit Function
                EcrireTag = Img.Properties("40092").Value.String 'provoque une erreur si le tag commentaires n'existe pas encore
                If Err.Number <> -2145320857 And Err.Number <> 0 Then EcrireTag = Err.Description: Exit Function
 
                On Error GoTo 0
                ' si Err.Number = -2145320857 création du TAG, si Err.Number = 0 on le modifie
                Set ImgProcess = CreateObject("WIA.imageProcess") 'création du gestionnaire de filtre
                Set ImgVector = CreateObject("WIA.Vector") 'création d'un vecteur
                ImgProcess.Filters.Add ImgProcess.FilterInfos("Exif").FilterID
                ImgProcess.Filters(1).Properties("ID") = 40092
                ImgProcess.Filters(1).Properties("Type") = 1101 'VectorOfBytesImagePropertyType
                ImgVector.SetFromString NewInfos 'stocke une chaine de caractères dans le vecteur
                ImgProcess.Filters(1).Properties("Value") = ImgVector 'applique au filtre le contenu du vecteur
                Set ImgVector = Nothing
                Set Img = ImgProcess.Apply(Img) 'application du filtre dans l'image
                Set ImgProcess = Nothing
                DeleteAFile ChemNomImg 'car Img.SaveFile ne veux pas écraser le fichier
                'sauvegarde de l'image
                Img.SaveFile ChemNomImg
                Set Img = Nothing
                EcrireTag = "OK"
        End Function
        '------------------------------------------------------------------------------------------------------------------
        Sub DeleteAFile(filespec)
                Dim fso
                Set fso = CreateObject("Scripting.FileSystemObject")
                fso.DeleteFile(filespec)
        End Sub
        '------------------------------------------------------------------------------------------------------------------
        Sub LireOnClick()
                Infos.Innertext = LireTag(DossierDuProg & "DscEssais.JPG")
        End Sub
        '------------------------------------------------------------------------------------------------------------------
        Sub EcrireOnClick()
                Cpt = Cpt + 1
                Infos.Innertext = EcrireTag(DossierDuProg & "DscEssais.JPG", Cpt & " Je pense que cela fonctionne pour la modification du TAG Commentaires")
        End Sub
        '------------------------------------------------------------------------------------------------------------------
        </SCRIPT>
        <body>
                        <INPUT Type="button" id="Lire" name="Lire" value="Lire" onClick="LireOnClick" >
                        <INPUT Type="button" id="Ecrire" name="Ecrire" value="Ecrire" onClick="EcrireOnClick" >
                        <BR>
                        <Div Id="Infos"> le commentaire </Div>
        </body>

Il vous faut une image .JPG dans le même dossier ou vous aurez sauvegardé le code ci-dessus, au départ, l'idéal pour la démonstration est d'avoir un fichier qui n'a pas encor de commentaires.
Pensez donc à mettre le nom de votre fichier lignes 50 à 54 pour le VBS et lignes 77 et 82 pour le HTA.

Vous pouvez aller plus loin au vu du tutoriel de SilkyRoad

Citation:

IP.Filters(1).Properties("ID") = 40091
'40091 Titre
'40092 Commentaire
'40093 Auteur
'40094 Mots clés

:merci: de vos commentaires.:cfou: ------------>:aie: