Envoyer document Word par Excel

Bonjour,

J'aimerai avec une macro excel envoyer par mail un document Word qui serai au préalable ouvert.

Voici mon code :

Private Sub Workbook_SheetFollowHyperlink(ByVal Sh As Object, ByVal Target As Hyperlink)

Dim WdApp As Object

Set WdApp = CreateObject("Word.application")

WdApp.ActiveDocument.SendMail

End Sub

Mais j'ai l'erreur qui me dis que aucun document n'est ouvert. Comment faire pour que il trouve le document Word en cours et l'envoi?

Pour que ça fonctionne bien, il faudrait je crois que tu ouvres le document word depuis ton code avec la même variable application. Dans ton code tu ouvre un nouveau processus Word qui n'a aucun lien avec ton document déjà ouvert. Voici un exemple

Private Sub CommandButton1_Click()
    'Si tu travail avec word, c'est plus simple d'activer la référence à
    'Microsoft Word x.x Object Library
    Dim wrdApp As New Word.Application
    Dim wrdDoc As Word.Document

    wrdApp.Visible = True
    Set wrdDoc = wrdApp.Documents.Open("C:\Test.doc")

    wrdDoc.SendMail
End Sub

D'accord c'est donc bien ce que j'ai cru comprendre, mon problème c'est que j'ouvre bien Word à partir d'excel mais avec des liens hypertextes... voila mon code :

Public Sub Repli_appssu_Click()  'Repli Collaborateurs > APP-SSU  C1
Dim Chemin As String
Dim myShell As Shell
Dim myFolder As Folder
Dim myFile As FolderItem
Dim I As Byte, F As String, lig As Long
Dim Ligne As Long

Sheets("Résultat").Unprotect ""
Chemin = Sheets("Feuil1").Range("C1").Value  'le chemin du répertoire

On Error Resume Next
Set myShell = CreateObject("Shell.Application")
Set myFolder = myShell.NameSpace(Chemin)
Set myFile = myFolder.Items.Item(F)
Application.ScreenUpdating = False

LigneP = "blabla"
Ligne = Sheets("Résultat").Cells.Find(What:=LigneP).Row
Ligne = Ligne + 2

F = Dir(Chemin & "\*.doc") 'Do While Len(F) > 0  'Fait autant de fois qu'il y a de F
Set myFile = myFolder.Items.Item(F)

If myFolder.GetDetailsOf(myFile, I) <> "" Then

Range("A1").Offset(Ligne - 1, 0).Select
ActiveSheet.Hyperlinks.Add Anchor:=Selection, Address:= _
Chemin & "\" & myFolder.GetDetailsOf(myFile, 0) _
, TextToDisplay:=myFolder.GetDetailsOf(myFile, 0) 'nom et lien
Selection.Font.Bold = True
Sheets("Résultat").Cells(Ligne, 5) = myFolder.GetDetailsOf(myFile, 3) 'date de modif
Sheets("Résultat").Cells(Ligne, 4) = myFolder.GetDetailsOf(myFile, 31) 'date de création
Sheets("Résultat").Cells(Ligne, 2) = myFolder.GetDetailsOf(myFile, 9) 'Auteur
Sheets("Résultat").Cells(Ligne, 3) = myFolder.GetDetailsOf(myFile, 11) ' objet
Sheets("Résultat").Cells(Ligne, 7) = myFolder.GetDetailsOf(myFile, 12) ' proprio
Sheets("Résultat").Cells(Ligne, 6) = myFolder.GetDetailsOf(myFile, 8) 'lastsaveby

Ligne = Ligne + 1
End If

F = Dir
Loop
Set myShell = Nothing
Set myFolder = Nothing
Set myFile = Nothing
End Sub

Il y a moyen d'adapter?