Pb ouverture fichier pdf a partir d'une liste d'excl

aquariumania

Nouveau membre
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.
 

galopin01

Habitué
bonsoir,
tu nous donnerais pas un petit aperçu de ta macro modifiée des fois ?

A+
 

aquariumania

Nouveau membre
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


 

KangOl

Grand Maître
et les balises
Code:
 [img]http://forum.hardware.fr/images/perso/j%20l%20b.gif[/img]
 
Vous devez vous inscrire ou vous connecter pour répondre ici.
Derniers messages publiés
Statistiques globales
Discussions
730 098
Messages
6 717 082
Membres
1 586 286
Dernier membre
petitangebleu1977
Partager cette page
Haut