Soyez le premier à donner votre avis sur cette source.
Vue 13 235 fois - Téléchargée 1 182 fois
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
Pdf.ocx c'est bien
Oui il faut un fichier pdf a l'origine. Il modifie seulement les tags et les commentaires d'un fichier pdf.
Oui il faut un fichier pdf a l'origine. Il modifie seulement les tags et les commentaires d'un fichier pdf.
Il faut un document à l'origine pour ton document ?
++
Moustachu
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.