vanuit excel naar 20+ emailadressen sturen

[abracadaver909]

Beste Help Mij-ers,

Ik wil vanuit een macro in excel het bestand versturen naar 20+ adressen. Deze adressen staan in blad "e-mail" in de range van B2 t/m B22.

Ik ben niet verder gekomen dan het volgende:

ActiveWorkbook.SendMail Sheets("E-mail").Range("B2:B22")

Dit werkt helaas niet

Hoe kan ik het script aanpassen zodat het wel werkt?


Bij voorbaat dank,

Chris Verschoor

 

[Warme bakkertje]

Kijk eens hier voor meer informatie
http://www.rondebruin.nl/mail/folder1/mail1.htm

 

[abracadaver909]

Beste Rudi,

Bedankt voor je respons!

Ik ben tijdens het googlen verschillende malen deze site tegen gekomen. Het ligt waarschijnlijk aan mij, maar volgens mij wordt daar niet besproken waar ik naar zoek.

Volgens mij moet het lukken met die range. Op die manier hoef je alleen maar een mailadres aan die range toe te voegen en wordt deze automatisch meegenomen in mailto lijst.

Groeten Chris

 

[Warme bakkertje]

Deze heb ik eens gemaakt voor een ander project. Hier kan je alles uithalen wat je nodig hebt.

Option Base 1
Sub Mail_Sheets()
'Working in 97-2010
    Dim Sourcewb As Workbook, Destwb As Workbook
    Dim sh As Worksheet, I As Long, strto As String
    Dim TheActiveWindow As Window, TempWindow As Window
    Dim shtArray(), X As Long
    With Application
        .ScreenUpdating = False
        .EnableEvents = False
        .DisplayAlerts = False
    Set Sourcewb = ActiveWorkbook
    On Error Resume Next
    'Verzend de tabbladen in kolom E naar iedere spelers die in het bereik ("B1:B150") staat.
    For Each cell In ThisWorkbook.Sheets("e-mailadressen") _
        .Range("B1:B150").Cells.SpecialCells(xlCellTypeConstants)
        If cell.Value Like "?*@?*.?*" Then
            strto = strto & cell.Value & ";"
        End If
    Next cell
    On Error GoTo 0
    If Len(strto) > 0 Then strto = Left(strto, Len(strto) - 1)
    'Make a list of the worksheets to copy and make a copy
    sq = Sheets("e-mailadressen").Range("E2:E" & Sheets("e-mailadressen").Range("E20").End(xlUp).Row)
    For X = 1 To UBound(sq)
        Sheets(sq(X, 1)).Copy Before:=Sheets(1)
        With ActiveSheet
            .Unprotect
            .Cells.Copy
            .Cells.PasteSpecial Paste:=xlPasteValues
            '.Protect
        End With
            Application.CutCopyMode = False
    Next
    Set Sourcewb = ActiveWorkbook
    'Copy the sheets to a new workbook
    'We add a temporary Window to avoid the Copy problem
    'if there is a List or Table in one of the sheets and
    'if the sheets are grouped
    
    With Sourcewb
        Set TheActiveWindow = ActiveWindow
        Set TempWindow = .NewWindow
        For Each ws In .Worksheets
            If Right(ws.Name, 3) = "(2)" Then
                intA = intA + 1
                ReDim Preserve shtArray(intA)
                shtArray(intA) = ws.Name
            End If
        Next ws
    .Sheets(shtArray).Copy
    End With
    'Close temporary Window
    TempWindow.Close
    Set Destwb = ActiveWorkbook
    
    'Save the new workbook/Mail it/Delete it
    With Destwb
        .SaveAs Environ$("temp") & "\" & "'t Sluissse VOETBALSPEL " & Format(Now, "dd-mmm-yy") & ".xlsx", _
                FileFormat:=51
    On Error Resume Next
    Dim N As Long
    With Application
         'if necessary change this message
         'scroll down to the message field
        For N = 1 To 5
            .SendKeys "{TAB}", Wait:=True
        Next
        .Dialogs(xlDialogSendMail).Show strto, _
        "'t Sluisse VOETBALSPEL " & Format(Now, "yyyy")
    End With
        On Error GoTo 0
        .Close SaveChanges:=False
    End With
    'Delete the file you have send
    Kill Environ$("temp") & "\" & "'t Sluissse VOETBALSPEL " & Format(Now, "dd-mmm-yy") & ".xlsx"
    Sheets(shtArray).Delete
        .ScreenUpdating = True
        .EnableEvents = True
        .DisplayAlerts = True
    End With
End Sub

 

[abracadaver909]

Beste Rudi,

Ik ben eruit!
Jouw script is veel uitgebreider voor wat ik nodig heb, maar het werkt! Ik heb hem wat uitgedunt en aangepast met een ander script.

Voor de mensen die dit probleem ook hebben, heb ik hieronder het uiteindelijke script geplaatst...

Sub Create_Mail_From_List()
' Works in Excel 2000, Excel 2002, Excel 2003, Excel 2007, Excel 2010, Outlook 2000, Outlook 2002, Outlook 2003, Outlook 2007, and Outlook 2010.
    Dim OutApp As Object
    Dim OutMail As Object
    Dim cell As Range
    
    Application.ScreenUpdating = False
    Set OutApp = CreateObject("Outlook.Application")

    On Error GoTo cleanup
    For Each cell In ThisWorkbook.Sheets("E-mail").Range("B2:B150").Cells.SpecialCells(xlCellTypeConstants)
        If cell.Value Like "?*@?*.?*" Then
            strto = strto & cell.Value & "; "
        End If

            Set OutMail = OutApp.CreateItem(0)
            On Error Resume Next
            With OutMail
                .To = strto
                .Subject = "Bezetting " & Cells(3, 6).Value
                '.Body = "Dear " & Cells(cell.Row, "A").Value _
                '      & vbNewLine & vbNewLine & _
                '        "Please contact us to discuss bringing " & _
                '       "your account up to date"

                
                'You can also add files like this:
                '.Attachments.Add ("C:\test.txt")


                .Attachments.Add ActiveWorkbook.FullName

                
                .Send  'Or use Display
                
                

            End With
            On Error GoTo 0
            Set OutMail = Nothing
    
    Next cell

cleanup:
    Set OutApp = Nothing
    Application.ScreenUpdating = True
End Sub

Hartstikke bedankt!

***EDIT*** Lees bericht hieronder!

 

[abracadaver909]

Herstel!!!

Het script zoals hierboven zorgt voor een kettingreactie met mails versturen.

De eerstgenoemde persoon in de range krijt een maail en daar een mail voor ieder ander in die range, in dit geval dus zo'n 22 mails met dezlefde inhoud.
Dit is het script dat wel de mails goed verzend:

Sub Create_Mail_From_List()
' Works in Excel 2000, Excel 2002, Excel 2003, Excel 2007, Excel 2010, Outlook 2000, Outlook 2002, Outlook 2003, Outlook 2007, and Outlook 2010.
    Dim OutApp As Object
    Dim OutMail As Object
    Dim cell As Range
    
    Application.ScreenUpdating = False
    Set OutApp = CreateObject("Outlook.Application")

    On Error GoTo cleanup
    For Each cell In ThisWorkbook.Sheets("E-mail").Range("B2:B150").Cells.SpecialCells(xlCellTypeConstants)
        If cell.Value Like "?*@?*.?*" Then
            strto = strto & cell.Value & "; "
        End If

            Set OutMail = OutApp.CreateItem(0)
            On Error Resume Next
            With OutMail
                .To = strto
                '.Subject = "Reminder"
                '.Body = "Dear " & Cells(cell.Row, "A").Value _
                '      & vbNewLine & vbNewLine & _
                '        "Please contact us to discuss bringing " & _
                '       "your account up to date"
                
                'You can also add files like this:
                .Attachments.Add ActiveWorkbook
                
                .Send  'Or use Display.
            End With
            On Error GoTo 0
            Set OutMail = Nothing
    
    Next cell

cleanup:
    Set OutApp = Nothing
    Application.ScreenUpdating = True
End Sub