slamkode

Sub create_and_add_to()
    On Error Resume Next
    Dim OutApp As Object
    Dim OutMail As Object
    Dim objNsp As Object
    Dim colSyc As Object
    Dim objSyc As Object
    Dim i As Integer
    Dim ActSheet As Worksheet
    Dim SelRange As Range
    Dim toAddress As String
    Dim signature As String


    Set ActSheet = ActiveSheet
    Set SelRange = Selection

    Set OutApp = CreateObject("Outlook.Application")
    Set OutMail = OutApp.CreateItem(0)
    Set objNsp = appOL.Application.GetNamespace("MAPI")
    Set colSyc = objNsp.SyncObjects

    'On Error Resume Next

    For Each cell In Selection
        If cell.Column = 4 Then
            toAddress = toAddress & cell & ";"
        Else
            ccAddress = ccAddress & ";" & cell & ";"
        End If
    Next cell
    signature = OutApp.body
    With OutMail
        .To = toAddress
        .Subject = ""
        '.body = "" & vbNewLine & signature
        .CC = ccAddress
        '.Attachments.Add BFld1 & TBFileName.Text
        '.Send ' to send in background
         .Display ' to open a mail window with a normal 'SEND' icon available
         .ActiveWindow.Activate
    End With

    For i = 1 To colSyc.Count
        Set objSyc = colSyc.Item(i)
        objSyc.Start
    Next

    On Error GoTo 0

    'OutApp.Quit

    Set OutMail = Nothing
    Set objNsp = Nothing
    Set colSyc = Nothing
    Set objSyc = Nothing
    Set OutApp = Nothing

aa:
End Sub