Adapter une macro

Bonjour,

je souhaiterai avec votre aide pour adapter cette macro (qui fonctionne parfaitement en l'état ) mais pour envoyer la feuille active d'un fichier excel ouvert (mes connaissances sont encore trop limite pour m'en sortir)

merci d'avance pour votre aide et au créateur de cette macro.

Didier

Sub Macro1()
'

'
Dim oSess As Object
Dim oDB As Object
Dim oDoc As Object
Dim oItem As Object
' Variable TEXTE
Dim ntsServer As String
Dim ntsMailFile As String
'
Dim EMailSendTo As String
Dim EMailCopyTo As String
Dim EMailSubject As String
Dim MailPJ As String
Dim LotusSRV As String
'Dim WbkName As String
Dim feuille_active As String
'
On Error GoTo err_SendNotesMsg
' Initialisation des variables
EMailSendTo = "adresse mail"
EMailCopyTo = "adresse mail copy"
EMailSubject = "titre du sulet"
'
' Créer une nouvelles session Notes
Set oSess = CreateObject("Notes.NotesSession")
'
'Récupérer le nom du serveur
ntsServer = oSess.GetEnvironmentString("serveur de votre lotus", True)
'Acquière le nom du fichier mailfile de l'utilisateur courant dans Notes.ini
ntsMailFile = oSess.GetEnvironmentString("MailFile", True) 'remplacé MailFile
Set oDB = oSess.GetDatabase(ntsServer, ntsMailFile)
Set oDoc = oDB.CreateDocument
' Définit les éléments à rajouter au message
Set oItem = oDoc.createRichTextItem("BODY")
'
oDoc.Form = "Memo"
' Préparer les destinataires
oDoc.Sendto = EMailSendTo
If Not IsMissing(EMailCopyTo) Then
oDoc.Copyto = EMailCopyTo
End If
'
' Préparer le sujet du message
If Not IsMissing(EMailSubject) Then
If EMailSubject <> "" Then oDoc.Subject = EMailSubject
End If
oDoc.FROM = oSess.CommonUserName
oDoc.PostedDate = Date
' Préparer les texte
'
With oItem
.appendtext "Bonjour,"
.addnewline 2
.appendtext "Ci-joint le fichier des herues pour la semaine 11."
.addnewline 2
.appendtext "Cet e-mail a été généré par un processus automatique."
.addnewline 2
'
End With
' Créer la pièce jointe
' le classeur
WbkName = ThisWorkbook.FullName
'Attachement du classeur au mail
Call oItem.embedObject(1454, "", WbkName, "")
' Message de salutation
oItem.addnewline 1
oItem.appendtext "Cordialement"
oItem.addnewline 2
oItem.appendtext "mon nom"

' Envoyer le message
oDoc.send False
'
MsgBox "Le message a été envoyé", vbInformation, "MESSAGE LOTUS ..."
'
exit_SendNotesMsg:
On Error Resume Next
Set oSess = Nothing
Set oDB = Nothing
Set oDoc = Nothing
Set oItem = Nothing
Exit Sub
'
err_SendNotesMsg:
If Err.Number = 7225 Then
MsgBox "Impossible d'attacher le fichier, vérifier le chemin!", vbCritical
Else
MsgBox "[" & Err.Number & "]: " & Err.Description
End If
'
MsgBox "Message non envoyé suite erreur!", vbCritical
Resume exit_SendNotesMsg

'
End Sub