Ce programme permet de modifier et lire les tags, commentaire d'un fichier pdf.
Le module s'accompagne d'une forme qui permet d'executer les fonctions.
Enfin le fichier est lisible par acrobat et reader mais acrobat demandera d'enregistrer le fichier car il aurrat quelque erreur mais il peut être catalogé sans problème.
Source / Exemple :
Public Sub propriete(ByVal Title As String, ByVal Auteur As String, ByVal Subject As String, ByVal Keywords As String, ByVal CreateDate As Date, ByVal ModifDate As Date, ByVal stFichier As String, ByVal stFichierdest As String)
Dim inFree As Integer
Dim datetemps As Date
Dim binByte() As Byte
Dim taille As Long
Dim deb As Long
Dim fin As Long
Dim init As Long
Dim nbbyte As Long
Dim Producer As String
Dim Creator As String
Dim ModDate As String
Dim CreationDate As String
Dim strobj As String
'***********************
Producer = "PDFTAG 1.0"
Creator = "PDFTAG 1.0"
ModDate = "D:" & Format(ModifDate, "yyyymmddhhmmss+03'00'")
CreationDate = "D:" & Format(CreateDate, "yyyymmddhhmmssZ")
Call copy(binByte(), taille, stFichier)
strobj = Create_obj(Producer, Auteur, Creator, ModDate, Title, CreationDate, Subject, Keywords)
deb = taille - 1
While balise_obj(binByte(), taille, deb, fin, (taille - 1) - deb)
Call remplace(binByte(), deb, fin, taille, strobj)
Wend
datetemps = ModifDate
ModDate = Format(datetemps, "yyyy-mm-ddThh:mm:ss+03:00")
datetemps = CreateDate
CreationDate = Format(datetemps, "yyyy-mm-ddThh:mm:ssZ")
strobj = Create_pdftag(Producer, Auteur, Creator, ModDate, Title, CreationDate, Subject, Keywords, nbbyte)
deb = taille - 1
While balise_pdf(binByte(), taille, deb, fin, (taille - 1) - deb)
Call remplace(binByte(), deb, fin, taille, strobj)
Wend
strobj = Create_pdftagav(nbbyte)
deb = taille - 1
While balise_pdfav(binByte(), taille, deb, fin, (taille - 1) - deb)
Call remplace(binByte(), deb, fin, taille, strobj)
Wend
'***********************
On Error Resume Next
Call Kill(stFichierdest)
inFree = FreeFile
Open stFichierdest For Binary Access Write As #inFree
Put #inFree, , binByte
Close #inFree
End Sub
Private Function Create_obj(Producer As String, Auteur As String, Creator As String, ModDate As String, Title As String, CreationDate As String, Subject As String, Keywords As String) As String
Create_obj = Chr(13) & "/Producer (" & Producer & ")" & _
Chr(13) & "/Author (" & Auteur & ")" & _
Chr(13) & "/Creator (" & Creator & ")" & _
Chr(13) & "/ModDate (" & ModDate & ")" & _
Chr(13) & "/Title (" & Title & ")" & _
Chr(13) & "/CreationDate (" & CreationDate & ")" & _
Chr(13) & "/Subject (" & Subject & ")" & _
Chr(13) & "/Keywords (" & Keywords & ")" & Chr(13)
End Function
Private Function Create_pdftagav(nbbyte As Long) As String
Create_pdftagav = "<< /Type /Metadata /Subtype /XML /Length " & nbbyte & " >>"
End Function
Private Function Create_pdftag(Producer As String, Auteur As String, Creator As String, ModDate As String, Title As String, CreationDate As String, Subject As String, Keywords As String, nbbyte As Long) As String
nbbyte = 1000
While Len(Tag) <> nbbyte
nbbyte = Len(Tag)
Tag = "<?xpacket begin='' id='W5M0MpCehiHzreSzNTczkc9d' bytes='" & nbbyte & "'?>" & _
"<rdf:RDF xmlns:rdf='http://www.w3.org/1999/02/22-rdf-syntax-ns#'" & _
" xmlns:iX='http://ns.adobe.com/iX/1.0/'>" & _
" <rdf:Description about=''" & _
" xmlns='http://ns.adobe.com/pdf/1.3/'" & _
" xmlns:pdf='http://ns.adobe.com/pdf/1.3/'>" & _
" <pdf:Producer>" & Producer & "</pdf:Producer>" & _
" <pdf:Author>" & Auteur & "</pdf:Author>" & _
" <pdf:Creator>" & Creator & "</pdf:Creator>" & _
" <pdf:ModDate>" & ModDate & "</pdf:ModDate>" & _
" <pdf:Title>" & Title & "</pdf:Title>" & _
" <pdf:CreationDate>" & CreationDate & "</pdf:CreationDate>" & _
" <pdf:Subject>" & Subject & "</pdf:Subject>" & _
" <pdf:Keywords>" & Keywords & "</pdf:Keywords>" & _
" </rdf:Description>" & _
" <rdf:Description about=''" & _
" xmlns='http://ns.adobe.com/xap/1.0/'" & _
" xmlns:xap='http://ns.adobe.com/xap/1.0/'>" & _
" <xap:Author>" & Auteur & "</xap:Author>" & _
" <xap:ModifyDate>" & ModDate & "</xap:ModifyDate>" & _
" <xap:Title>" & _
" <rdf:Alt>" & _
" <rdf:li xml:lang='x-default'>" & Title & "</rdf:li>" & _
" </rdf:Alt>" & _
" </xap:Title>"
Tag = Tag & " <xap:CreateDate>" & CreationDate & "</xap:CreateDate>" & _
" <xap:Description>" & _
" <rdf:Alt>" & _
" <rdf:li xml:lang='x-default'>" & Subject & "</rdf:li>" & _
" </rdf:Alt>" & _
" </xap:Description>" & _
" <xap:MetadataDate>" & ModDate & "</xap:MetadataDate>" & _
" </rdf:Description>" & _
" <rdf:Description about=''" & _
" xmlns='http://purl.org/dc/elements/1.1/'" & _
" xmlns:dc='http://purl.org/dc/elements/1.1/'>" & _
" <dc:creator>" & Creator & "</dc:creator>" & _
" <dc:title>" & Title & "</dc:title>" & _
" <dc:description>" & Subject & "</dc:description>" & _
" </rdf:Description>" & _
"</rdf:RDF>" & _
"<?xpacket end='r'?>"
Wend
Create_pdftag = Tag
End Function
Private Function balise_obj(ByRef binByte() As Byte, taille As Long, deb As Long, fin As Long, init As Long)
Dim l As Long
Dim stread As String
Dim recherche As String
recherche = "/Producer"
l = Len(recherche)
For j = 0 To l - 2
stread = Chr(binByte(taille - init - j)) & stread
Next
While init < (taille - l) And stread <> recherche
init = init + 1
stread = Left(Chr(binByte(taille - init - l + 1)) & stread, l)
Wend
If stread = recherche Then
recherche = "<< "
l = Len(recherche)
While init < (taille - l) And stread <> recherche
init = init + 1
stread = Left(Chr(binByte(taille - init - l + 1)) & stread, l)
Wend
If stread = recherche Then
deb = taille - init
recherche = Chr(13) + ">>"
l = Len(recherche)
While init > 1 And stread <> recherche
init = init - 1
stread = Right(stread & Chr(binByte(taille - init - l + 1)), l)
Wend
If stread = recherche Then
fin = taille - init - l + 1
init = deb
balise_obj = True
Else
balise_obj = False
End If
End If
End If
End Function
Private Function balise_pdfav(ByRef binByte() As Byte, taille As Long, deb As Long, fin As Long, init As Long)
Dim l As Long
Dim stread As String
Dim recherche As String
recherche = "<< /Type /Metadata /Subtype /XML /Length "
l = Len(recherche)
For j = 0 To l - 2
stread = Chr(binByte(taille - init - j)) & stread
Next
While init < (taille - l) And stread <> recherche
init = init + 1
stread = Left(Chr(binByte(taille - init - l + 1)) & stread, l)
Wend
If stread = recherche Then
deb = taille - init - l
recherche = " >>"
l = Len(recherche)
While init > 1 And stread <> recherche
init = init - 1
stread = Right(stread & Chr(binByte(taille - init - l + 1)), l)
Wend
If stread = recherche Then
fin = taille - init - l + 3
init = deb
balise_pdfav = True
Else
balise_pdfav = False
End If
End If
End Function
Private Function balise_pdf(ByRef binByte() As Byte, taille As Long, deb As Long, fin As Long, init As Long)
Dim l As Long
Dim stread As String
Dim recherche As String
recherche = "<?xpacket begin=''"
l = Len(recherche)
For j = 0 To l - 2
stread = Chr(binByte(taille - init - j)) & stread
Next
While init < (taille - l) And stread <> recherche
init = init + 1
stread = Left(Chr(binByte(taille - init - l + 1)) & stread, l)
Wend
If stread = recherche Then
deb = taille - init - l
recherche = "<?xpacket end='r'?>"
l = Len(recherche)
While init > 1 And stread <> recherche
init = init - 1
stread = Right(stread & Chr(binByte(taille - init - l + 1)), l)
Wend
If stread = recherche Then
fin = taille - init - l + 3
init = deb
balise_pdf = True
Else
balise_pdf = False
End If
End If
End Function
Private Sub copy(ByRef binByte() As Byte, taille As Long, stFichier As String)
Dim inFree As Integer
inFree = FreeFile
Open stFichier For Binary Access Read As #inFree
taille = LOF(inFree)
ReDim binByte(taille)
Get #inFree, 1, binByte
Close #inFree
End Sub
Private Sub remplace(ByRef binByte() As Byte, debut As Long, fin As Long, taille As Long, strval As String)
Dim tempByte() As Byte
Dim newtaille As Long
'debut: byte fin dans tab
'fin:byte debut dans tab
'taille:nb byte
newtaille = (debut + 1) + (taille - (fin + 1)) + Len(strval)
ReDim tempByte(newtaille)
For i = 0 To debut
tempByte(i) = binByte(i)
Next
For i = 1 To Len(strval)
tempByte(i + debut) = Asc(Mid(strval, i, 1))
Next
dd = (debut + Len(strval))
ff = (newtaille - 1 - dd)
For i = 1 To ff
tempByte((dd + i)) = binByte(fin - 2 + i)
Next
ReDim binByte(newtaille)
binByte = tempByte
taille = newtaille
End Sub
Public Sub lecturepropriete(Title As String, Auteur As String, Subject As String, Keywords As String, ByRef CreateDate As String, ModifDate As String, ByVal stFichier As String)
Dim binByte() As Byte
Dim taille As Long
Dim deb As Long
Dim fin As Long
'***********************
Call copy(binByte(), taille, stFichier)
deb = taille - 1
While balise_obj(binByte(), taille, deb, fin, (taille - 1) - deb)
Call lecturebalise(Title, Auteur, Subject, Keywords, CreateDate, ModifDate, binByte, deb, fin)
Wend
End Sub
Private Sub lecturebalise(Title As String, Auteur As String, Subject As String, Keywords As String, CreateDate As String, ModifDate As String, ByRef binByte() As Byte, debut As Long, fin As Long)
Dim strlect As String
strlect = ""
For i = debut + 1 To fin - 1
strlect = strlect + Chr(binByte(i))
Next
Auteur = Valpropriete(strlect, "Author")
Title = Valpropriete(strlect, "Title")
Subject = Valpropriete(strlect, "Subject")
Keywords = Valpropriete(strlect, "Keywords")
CreateDate = Valpropriete(strlect, "CreationDate")
CreateDate = Mid(CreateDate, 9, 2) & "/" & Mid(CreateDate, 7, 2) & "/" & Mid(CreateDate, 3, 4) & " " & Mid(CreateDate, 11, 2) & ":" & Mid(CreateDate, 13, 2) & ":" & Mid(CreateDate, 15, 2)
ModifDate = Valpropriete(strlect, "ModDate")
ModifDate = Mid(ModifDate, 9, 2) & "/" & Mid(ModifDate, 7, 2) & "/" & Mid(ModifDate, 3, 4) & " " & Mid(ModifDate, 11, 2) & ":" & Mid(ModifDate, 13, 2) & ":" & Mid(ModifDate, 15, 2)
End Sub
Private Function Token(chaine As String, separateur As String) As String
On Error Resume Next
Dim i As Long
i = 1
While Mid(chaine, i, Len(separateur)) <> separateur And i < Len(chaine)
i = i + 1
Wend
Token = Left(chaine, i - 1)
chaine = Right(chaine, Len(chaine) - i)
End Function
Private Function Valpropriete(ByVal chaine As String, propriete As String) As String
Dim tokenchaine As String
tokenchaine = "init"
While Left(tokenchaine, Len(propriete)) <> propriete And tokenchaine <> ""
tokenchaine = Token(chaine, "/")
Wend
If Left(tokenchaine, Len(propriete)) = propriete Then
Call Token(tokenchaine, "(")
Valpropriete = Token(tokenchaine, ")")
End If
End Function
Conclusion :
PS: pour la form il faut pdf.ocx pour visualier les pdfs mais il peut etre suprimé.
Sinon je m'excuse pour la nondoc dans le code....lol
Si quelqu'un l'améliore merci de me prevenir...
Vous n'êtes pas encore membre ?
inscrivez-vous, c'est gratuit et ça prend moins d'une minute !
Les membres obtiennent plus de réponses que les utilisateurs anonymes.
Le fait d'être membre vous permet d'avoir un suivi détaillé de vos demandes et codes sources.
Le fait d'être membre vous permet d'avoir des options supplémentaires.