adapter une macro Fermé

Question

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

dps89 · Answer

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

Adapter une macro

1 réponse

Discussions similaires