LECTURE ET MODIFICATION DES TAG ET COMMENTAIRE D'UN FICHIER PDF (INEDIT)

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

Télécharger le zip

02 février 2006 14:16:05 :

Ajout de mot clé