Ouvrir 1 PDF, depuis un bouton du USF, lié à un lien hypertexte d'1 cellule
Bonjour,
Je souhaite pouvoir faire la chose suivante depuis le UserForm, après avoir sélectionné le BC xxx dont j’ai besoin via la CommandBox1
Pour l'exemple nous prendrons le BC 606
--> En cliquant sur le CommandButton8 ("ouvrir pdf"), cela ouvre le pdf du BC 606 pour lequel j’ai déjà le lien hypertexte (qui fonctionne) dans la colonne GZ.
En l’occurrence, pour le BC 603, cela viendra activer le lien hypertexte qui est présent en GZ 36 qui ouvrira le PDF associé.
J’espère avoir été assez clair dans mes explications.
Je vous remercie par avance pour votre précieuse aide !
Bonjour
Voici un code pour ouvrir n'importe quel fichier (.pdf, .xls, etc.). Maintenant à toi de l'ajuster en fonction de tes besoins
Sub OuvrirLien()
Dim Cible As String
Dim MonApplication As Object
Dim MonFichier As String
Dim FichierExiste As Boolean
Set MonApplication = CreateObject("Shell.Application")
Err.Number = 0
On Error Resume Next
Cible = ThisWorkbook.Worksheets("Sheet").Range("A1") 'à ajuster (là où se trouve le lien)
If Err.Number <> 0 Then
MsgBox "Impossible de définir la cible." & Chr(10) & _
"N° d'erreur : " & Err.Number & Chr(10) & _
"Message d'erreur : " & Err.Description, vbCritical
Exit Sub
End If
If Cible <> "" And Len(Dir(Cible)) > 0 Then
FichierExiste = True
Else
FichierExiste = False
End If
If FichierExiste = False Then MsgBox "Le fichier n'existe pas, il a peut-être été supprimé ou déplacé.", vbExclamation: Exit Sub
MonApplication.Open (Cible)
Set MonApplication = Nothing
End SubBonjour et merci pour la réponse
"La cible" qui doit viser là où se trouve le lien hypertexte change en permanence... les liens hypertextes se situent entre GZ10 et GZXXX - Les cibles changent en fonction du BC que je sélectionne avec la ComboBox.
Si je sélectionne le BC 603, le code doit être lié au bouton "CommandButton8" (ouvrir PDF) afin que lorsque je clique sur le bouton, le PDF s'ouvre.
Si je sélectionne le BC 598, le code doit être lié au bouton "CommandButton8" (ouvrir PDF) afin que lorsque je clique sur le bouton, le PDF s'ouvre.
etc etc etc
Je suis BAC -2 en VBA donc j'aurais besoin de plus d'aide pour relier (le code avec la combobox1 et le commandbutton8)
Merci !!!
J'ai inséré le code comme ça :
Private Sub CommandButton8_Click()
Dim Cible As String
Dim MonApplication As Object
Dim MonFichier As String
Dim FichierExiste As Boolean
Set MonApplication = CreateObject("Shell.Application")
Err.Number = 0
On Error Resume Next
Cible = ThisWorkbook.Worksheets("BC").Range("HC10:HC800") 'à ajuster (là où se trouve le lien)
If Err.Number <> 0 Then
MsgBox "Impossible de définir la cible." & Chr(10) & _
"N° d'erreur : " & Err.Number & Chr(10) & _
"Message d'erreur : " & Err.Description, vbCritical
Exit Sub
End If
If Cible <> "" And Len(Dir(Cible)) > 0 Then
FichierExiste = True
Else
FichierExiste = False
End If
If FichierExiste = False Then MsgBox "Le fichier n'existe pas, il a peut-être été supprimé ou déplacé.", vbExclamation: Exit Sub
MonApplication.Open (Cible)
Set MonApplication = Nothing
End SubMaintenant, je ne sais pas comment attribuer le BC choisi par la combobox1 à la cible correspondante.
Heeuuuu où se trouve le CommandButton8 ? Et de quel ComboBox parles-tu ?
Dans le fichier Excel que j'ai joint "suivi-actes-pour-partage.xlsm" (Lors de mon premier message)
Je le joins à nouveau.
Le CommandButton8 et la Combobox1 sont dans le UserFom1 du fichier.
Bon, ton fichier est inutilisable chez moi, il ne fait que cracher, impossible d'éditer du code et encore moins faire des tests.... Bref, de ce que j'ai pu apercevoir je te propose cette modif faite à tâtons, dit moi ce que tu en penses.
Private Sub CommandButton8_Click()
Dim Cible As String
Dim MonApplication As Object
Dim FichierExiste As Boolean
Dim Ligne As Long
If Me.ComboBox1.ListIndex = -1 Or Me.ComboBox1.ListIndex = "" Then Exit Sub
Set MonApplication = CreateObject("Shell.Application")
Err.Number = 0
On Error Resume Next
Ligne = Me.ComboBox1.ListIndex + 1
Cible = ThisWorkbook.Worksheets("BC").Range("HC" & Ligne).Hyperlinks(1).Address 'à ajuster (là où se trouve le lien)
If Err.Number <> 0 Then
MsgBox "Impossible de définir la cible." & Chr(10) & _
"N° d'erreur : " & Err.Number & Chr(10) & _
"Message d'erreur : " & Err.Description, vbCritical
Exit Sub
End If
If Len(Dir(Cible)) > 0 Then
FichierExiste = True
Else
FichierExiste = False
End If
If FichierExiste = False Then MsgBox "Le fichier n'existe pas, il a peut-être été supprimé ou déplacé.", vbExclamation: Exit Sub
MonApplication.Open (Cible)
Set MonApplication = Nothing
End SubJe ne comprends pas pourquoi il ne s'ouvre pas chez toi car ici il s'ouvre très bien.
Du coup je t'ai fait des "copies écran" de certains éléments qui pourront, je l'espère, t'aider.
Avec ton nouveau code, j'ai le message d'erreur suivant qui s'affiche lorsque je clique sur "ouvrir pdf"
Il ne doit donc pas trouver la cible avec l'actuel code.
Ci après l'userform :
ci-après la feuille de calcul "BC" :
Comme tu peux le constater, dans chaque cellule de HC il y a une "formule hypertexte". Elle est fonctionnelle (quand je clique sur un des numéros, le BC en PDF s'ouvre bien). L'idée d'avoir un CommandButton dans le Userform me permet donc d'ouvrir le PDF sans aller en "HC" qui est très loin dans le tableau.
CODE complet du USERFORM1 :
Option Explicit
Dim Ws As Worksheet
Private Sub Frame1_Click()
End Sub
Private Sub CommandButton4_Click() 'RAZ'
TextBox1.Value = ""
TextBox2.Value = ""
TextBox3.Value = ""
TextBox4.Value = ""
TextBox5.Value = ""
TextBox6.Value = ""
TextBox7.Value = ""
TextBox8.Value = ""
TextBox9.Value = ""
TextBox10.Value = ""
TextBox11.Value = ""
TextBox12.Value = ""
TextBox13.Value = ""
TextBox14.Value = ""
TextBox15.Value = ""
TextBox16.Value = ""
TextBox17.Value = ""
TextBox18.Value = ""
TextBox20.Value = ""
UserForm1.ComboBox1.SetFocus
Dim Ctl As Control
For Each Ctl In Me.Controls
If Ctl.Tag = "LblZoneA" Then
Ctl = ""
End If
Next Ctl
End Sub
'Ouvrir le PDF'
Private Sub CommandButton8_Click()
Dim Cible As String
Dim MonApplication As Object
Dim FichierExiste As Boolean
Dim Ligne As Long
If Me.ComboBox1.ListIndex = -1 Or Me.ComboBox1.ListIndex = "" Then Exit Sub
Set MonApplication = CreateObject("Shell.Application")
Err.Number = 0
On Error Resume Next
Ligne = Me.ComboBox1.ListIndex + 1
Cible = ThisWorkbook.Worksheets("BC").Range("HC" & Ligne).Hyperlinks(1).Address 'à ajuster (là où se trouve le lien)
If Err.Number <> 0 Then
MsgBox "Impossible de définir la cible." & Chr(10) & _
"N° d'erreur : " & Err.Number & Chr(10) & _
"Message d'erreur : " & Err.Description, vbCritical
Exit Sub
End If
If Len(Dir(Cible)) > 0 Then
FichierExiste = True
Else
FichierExiste = False
End If
If FichierExiste = False Then MsgBox "Le fichier n'existe pas, il a peut-être été supprimé ou déplacé.", vbExclamation: Exit Sub
MonApplication.Open (Cible)
Set MonApplication = Nothing
End Sub
Private Sub CommandButton5_Click() 'Ajouter un nouveau BC'
Dim DerLig As Long, T As Variant
With Worksheets("BC")
DerLig = .Range("ED65000").End(xlUp).Row + 1
T = Application.Substitute(Me.TextBox20, ".", ",")
If IsNumeric(T) Then
.Range("ED" & DerLig) = CDbl(T)
Else
MsgBox "Vérifier le contenu du textbox."
End If
End With
Dim Lig As Long
Set Ws = Sheets("BC")
Lig = Ws.Range("ED" & Rows.Count).End(xlUp).Row + 1
With ComboBox1
.List = Ws.Range("ED10:ED" & Ws.Range("ED" & Rows.Count).End(xlUp).Row).Value
End With
TextBox20.Value = ""
Call UserForm_Activate
End Sub
Private Sub CommandButton6_Click() 'effacer le dernier bon de commande'
Range("ED" & Cells(Rows.Count, "ED").End(xlUp).Row).ClearContents
Dim Lig As Long
Set Ws = Sheets("BC")
Lig = Ws.Range("ED" & Rows.Count).End(xlUp).Row + 1
Ws.Cells(Lig, 1).Value = TextBox20.Value
With ComboBox1
.Clear
.List = Ws.Range("ED10:ED" & Ws.Range("ED" & Rows.Count).End(xlUp).Row).Value
End With
TextBox20.Value = ""
Call UserForm_Activate
End Sub
Private Sub UserForm_Activate() 'Affiche le dernier BC'
Label71 = Range("ED65000").End(xlUp).Rows
End Sub
'Pour le formulaire
Private Sub UserForm_Initialize()
Application.ScreenUpdating = False
Dim J As Long
Dim I As Integer
Set Ws = Sheets("BC") 'Correspond au nom de l'onglet dans le fichier Excel
With Me.ComboBox1
For J = 1 To Ws.Range("ED" & Rows.Count).End(xlUp).Row
.AddItem Ws.Range("ED" & J)
Next J
End With
For I = 1 To 18
Me.Controls("TextBox" & I).Visible = True
Next I
Application.ScreenUpdating = True
End Sub
'Pour la liste déroulante BC'
Private Sub ComboBox1_Change()
Application.ScreenUpdating = False
Dim Ligne As Long
Dim I As Integer
If Me.ComboBox1.ListIndex = -1 Then Exit Sub
Ligne = Me.ComboBox1.ListIndex + 1
With Sheets("BC")
For I = 1 To 18
Me.Controls("TextBox" & I) = .Cells(Ligne, I + 115)
Next I
Me.Label46 = CStr(Application.Index(.Range("EE10:EE2000"), Application.Match(Me.ComboBox1.Value * 1, .Range("ED10:ED2000"), 0)))
Me.Label47 = CStr(Application.Index(.Range("EF10:EF2000"), Application.Match(Me.ComboBox1.Value * 1, .Range("ED10:ED2000"), 0)))
Me.Label52 = CStr(Application.Index(.Range("AA10:AA2000"), Application.Match(Me.ComboBox1.Value * 1, .Range("ED10:ED2000"), 0)))
Me.Label54 = CStr(Application.Index(.Range("I10:I2000"), Application.Match(Me.ComboBox1.Value * 1, .Range("ED10:ED2000"), 0)))
Me.Label56 = CStr(Application.Index(.Range("EG10:EG2000"), Application.Match(Me.ComboBox1.Value * 1, .Range("ED10:ED2000"), 0)))
Me.Label59 = CStr(Application.Index(.Range("C10:C2000"), Application.Match(Me.ComboBox1.Value * 1, .Range("ED10:ED2000"), 0)))
Me.Label61 = CStr(Application.Index(.Range("L10:L2000"), Application.Match(Me.ComboBox1.Value * 1, .Range("ED10:ED2000"), 0)))
Me.Label62 = CStr(Application.Index(.Range("BM10:BM2000"), Application.Match(Me.ComboBox1.Value * 1, .Range("ED10:ED2000"), 0)))
End With
Application.ScreenUpdating = True
End Sub
'Pour le suivi des visas'
Private Sub CommandButton1_Click()
Application.ScreenUpdating = False
Dim L As Integer
Range("ED" & L).Value = ComboBox1
Range("DL" & L).Value = TextBox1
Range("DM" & L).Value = TextBox2
Range("DN" & L).Value = TextBox3
Range("DO" & L).Value = TextBox4
Range("DP" & L).Value = TextBox5
Range("DQ" & L).Value = TextBox6
Range("DR" & L).Value = TextBox7
Range("DS" & L).Value = TextBox8
Range("DT" & L).Value = TextBox9
Range("DU" & L).Value = TextBox10
Range("DV" & L).Value = TextBox11
Range("DW" & L).Value = TextBox12
Range("DX" & L).Value = TextBox13
Range("DZ" & L).Value = TextBox14
Range("DZ" & L).Value = TextBox15
Range("EA" & L).Value = TextBox16
Range("EB" & L).Value = TextBox17
Range("EC" & L).Value = TextBox18
End If
Application.ScreenUpdating = True
End Sub
'Pour le bouton Modifier
Private Sub CommandButton2_Click()
Application.ScreenUpdating = False
Dim Ligne As Long
Dim I As Integer
If MsgBox("Confirmez-vous les modifications apportées ?", vbYesNo, "Demande de confirmation de modification") = vbYes Then
If Me.ComboBox1.ListIndex = -1 Then Exit Sub
Ligne = Me.ComboBox1.ListIndex + 1
ActiveSheet.Unprotect
For I = 1 To 18
If Me.Controls("TextBox" & I).Visible = True Then
Ws.Cells(Ligne, I + 115) = Me.Controls("TextBox" & I)
End If
Next I
End If
ActiveSheet.Protect
Application.ScreenUpdating = True
Call ComboBox1_Change
End Sub
'Pour le bouton Quitter
Private Sub CommandButton3_Click()
Unload Me
End SubRe, bon toujours une galère chez moi, j'ai vu que les liens hypertextes étaient générés via une formule et que c'est pour ça que ça plante. Je te propose de remplacer la ligne :
Cible = ThisWorkbook.Worksheets("BC").Range("HC" & Ligne).Hyperlinks(1).Address 'à ajuster (là où se trouve le lien)
par la ligne :
Cible = "S:\ERO_PS\Commun\2. PR_BCR\Contrat\2-BC\BC Notifiés\" & "BC" & Me.ComboBox1 & ".pdf"
ce qui donne :
Private Sub CommandButton8_Click()
Dim Cible As String
Dim MonApplication As Object
Dim FichierExiste As Boolean
Dim Ligne As Long
If Me.ComboBox1.ListIndex = -1 Or Me.ComboBox1 = "" Then Exit Sub
Set MonApplication = CreateObject("Shell.Application")
Err.Number = 0
On Error Resume Next
Ligne = Me.ComboBox1.ListIndex + 1
Cible = "S:\ERO_PS\Commun\2. PR_BCR\Contrat\2-BC\BC Notifiés\" & "BC" & Me.ComboBox1 & ".pdf"
If Err.Number <> 0 Then
MsgBox "Impossible de définir la cible." & Chr(10) & _
"N° d'erreur : " & Err.Number & Chr(10) & _
"Message d'erreur : " & Err.Description, vbCritical
Exit Sub
End If
If Len(Dir(Cible)) > 0 Then
FichierExiste = True
Else
FichierExiste = False
End If
If FichierExiste = False Then MsgBox "Le fichier n'existe pas, il a peut-être été supprimé ou déplacé.", vbExclamation: Exit Sub
MonApplication.Open (Cible)
Set MonApplication = Nothing
End SubBonjour!
Super, t'es au top! Cela fonctionne impeccable ! J'ai juste du rajouter un espace dans le code après "BC" --> "BC " car le nom du fichier est "BC xxx"
Merci infiniment !!!
Parfait si c'est ok pour toi, bonne journée et bon weekend
Bon weekend également à toi !
Une dernière petite question, si je souhaite adapter ce code (toujours la même chose : Sélection BC puis ouverture par bouton) pour ouvrir le dossier dans lesquels se trouve les BC.
Par exemple, en colonne HD, j'ai "copier-coller" tous les numéros de BC sur lesquels j'ai attribué un lien hypertexte avec le chemin du répertoire des BC 601 à 650 (pour les BC allant de 601 à 650 , etc) : S:\ERO_PS\Commun\2. PR_BCR\Contrat\2-BC\BC 601à650
J'ai essayé avec ton premier code mais cela ne fonctionne pas (message d'erreur)
Bonjour,
Je viens rajouter une autre question
J'ai une autre feuille sur laquelle je voudrais mettre le même code mais pour ouvrir des fichiers zip ayant tous un nom avec une base commune et un nom different
ex: DR403 BC155 / DR506 BC227
La base est donc "DRxxx" il faudrait donc que la recherche et activation du lien ne se fasse qu'avec cette base commune.
Est ce possible ?
Sinon, est ce possible de faire un code qui active (au click du commandbutton) le lien hypertexte en place dans la cellule, quel que soit le nom des dossiers? (Au même titre que je fichier s'ouvre lorsque je clique directement dessus avec la souris)
Encore merci d'avance :)
Re, reprenons ici. Concernant l'ouverture du dossier, il se fait avec quel bouton ? Le N° du BC est toujours issu du ComboBox ?
Bonjour GGautier,
Oui, l'ouverture du dossier se fait toujours avec un CommandButton (n°10) avec le n° de BC toujours issu de la même Combobox (n°1)
La particularité:
Pour les BC 001 à 050 --> En sélectionnant n'importe lequel de ces BC, le dossier avec le lien "=LIEN_HYPERTEXTE("S:\ERO_PS\Commun\2. PR_BCR\Contrat\2-BC\BC 1à50")" doit s'ouvrir (ce lien est "copier coller" en colonne HD au même niveau que les BC allant de 1 à 50 (donc de HD1 à HD64)
--> Il s'agit du dossier contenant les BC 1 à 50
Pour les BC 051 à 100 --> En sélectionnant n'importe lequel de ces BC, le dossier avec le lien "=LIEN_HYPERTEXTE("S:\ERO_PS\Commun\2. PR_BCR\Contrat\2-BC\BC 051à100")" doit s'ouvrir (ce lien est "copier coller" en colonne HD au même niveau que les BC allant de 51 à 100 (donc de HD65 à HD118)
--> Il s'agit du dossier contenant les BC 51 à 100
etc etc etc jusqu'à 1500
Les liens hypertextes formules sont fonctionnels dès qu'on les active en cliquant dessus.
Ci-joint le fichier et encore merci pour ton aide !
Quel est le nom exacte des dossiers à ouvrir ? Est-ce que c'est "BC 1 à 50" ? (ou 1 et 50 varies mais je veux surtout savoir pour les escapes, majuscules et accents)
Voilà, à toi de tester :
Private Sub CommandButton10_Click()
Dim Cible As String, NomDossier As String
Dim MonApplication As Object
Dim FichierExiste As Boolean
Dim TailleDossier As Integer
Dim LimiteInf As Long, LimiteSup As Long, i As Long, Ligne As Long
If Me.ComboBox1.ListIndex = -1 Or Me.ComboBox1 = "" Then Exit Sub
Set MonApplication = CreateObject("Shell.Application")
Ligne = Me.ComboBox1.ListIndex + 1
TailleDossier = 50
For i = 1 To 1500 Step TailleDossier
LimiteInf = i
LimiteSup = i + TailleDossier - 1
If Ligne >= LimiteInf And Ligne <= LimiteSup Then NomDossier = "BC " & LimiteInf & "à" & LimiteSup: Exit For
Next i
Cible = "S:\ERO_PS\Commun\2. PR_BCR\Contrat\2-BC\" & NomDossier
If Len(Dir(Cible)) > 0 Then FichierExiste = True Else FichierExiste = False
If FichierExiste = False Then MsgBox "Le dossier n'existe pas, il a peut-être été supprimé ou déplacé.", vbExclamation: Exit Sub
Shell Environ("WINDIR") & "\explorer.exe " & Cible, vbNormalFocus
Set MonApplication = Nothing
End SubMerci, je vais essayer le code.
Pour le nom des dossiers, c'est exactement comme suit :
BC 1à50 / BC 51à100 / BC 101à150 / BC 151à200 etc
Le seul espace est entre BC et le numéro
Après insersion du code, j'ai le message d'erreur : Le dossier n'existe pas, il a peut-être été supprimé ou déplacé.
Pourtant la syntaxe que tu as faites me parait correcte :
If Ligne >= LimiteInf And Ligne <= LimiteSup Then NomDossier = "BC " & LimiteInf & "à" & LimiteSupJ'ai essayé en supprimant l'espace après BC, mais cela ne donne rien.
Je n'ai pas précisé, mais les dossiers se trouvent sur un serveur. Peut-être que la commande "Shell Environ("WINDIR") & "\explorer.exe" & Cible, vbNormalFocus" n'est pas adaptée ?