feuille archives:
Private Sub CommandButton1_Click()
Dim strRep As String
Dim fd As FileDialog
Dim vrtSelectedItem As Variant
Set fd = Application.FileDialog(msoFileDialogFolderPicker)
fd.AllowMultiSelect = False
fd.Show
With fd
If .Show = -1 Then
For Each vrtSelectedItem In .SelectedItems
strRep = vrtSelectedItem
Next vrtSelectedItem
Else
End If
End With
Set fd = Nothing
Worksheets("ARCHIVES").Cells(1, 1).Value = strRep
End Sub
Private Sub CommandButton2_Click()
Worksheets("GENERAL").Select
Worksheets("GENERAL").Range("A1").Select
End Sub
Private Sub Rafraichir_Click()
Getpdf
End Sub
Private Sub Worksheet_Activate()
Getpdf
End Sub
Private Sub Worksheet_Change(ByVal Target As Range)
If (Target.Address(RowAbsolute:=False) = "$A1") Then Getpdf
End Sub
module 1:
Option Explicit 'Force la declaration de toutes les variables
Sub Getpdf()
Dim Nbr, NbrDel, i As Integer 'Déclaration Nbr, NbrDel et i comme Integer
Dim RepSearch As String 'Déclaration RepSearch comme Chaine de caractères
Dim Rep As FileSearch 'Déclaration Rep comme Boite de dialogue
Dim objHyper As Hyperlink 'Déclaration objHyper comme Lien hypertexte
Set Rep = Application.FileSearch 'Création de l'objet de recherche
'On Error GoTo Errgst 'Emplacement de la gestion d'erreur
RepSearch = Worksheets("ARCHIVES").Cells(1, 1).Value 'Affectation de RepSearch avec le contenu de la cellule A1
NbrDel = 4 'Nombre de lignes dans le "header excel"
Do 'Boucle de vérification du contenu des cellules
NbrDel = NbrDel + 1 'Implementation du nombre de cellules non vide
Loop Until Worksheets("ARCHIVES").Cells(NbrDel, 1).Value = "" 'Execute la boucle tant que la cellule suivante n'est pas nulle
With Rep
.LookIn = RepSearch 'Affectation durepertoire de recherche a l'objet de recherche
.FileName = "*.pdf" 'Filtre de recherche eventuel
.SearchSubFolders = True 'Affectation de la propriété de recherche dans les sous repertoires
.Execute 'Effectue la recherche
End With
Nbr = Rep.FoundFiles.Count 'Affectation de Nbr du nombre de fichiers trouvés au cours de la recherche
Worksheets("ARCHIVES").Range("A4:A" & NbrDel).Delete 'Efface le contenu précédent des cellules
Worksheets("ARCHIVES").Cells(1, 2).Value = Nbr & " références trouvées" 'Affiche le nombre de références
For i = 1 To Nbr 'Demarre une boucle parcourant les entier de 1 à Nbr
Worksheets("ARCHIVES").Cells(i + 3, 1).Value = Rep.FoundFiles.Item(i) 'Ajoute la reference trouvée dans la bonne case
Worksheets("ARCHIVES").Hyperlinks.Add Worksheets("ARCHIVES").Cells(i + 3, 1), Rep.FoundFiles.Item(i) 'Cree un lien hypertexte vers la reference en cours
Next i 'Passe a la reference suivante
ChargeTag
Exit Sub 'Si tout c'est bien passé, fin de la procédure
errgst: 'Gestion des erreurs
MsgBox "Erreur...", vbOKOnly, "P'tit probleme"
MsgBox Err.Description 'Affiche la description de l'erreur
End Sub
module 2:
Option Explicit 'Force la declaration de toutes les variables
Public Sub ChargeTag()
Dim fichierpdf, repertoire As String 'Déclare deux chaines de caracteres
Dim Nbr, attribut As Integer 'Déclare deux Integers
Dim bool As Boolean 'Déclare un booleen
Nbr = 4 'Affecte le nombre de ligne du "header" du document excel à la variable Nbr
Do 'Demarre un boucle parcourant les entrées de la feuille
fichierpdf = Worksheets("ARCHIVES").Cells(Nbr, 1).Value 'Récupere l'adresse du fichier correspondant a la ligne Nbr
If Right(fichierpdf, 3) = "ARCHIVES" Then 'Filtre pour fichiers pdf
attribut = GetAttr(fichierpdf) 'Verifie l'état "lecture seule" (probablement optionnel)
Worksheets("ARCHIVES").Cells(Nbr, 2).Value = GetAuteur(ByVal fichierpdf) 'Affecte le resultat de la fonction GetAuteur dans la colone 2 de la ligne Nbr de la feuille pdf
bool = DetectV2(ByVal fichierpdf)
End If 'Fin de la condition du filtre pdf
Nbr = Nbr + 1 'Incremente le numero de la ligne Nbr
Loop While Worksheets("ARCHIVES").Cells(Nbr, 1) <> "" 'Boucle tant que la ligne Nbr ne vaut pas chaine vide
End Sub
Private Function GetAuteur(ByVal fichier As String) As String
If CheckTag(fichier, False) = False Then Exit Function 'Si la fonction CheckTag renvoit faux alors sort de la fonction
Dim ff As Integer 'Déclare une variable ff en tant qu'Integer
Dim txt1 As String * 30 'Déclare une variable de type chaine de 30 caractères
ff = FreeFile 'Affecte le numero de fichier suivant disponible a la variable ff
Open fichier For Binary As ff 'Ouvre le fichier contenu dans le parametre en mode binaire
Get ff, FileLen(fichier) - 94, txt1 'Place
Close ff 'Ferme le fichier
GetAuteur = Trim$(txt1) 'Affecte à GetAuteur le contenu de txt1 sans espace ni a droite, ni a gauche.
End Function
Private Function CheckTag(fichier As String, Ecrire As Boolean) As Boolean
Dim ReadOnly As Boolean 'Déclare ReadOnly comme booleen
Dim ff As Integer 'Déclare ff comme Integer
ReadOnly = False 'Affecte faux au booleen ReadOnly
If (GetAttr(fichier) = 1 Or GetAttr(fichier) = 33) And Ecrire = True Then 'Condition si l'attribut du fichier vaut 1 OU 33 ET que l'argument booleen Ecrire vaut vrai
ReadOnly = True 'Affecte vrai à la variable ReadOnly
Exit Function 'Sort de la fonction CheckTag
End If 'Fin de condition
'''''''''''''''''''''''''''''''''''''''''''''''''''''ici''''''''''''''''''''''''
On Error Resume Next '"Gestion" d'erreur
CheckTag = True 'Affecte vrai a la fonction booleenne CheckTag
Dim Tag As String * 3 'Déclare Tag comme chaine de 3 caracteres
ff = FreeFile 'Affecte à la variable ff le numero de fichier suivant disponible
Open fichier For Binary As ff 'Ouvre le fichier dont l'adresse est stoquee dans le parametre fichier en mode binaire
Get ff, FileLen(fichier) - 127, Tag 'Récupère les 127 derniers bytes contenu dans le fichier de numero ff et le place dans la variable Tag
If Tag <> "TAG" Then CheckTag = False 'Si la variable Tag ne vaut pas "TAG" (marqueur de tag) alors affecte à CheckTag faux
If Ecrire = True And CheckTag = False Then 'Si les parametres booleens Ecrire et CheckTag valent vrai ET faux ALORS
Dim TagSpace As String * 128 'Déclaration d'une chaine TagSpace de 128 caracteres
TagSpace = "TAG" '?
Put ff, FileLen(fichier), TagSpace 'Affecte à TagSpace le contenu de ff
End If 'Fin de condition
Close ff 'Ferme le fichier en cours
End Function
Private Function DetectV2(ByVal fichier As String) As Boolean
Dim deb As String * 3 'Déclare deb comme chaine de 3 caracteres
Open fichier For Binary As #1 'Ouvre le fichier dont l'adresse est en parametre
Get #1, 1, deb 'Affecte le premier enregistrement du fichier à deb
Close #1 'Ferme le fichier
If deb = "ID3" Then 'Si deb vaut "ID3"
DetectV2 = True 'Affecte vrai a la fonction booleenne DetectV2
Else 'Sinon
DetectV2 = False 'Affecte faux a la fonction booleenne DetectV2
End If 'Fin de condition
End Function