Envoi différent onglet à différent destinataire 1 par 1

Le 10/01/2020 à 10:52

Bonjour,

Je souhaiterais si possible de l'aide pour l'envoi de mes onglets au adresse en cellule e1

Mais mon problème comment faire pour que cela fonctionne onglet par onglet car pour le moment cela s'envoi tout en même temps car même cellule.

Je vous remercie

16mail-transporteur.xlsm (45.07 Ko)
Le 11/01/2020 à 13:07

Salut CamS,

comme ca peut être

Sub colis()
    Dim wb As Workbook
    Dim TempFilePath As String
    Dim iMsg As Object

If MsgBox("Etes-vous certain de vouloir envoyer le fichier ORDRE DE TRANSPORT LP ?", vbYesNo, "Demande de confirmation") = vbYes Then

    TempFilePath = Environ$("temp") & "\"

    With Application
        .ScreenUpdating = False
        .EnableEvents = False
    End With

    Set wb = ActiveWorkbook
    If wb.Range("E1").Value Like "?*@?*.?*" Then
       Application.CutCopyMode = False
       wb.ExportAsFixedFormat Type:=xlTypePDF, Filename:=TempFilePath & wb.Name & ".pdf"

       Set iMsg = CreateObject("CDO.Message")
        With iMsg
          .Configuration.Fields.Item("http://schemas.microsoft.com/cdo/configuration/sendusing") = 2
          .Configuration.Fields.Item("http://schemas.microsoft.com/cdo/configuration/smtpserver") = "172.16.1.47"
          .Configuration.Fields.Item("http://schemas.microsoft.com/cdo/configuration/smtpserverport") = 25
          .Configuration.Fields.Update
            .To = sh.Range("e1").Value
            .Subject = "ORDRE TRANSPORT "
            .AddAttachment TempFilePath & wb.Name & ".pdf"
            .TextBody = "Bonjour,ci joint le fichier ORDRE DE TRANSPORT"
            .Send
        End With
       Set iMsg = Nothing

       Kill TempFilePath & wb.Name & ".pdf"

    End If

    Set iConf = Nothing

    With Application
        .ScreenUpdating = True
        .EnableEvents = True
    End With

        MsgBox "Le fichier a bien été envoyé !"
    End If
End Sub
Le 13/01/2020 à 09:36

Bonjour,

Cela ne fonctionne pas,

If wb.Range("E1").Value Like "?*@?*.?*" Then => en jaune

Je vous remercie

Le 13/01/2020 à 10:09
CamS a écrit :

Bonjour,

Cela ne fonctionne pas,

If wb.Range("E1").Value Like "?*@?*.?*" Then => en jaune

Je vous remercie

et dans les céllules E1 il y a bien des adresse Mail? qui ont un format max@web.fr? ou bien "adresse 1", "adresse 2", .. etc ???

sous la feuille Base colonne F, il faut enlever les liens hypertexte et tape directement les adresses Mail!

@++

Le 13/01/2020 à 10:34

Oui j'ai bien une adresse mail sans lien hypertexte mais cela note débogage.

Petite question, dans votre macro, comment faite vous le lien avec l'onglet concerné ?

Le 13/01/2020 à 10:51

Ben le code doit être relier à chaque bouton de chaque page et avec ce code

Set wb = ActiveWorkbook

il traite la page active!

Le 13/01/2020 à 11:42

ok je comprends, mais cela ne fonctionne pas j'ai

If wb.Range("E1").Value Like "?*@?*.?*" Then => en jaune

Avez vous essayé sur mon fichier joint avec dans la base votre adresse mail ?

Le 13/01/2020 à 12:23

Sorry mais il y a vraiment un problème avec cette macro, je croyais que ca fonctionne!

essaie comme ca et dit moi si ca fonctionne

Sub colis()
    Dim sh As Worksheet
    Dim TempFilePath As String
    Dim iMsg As Object

If MsgBox("Etes-vous certain de vouloir envoyer le fichier ORDRE DE TRANSPORT LP ?", vbYesNo, "Demande de confirmation") = vbYes Then

    TempFilePath = Environ$("temp") & "\"

    With Application
        .ScreenUpdating = False
        .EnableEvents = False
    End With

    Set sh = ActiveSheet
    If sh.Range("E1").Value Like "?*@?*.?*" Then
       Application.CutCopyMode = False
       sh.ExportAsFixedFormat Type:=xlTypePDF, Filename:=TempFilePath & sh.Name & ".pdf"

       Set iMsg = CreateObject("CDO.Message")
        With iMsg
          .Configuration.Fields.Item("http://schemas.microsoft.com/cdo/configuration/sendusing") = 2
          .Configuration.Fields.Item("http://schemas.microsoft.com/cdo/configuration/smtpserver") = "172.16.1.47"
          .Configuration.Fields.Item("http://schemas.microsoft.com/cdo/configuration/smtpserverport") = 25
          .Configuration.Fields.Update
            .To = sh.Range("E1").Value
            .Subject = "ORDRE TRANSPORT "
            .AddAttachment TempFilePath & sh.Name & ".pdf"
            .TextBody = "Bonjour,ci joint le fichier ORDRE DE TRANSPORT"
            .SendUsingAccount = objOutlook.Session.Accounts.Item(1)
            .Send
        End With
       Set iMsg = Nothing

       Kill TempFilePath & sh.Name & ".pdf"

    End If

    Set iConf = Nothing

    With Application
        .ScreenUpdating = True
        .EnableEvents = True
    End With

        MsgBox "Le fichier a bien été envoyé !"
    End If
End Sub

si ca fonctionne pas, essaie cette macro

Sub colis_1()

    Dim OlApp As Object
    Dim NewMail As Object
    Dim TempFilePath As String
    Dim TempFileName As String
    Dim FileFullPath As String

    With Application
        .ScreenUpdating = False
        .EnableEvents = False
    End With

    TempFilePath = Environ$("temp") & "\"

    TempFileName = ActiveSheet.Name & "-" & Format(Now, "dd-mmm-yy h-mm-ss") & ".pdf"

    FileFullPath = TempFilePath & TempFileName

    On Error GoTo err
    With ActiveSheet
        .ExportAsFixedFormat _
        Type:=xlTypePDF, _
        Filename:=FileFullPath, _
        Quality:=xlQualityStandard, _
        IncludeDocProperties:=True, _
        IgnorePrintAreas:=False, _
        OpenAfterPublish:=False
    End With
       sh.ExportAsFixedFormat Type:=xlTypePDF, Filename:=TempFilePath & sh.Name & ".pdf"

    Set OlApp = CreateObject("Outlook.Application")
    Set NewMail = OlApp.CreateItem(0)

    On Error Resume Next
    With NewMail
        .To = ActiveSheet.Range("E1").Value
        .Subject = "ORDRE TRANSPORT "
        .Body = "Bonjour,ci joint le fichier ORDRE DE TRANSPORT"
        .Attachments.Add FileFullPath
        .Send   'ou bien .Display pour voir le mail avant l'envoi.
    End With
    On Error GoTo 0

    Kill FileFullPath

    Set NewMail = Nothing
    Set OlApp = Nothing

    With Application
        .ScreenUpdating = True
        .EnableEvents = True
    End With
        MsgBox ("Le fichier a bien été envoyé !")
    Exit Sub
err:
        MsgBox err.Description

End Sub
Le 13/01/2020 à 12:43

Cela me note Objet requis

Je suis sur Gmail au lien de Outlook

Merci

Le 13/01/2020 à 12:54
CamS a écrit :

Cela me note Objet requis

Nr. d'erreur? 424?

CamS a écrit :

Mais mon problème comment faire pour que cela fonctionne onglet par onglet car pour le moment cela s'envoi tout en même temps car même cellule.

mais pourquoi ca fonctionnait avant avec tout le fichier?

microsoft CDO for Windows 2000 Library est bien activé? voir foto

cdo
Le 13/01/2020 à 13:41

Cela fonctionnait ça envoyait le 2 onglet en même temps car adresse je pense était dans la même cellule car j'ai un autre fichier ou l'on a fait la macro en changeant l'adresse de cellule a chaque onglet et cela fonctionne un par un mais je voulais plus faire comme cela car cela est source d'erreur quand il y a 50 onglets

Ci dessous la macro qui fonctionne sur chaque onglet quand on change l'adresse mail de cellule

Sub CDO_Mail_Every_Worksheet_Filejeudi()

'fonctionne sur Excel 97-2007

If MsgBox("Etes-vous certain de vouloir envoyer le fichier ?", vbYesNo, "Demande de confirmation") = vbYes Then

Dim sh, shCopy As Worksheet

Dim wb As Workbook

Dim Sourcewb As Workbook

Dim FileExtStr As String

Dim FileFormatNum As Long

Dim TempFilePath As String

Dim TempFileName As String

Dim iMsg As Object

Dim iConf As Object

Dim Flds As Variant

Set Sourcewb = ThisWorkbook

TempFilePath = Environ$("temp") & "\"

With Application

.ScreenUpdating = False

.EnableEvents = False

End With

Set iConf = CreateObject("CDO.Configuration")

' iConf.Load -1 ' CDO Source Defaults

' Set Flds = iConf.Fields

' With Flds

' .Item("http://schemas.microsoft.com/cdo/configuration/sendusing") = 2

' .Item("http://schemas.microsoft.com/cdo/configuration/smtpserver") = "Fill in your SMTP server here"

' .Item("http://schemas.microsoft.com/cdo/configuration/smtpserverport") = 25

' .Update

' End With

For Each sh In Sourcewb.Worksheets

If sh.Range("d2").Value Like "?*@?*.?*" Then

Set wb = ActiveWorkbook

'Change all cells in the worksheet to values if you want

' With wb.Sheets(1).UsedRange

' .Cells.Copy

' .Cells.PasteSpecial xlPasteValues

' .Cells(1).Select

' End With

Application.CutCopyMode = False

sh.Select

sh.ExportAsFixedFormat Type:=xlTypePDF, Filename:= _

TempFilePath & sh.Name & ".pdf"

'With wb

' .SaveAs TempFilePath & sh.Name & ".pdf"

' .Close savechanges:=False

'End With

Set iMsg = CreateObject("CDO.Message")

With iMsg

.Configuration.Fields.Item _

("http://schemas.microsoft.com/cdo/configuration/sendusing") = 2

.Configuration.Fields.Item _

("http://schemas.microsoft.com/cdo/configuration/smtpserver") = "172.16.1.47"

.Configuration.Fields.Item _

("http://schemas.microsoft.com/cdo/configuration/smtpserverport") = 25

.Configuration.Fields.Update

.To = sh.Range("d2").Value

.Bcc = "adresse mail"

.From = "adresse mail"

.Subject = "Fichier qualité "

.AddAttachment TempFilePath & sh.Name & ".pdf"

.TextBody = "Bonjour,ci joint le fichier ..."

.Send

End With

Set iMsg = Nothing

Kill TempFilePath & sh.Name & ".pdf"

End If

Next sh

Set iConf = Nothing

Set Flds = Nothing

With Application

.ScreenUpdating = True

.EnableEvents = True

End With

MsgBox "Le fichier a bien été envoyé !"

End If

End Sub

Le 13/01/2020 à 13:47

microsoft CDO for Windows 2000 Library est bien activé?

à tester

Dim sh As Worksheet
Dim TempFilePath As String
Dim iMsg As Object
Dim iConf As Object

TempFilePath = Environ$("temp") & "\"

With Application
.ScreenUpdating = False
.EnableEvents = False
End With

Set iConf = CreateObject("CDO.Configuration")

Set sh = ActiveSheet
If sh.Range("E1").Value Like "?*@?*.?*" Then

Application.CutCopyMode = False
sh.Select
sh.ExportAsFixedFormat Type:=xlTypePDF, Filename:= _
TempFilePath & sh.Name & ".pdf"

Set iMsg = CreateObject("CDO.Message")
With iMsg
.Configuration.Fields.Item _
("http://schemas.microsoft.com/cdo/config ... /sendusing") = 2
.Configuration.Fields.Item _
("http://schemas.microsoft.com/cdo/config ... smtpserver") = "172.16.1.47"
.Configuration.Fields.Item _
("http://schemas.microsoft.com/cdo/config ... serverport") = 25
.Configuration.Fields.Update
.To = sh.Range("E1").Value
.BCC = "adresse mail"
.From = "adresse mail"
.Subject = "Fichier qualité "
.AddAttachment TempFilePath & sh.Name & ".pdf"
.TextBody = "Bonjour,ci joint le fichier ..."
.Send
End With
Set iMsg = Nothing

Kill TempFilePath & sh.Name & ".pdf"

End If

Set iConf = Nothing

With Application
.ScreenUpdating = True
.EnableEvents = True
End With

MsgBox "Le fichier a bien été envoyé !"
End If
End Sub
Le 13/01/2020 à 14:02

Oui car l'autre macro fonctionne très bien

Le 13/01/2020 à 14:45

Voici le fichier qui fonctionne si vous faites la macro les 3 onglets partent en même temps

Merci pour votre aide

7mail-transporteur.xlsm (47.36 Ko)
Le 13/01/2020 à 15:23

t'as testé la dernière macro? resultat?

Le 13/01/2020 à 16:40

.Send = débogage et En jaune Jaune

Tu as essayé avec mon fichier ?

Le 13/01/2020 à 21:53
CamS a écrit :

.Send = débogage et En jaune Jaune

Tu as essayé avec mon fichier ?

Non rien ne fonctionne!

Le 14/01/2020 à 10:28

Bonjour,

Moi quand je rajoute adresse mail dans la base la macro fonctionne

pouvez vous svp essayer de faire une macro dans mon fichier qui fonctionne chez vous et j'essayerai de mon coté

je vous remercie

Le 15/01/2020 à 11:41

Bonjour,

Merci

C'est bon j'ai fini par trouver

Rechercher des sujets similaires à "envoi different onglet destinataire"