1. Accueil
  2. Forum Codes-Sources
  3. Visual Basic
  4. VB.NET

Impression fichier word depuis excel lien hypertext

Signaler
-
 bebert51 -
Bonjour,

Le but de ma macro excel est d'ouvrir tout les liens hypertext présent sur la feuille les uns après les autres pour les imprimer.
Mon code fonctionne pour les document excel mais pas pour les word.
L'adresse du lien hypertext que j'utilise est pas complet (il me semble) ..\..\..\la fin du chemin.
Je n'arrive pas à récupérer la totalité du chemin.
Or quand je clic directement sur le lien j'arrive à ouvrir le document sans problème.

Sub ImprimerLiens()
'necessite d'activer la reference Microsoft Word xx.x Object Library
Dim WordApp As Word.Application
Dim WordDoc As Word.Document
Dim Lien As Hyperlink
Dim leNom As String

Application.ScreenUpdating = False

'boucle sur les liens de la feuille active
For Each Lien In ActiveSheet.Hyperlinks
leNom = Range(Lien.Range.Address).Hyperlinks(1).Address
'verifie si le lien est un document Word
If Right(leNom, 4) = ".doc" Then

Set WordApp = CreateObject("word.application") 'ouvre session word
'wordApp.Visible = False
Set WordDoc = WordApp.Documents.Open(leNom) 'ouverture document Word
WordDoc.PrintOut 'impression
WordDoc.Close 'fermeture document
WordApp.Quit ' fermeture session word
Else
'document Excel
Application.ScreenUpdating = False
If Right(Range(Lien.Range.Address).Hyperlinks(1).Address, 4) = ".xls" Then
Range(Lien.Range.Address).Hyperlinks(1).Follow NewWindow:=False
For I = 1 To ActiveWorkbook.Sheets.Count
'ActiveWorkbook.Sheets(I).PrintOut
Next I
ActiveWorkbook.Close
End If
Application.ScreenUpdating = True
End If
Next
End Sub

Si quelqu'un peut m'aider c'est super !!

Merci d'avance.

6 réponses

Réponse 1 / 6
Messages postés
7288
Date d'inscription
jeudi 13 septembre 2007
Statut
Contributeur
Dernière intervention
5 mars 2021
 120
Bonjour,
Ton code est bon. Le problème provient de l'adresse du lien qui ne démarre pas au début. Pour corriger cela. Je suis sous Office 2003:
Clic droit sur le lien,
Modifier le lien,
Allez en bas dans Adresse,
Ouvrir et sélectionnez l'adresse complète.
Bon courage si tu en as beaucoup!!!!!!!!!!

@+Le Pivert
Réponse 2 / 6
Messages postés
7288
Date d'inscription
jeudi 13 septembre 2007
Statut
Contributeur
Dernière intervention
5 mars 2021
 120
Erreur sur la manière de procéder. Cela donne l'adresse de ton classeur. Il faut trouver un moyen pour reconstituer l'adresse complète de tous tes documents!!!!!
Bon courage
Réponse 3 / 6
Messages postés
7288
Date d'inscription
jeudi 13 septembre 2007
Statut
Contributeur
Dernière intervention
5 mars 2021
 120
Il y a une solution par code. Mais il faut que tous tes documents soient dans le même dossier.
Tout d'abord fait un essai avec ceci pour voir: 

Sub verifier()
'necessite d'activer la reference Microsoft Word xx.x Object Library
Dim WordApp As Word.Application
Dim WordDoc As Word.Document
Dim Lien As Hyperlink
Dim leNom As String
Settings\Propriétaire\Mes documents\VBA Excel"
Application.ScreenUpdating = False

'boucle sur les liens de la feuille active
For Each Lien In ActiveSheet.Hyperlinks
leNom = Range(Lien.Range.Address).Hyperlinks(1).Address
'verifie si le lien est un document Word
If Right(leNom, 4) = ".doc" Then

MsgBox leNom
End If
Next
End Sub


Maintenant tu ajoutes ceci pour mettre le chemin: 

Sub verifier()
'necessite d'activer la reference Microsoft Word xx.x Object Library
Dim WordApp As Word.Application
Dim WordDoc As Word.Document
Dim Lien As Hyperlink
Dim leNom As String
Dim chemin As String
chemin = "C:\chemin du dossier Word"
Application.ScreenUpdating = False

'boucle sur les liens de la feuille active
For Each Lien In ActiveSheet.Hyperlinks
leNom = Range(Lien.Range.Address).Hyperlinks(1).Address
'verifie si le lien est un document Word
If Right(leNom, 4) = ".doc" Then

Set WordApp = CreateObject("word.application") 'ouvre session word
'wordApp.Visible = False
Set WordDoc = WordApp.Documents.Open(chemin & leNom) 'ouverture document Word
End Sub


@+Le Pivert
Réponse 4 / 6
Messages postés
1835
Date d'inscription
vendredi 13 mai 2005
Statut
Membre
Dernière intervention
20 novembre 2013
 9
Salut,

une méthode que j'utilise déjà pour la même raison que toi : 

Sub demo()
    Dim Chemin As String, Macellule As Range
    set Macellule = Range("A1")
    If Range("B68").Hyperlinks.count > 0 Then
        Chemin = PathFromHyperLink(Macellule.Hyperlinks(1).Address, True)
    End If
    If Not Chemin = vbNullString Then
        MsgBox Chemin
    End If
End Sub
Function PathFromHyperLink(ByVal AdresseLien As String, Optional ByVal UNCPath As Boolean = False) As String
    Dim objet_fso As Object
    PathFromHyperLink = vbNullString
    If Not Dir(AdresseLien) = vbNullString Then
        Set objet_fso = CreateObject("Scripting.FileSystemObject")
        PathFromHyperLink = objet_fso.GetAbsolutePathName(AdresseLien)
        If UNCPath True Then PathFromHyperLink GetUNCPath(Replace$(PathFromHyperLink, Dir(PathFromHyperLink), ""))
        Set objet_fso = Nothing
    End If
End Function
Function GetUNCPath(ByVal MyPath As String) As String ' recuperation du Chemin UNC d'un lecteur reseau
    Dim Drive_fso As Object, fso As Object
    
    If MyPath = vbNullString Then Exit Function
    Set fso = CreateObject("Scripting.FileSystemObject")
    On Error Resume Next
    Set Drive_fso = fso.GetDrive(fso.GetDriveName(MyPath))
    If Not Err = 0 Then
        GetUNCPath = vbNullString
    ElseIf Not Drive_fso.ShareName vbNullString And Not LCase$(fso.GetFile(MyPath).Path) LCase$(MyPath) Then
        GetUNCPath = Drive_fso.ShareName & Right$(MyPath, Len(MyPath) - 2)
    Else
        GetUNCPath = MyPath
    End If
    On Error GoTo 0
    Set Drive_fso = Nothing
    Set fso = Nothing
End Function


D'ailleur je vais publier un snippet pour le mettre à dispo.

A+
Réponse 5 / 6
Messages postés
1835
Date d'inscription
vendredi 13 mai 2005
Statut
Membre
Dernière intervention
20 novembre 2013
 9
oups !

une erreure dans la demo

Voici la version corrigée: 
Sub demo()
    Dim Chemin As String, Macellule As Range
    set Macellule = Range("A1")
    If Macellule.Hyperlinks.count > 0 Then
        Chemin = PathFromHyperLink(Macellule.Hyperlinks(1).Address, True)
    End If
    If Not Chemin = vbNullString Then
        MsgBox Chemin
    End If
End Sub


A+
Réponse 6 / 6

MERCI BCP BCP !!!!!!
Répondre Posez votre question