Adapter une macro

desoler petite erruer de copie de macro

voila celle que j'ai deja quelque peu adapter

Private Sub CommandButton1_Click()
'sub envoi_mail_automatique()
'

'
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 = ""
EMailSubject = "Heures journalières service production"
'
' 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
' Pour avoir un accusé de réception
oDoc.ReturnReceipt = "1"
'
' 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
Comment envoyer juste la feuille active du dossier excel
' Ca peut être 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 "signature"

' 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

Private Sub CommandButton2_Click()
Unload Me
End Sub