Kan man sende emails med attachment via SMTP til flere modtagere?

Du kan undgå at få spørgsmålet fra Outlook om bekræftelse ved at installere "ClickYes" fra:

www.contextmagic.com/express-clickyes...

Hmmm!? - det løser jo godt nok delvist problemet, bortset fra at man fortsat ikke kommer udenom at anvende Outlook?...

Jeg efterlyser helst et VBA-eksempel på hvordan man sender fra Excel udfra en mailliste via SMTP-protekollen? (med vedhæftet fil)

Du kunne jo se på det modsat, og lave en makro i Outlook, der sender det ark der markeres, samt sende til de personer du markerer i kontaktpersoner. Det må kunne lade sig gøre. Er det en holdbar løsning?

Denne kan afsende mail via SMTP. Er afprøvet, og fundet her: http://www.rondebruin.nl/cdo.htm#Workbook.

Du skal bare rette smtp til din egen server.

Sub CDO_Send_Workbook()
    Dim iMsg As Object
    Dim iConf As Object
    Dim wb As Workbook
    Dim WBname As String
    '    Dim Flds As Variant

    Application.ScreenUpdating = False
    Set wb = ActiveWorkbook

    ' It will save a copy of the file in C:/ with a Date and Time stamp
    WBname = wb.Name & " " & Format(Now, "dd-mm-yy h-mm-ss") & ".xls"
    wb.SaveCopyAs "C:/" & WBname


    Set iMsg = CreateObject("CDO.Message")
    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") = "smtp.mail.dk"
    '        .Item("http://schemas.microsoft.com/cdo/configuration/smtpserverport") = 25
    '        .Update
    '    End With

    With iMsg
        Set .Configuration = iConf
        .To = "jon@something.com"
        .CC = ""
        .BCC = ""
        .From = """Ron"" <ron@something.nl>"
        .Subject = "This is a test"
        .TextBody = "This is the body text"
        .AddAttachment "C:/" & WBname
        .Send
    End With

    'If you not want to delete the file you send delete this line
    Kill "C:/" & WBname 

    Set iMsg = Nothing
    Set iConf = Nothing
    Set wb = Nothing
    Application.ScreenUpdating = True
End Sub

Denne kræver 3 ark med navnene Mail, ark1 og ark2. I arket "Mail", skal der i kolonne A stå nogle mailadresser. I kolonne B et tal fra 1 til 3, således:

nogen1@mail.dk 1
nogen2@mail.dk 2
nogen3@mail.dk 3
nogen4@mail.dk 1
nogen5@mail.dk 2

Alle med et 1-tal får ark1, alle med et 2-tal får ark 2, alle med et 3-tal får ark 1 og 2.
Du kan jo selv udbygge!


Public Sub SendMail()

    Dim Bund
    Dim MitRange As Variant
    Dim iMsg As Object
    Dim iConf As Object
    Dim WB2 As Workbook
    Dim WBname As String
        Dim Flds As Variant
    Sheets("Mail").Activate
    Bund = Cells(65536, 1).End(xlUp).Row
    MitRange = Range("A1:B" & Bund)
   
    Application.ScreenUpdating = False
WB1Navn = ActiveWorkbook.Name
    For I = 1 To Bund
        If MitRange(I, 2) = 1 Then
            Sheets("Ark1").Copy
            GoSub Fortsaet:
        Else
            If MitRange(I, 2) = 2 Then
                Sheets("Ark2").Copy
                GoSub Fortsaet:
            Else
                If MitRange(I, 2) = 3 Then
                    Sheets(Array("Ark1", "Ark2")).Copy
                    GoSub Fortsaet:
                End If
            End If
        End If
    Next
   
GoTo Faerdig:
Fortsaet:
    Set WB2 = ActiveWorkbook

    ' It will save the new file with the ActiveSheet in C:/ with a Date and Time stamp
    WBname = "Part of " & WB1Navn & " " & Format(Now, "dd-mm-yy h-mm-ss") & ".xls"
    WB2.SaveAs "C:/" & WBname
    WB2.Close False

    Set iMsg = CreateObject("CDO.Message")
    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") = "smtp.mail.dk"
            .Item("http://schemas.microsoft.com/cdo/configuration/smtpserverport") = 25
            .Update
        End With

    With iMsg
        Set .Configuration = iConf
        .To = MitRange(I, 1)
        .CC = ""
        .BCC = ""
        .From = """akyhne"" <ron@something.nl>"
        .Subject = "This is NOT a test. This means serious buisness"
        .TextBody = "Hi there"
        .AddAttachment "C:/" & WBname
        .Send
    End With

  'If you not want to delete the file you send delete this line
    Kill "C:/" & WBname
 
    Set iMsg = Nothing
    Set iConf = Nothing
    Set WB2 = Nothing
    Workbooks(WB1Navn).Activate
Return
Set WB1 = Nothing
Faerdig:
    Application.ScreenUpdating = True
End Sub

OBS: Husk lige at rette mailadressen i .From