liste fichier

[Gaetan]

Bonjour,
j'ai modifié un macro qui me donne la liste des fichiers pdf se trouvant dans un dossier dans la feuille archives de mon classeur excel. Mon probleme est que lorsque je clique sur le fichier pour l'ouvrir, il s'ouvre puis se referme. Je voudrai également afficher a droite du lien du fichier la date de création, le nom de l'auteur, et l'objet.
Le fichier est de 94 ko , envoyez moi un message pour l'avoir.
Merci de votre aide.

 

[michel]

bonjour Gaetan

j'espere que cet exemple poura t'aider à recuperer les informations sur les fichiers PDF du repertoire
( un lien hyerptexte est créé dans la premier colonne , pour ouvrir directement les documents )


Sub listeFichiersPdf()
'necessite d'activer la reference Microsoft Shell Controls and Automation
Dim objShell As Shell
Dim strFileName As FolderItem
Dim objFolder As Folder
Dim i As Integer
Dim Chemin As String

Chemin = "C:\Documents and Settings\michel\dossier\general\excel"
Set objShell = CreateObject("Shell.Application")
Set objFolder = objShell.NameSpace(Chemin)

For Each strFileName In objFolder.Items

If Right(objFolder.GetDetailsOf(strFileName, 0), 4) = ".pdf" Then
i = i + 1
Cells(i, 1) = objFolder.GetDetailsOf(strFileName, 0)
Feuil1.Hyperlinks.Add Anchor:=Cells(i, 1), Address:=Chemin & "\" & _
objFolder.GetDetailsOf(strFileName, 0)

Cells(i, 2) = objFolder.GetDetailsOf(strFileName, 1) 'taille fichier
Cells(i, 3) = Format(objFolder.GetDetailsOf(strFileName, 4), "DD/MM/YYYY") 'date creation
Cells(i, 4) = objFolder.GetDetailsOf(strFileName, 9) 'auteur

'0 Name
'1 Size
'2 Type
'3 Date Modified
'4 Date Created
'5 Date Accessed
'6 Attributes
'7 Status
'8 Owner
'9 Author
'10 Title
'11 Subject
'12 Category
'13 Pages
'14 Comments
'15 Copyright
'16 Artist
'17 Album Title
'18 Year
'19 Track Number
'20 Genre
'21 Duration
'22 Bit Rate
'23 Protected
'24 Camera Model
'25 Date Picture Taken
'26 Dimensions
'27 Not used
'28 Not used
'29 Not used
'30 Company
'31 Description
'32 File Version
'33 Product Name
'34 Product Version
End If

Next strFileName

End Sub


par contre je ne comprends pas bien quand tu dis que les fichiers s'ouvrent puis se referment


bonne journée
MichelXld

 

[Gaetan]

Voici ce que j'ai:

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()
GetARCHIVES
End Sub

Private Sub Worksheet_Activate()
GetARCHIVES
End Sub

Private Sub Worksheet_Change(ByVal Target As Range)
If (Target.Address(RowAbsolute:=False) = "$A1") Then GetARCHIVES
End Sub






MODULE 1:
Option Explicit 'Force la declaration de toutes les variables

Sub GetARCHIVES()
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").Unprotect Password:="rascol" 'Enleve la protection de la feuille pour effectuer les changements
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
Worksheets("ARCHIVES").Unprotect Password:="rascol" 'Enleve la protection de la feuille pour effectuer les changements
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 Mp3
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






A l'origine, le fichier ouvrait des fichiers mp3

 

[Gaetan]

Il liste sans probleme les fichiers pdf mais lorsque je clique sur le liens acrobat s'ouvre et se referme.

 

[Gaetan]

C'est bon ça marche , j'ai installé acrobat reader 6 à la place du 7 et maintenant le fichier s'ouvre.

 

[Gaetan]

Par contre je suis toujours a la recherche du code pour afficher le nom de l'auteur colonne 2, la date de création colonne 3 et la description du fichier colonne 4.
Merci de votre aide.

 

[michel]

bonsoir Gaetan

as tu testé la macro dans mon precedent message ?


bonne soiree
MichelXld

 

[Gaetan]

oui mais il me dit qu'il y a une erreur de compilation.
Je ne connait pas grand chose en VBA. Peut être que je n'ai pas mit le code au bon endroit.

 

[michel]

rebonsoir

as tu activé la reference "Microsoft Shell Controls and Automation"

dans l'editeur de macros (Alt+F11)
Menu Outils
References
coches la ligne "Microsoft Shell Controls and Automation"
cliques sur OK pour valider


bonne soiree
MichelXld

 

[Gaetan]

Non, il n'était pas activé.
Par contre maintenant il ne m'affiche plus d'erreur mais rien ne se passe.

 

[Gaetan]

C'est bon ça marche. Merci beaucoup.
Maintenant il faut que je rajoute un bouton de mise a jour.