mail macro

[Afarag]

Dears,

please i ask for how can i send mail from mail list but not from one mail via excel vba

thanks

Option Explicit
' requires a reference to the Microsoft Outlook x.0 Object Library
Sub RegisterAppointmentList()
' adds a list of appontments to the Calendar in Outlook
    Dim olApp As Outlook.Application
    Dim olAppItem As Outlook.appointmentItem
    Dim r As Long
    Dim myPath As String

    Application.ScreenUpdating = False
    myPath = ActiveWorkbook.Path

    DeleteTestAppointments    ' deletes previous test appointments
    On Error Resume Next
    Set olApp = GetObject("", "Outlook.Application")
    On Error GoTo 0
    If olApp Is Nothing Then
        On Error Resume Next
        Set olApp = CreateObject("Outlook.Application")
        On Error GoTo 0
        If olApp Is Nothing Then
            MsgBox "Outlook is not available!"
            Exit Sub
        End If
    End If

    r = 10    ' first row with appointment data in the active worksheet
    While Len(Cells(r, 1).Formula) > 0
        Set olAppItem = olApp.CreateItem(olAppointmentItem)    ' creates a new appointment

        With olAppItem
            ' set default appointment values
            .Start = Now
            .End = Now
            .Subject = "No subject"
            .Location = ""
            .Body = ""
            .ReminderSet = True
            .MeetingStatus = olMeeting

            ' read appointment values from the worksheet
            On Error Resume Next
            .Start = Cells(r, 1).Value + Cells(r, 2).Value
            .End = Cells(r, 1).Value + Cells(r, 3).Value
            .Start = Cells(r, 1).Value + Cells(r, 4).Value
            .End = Cells(r, 1).Value + Cells(r, 5).Value
            .Start = Cells(r, 1).Value + Cells(r, 6).Value
            .End = Cells(r, 1).Value + Cells(r, 7).Value
            .Subject = Cells(r, 8).Value
            .Location = Cells(r, 9).Value
            .ReminderSet = Cells(r, 12).Value
            .Importance = Right(Cells(r, 13).Value, 1)
            .RequiredAttendees = Cells(r, 14).Value
            .Categories = "TestAppointment"    ' add this to be able to delete the testappointments
            .ReminderSet = True
            .ReminderMinutesBeforeStart = 0

            On Error GoTo 0
            .Save    ' saves the new appointment to the default folder
        End With

        With olApp
            Dim Xl As Excel.Application
            Dim Ws As Excel.Worksheet
            Dim xlRn As Excel.Range

            Set Xl = GetObject(, "Excel.Application")
            Set Ws = Xl.Workbooks.Parent.Worksheets(Cells(r, 1).Offset(0, 9).Value)
            Set xlRn = Ws.Range("MailBodyText")


            Dim varBody As String
            Dim objdata As DataObject
            Dim DataObject As Object
            Set objdata = New DataObject

            Application.GoTo Reference:=xlRn
            Selection.Copy
            objdata.GetFromClipboard
            varBody = objdata.GetText

            With olAppItem
                .Body = varBody '& vbCrLf & vbCrLf
            End With
        End With

        olAppItem.Close olSave
        r = r + 1
        Sheets("scheduleapp").Activate
    Wend
    Set olAppItem = Nothing
    Set olApp = Nothing
    Application.ScreenUpdating = True
End Sub
Sub DeleteTestAppointments()
' deletes all testappointments in Outlook
    Dim olApp As Outlook.Application
    Dim OLF As Outlook.MAPIFolder
    Dim r As Long, dCount As Long
    On Error Resume Next
    Set olApp = GetObject("", "Outlook.Application")
    On Error GoTo 0
    If olApp Is Nothing Then
        On Error Resume Next
        Set olApp = GetObject("Outlook.Application")
        On Error GoTo 0
        If olApp Is Nothing Then
            MsgBox "Outlook is not available!"
            Exit Sub
        End If
    End If
    Set OLF = olApp.GetNamespace("MAPI").GetDefaultFolder(olFolderCalendar)
    dCount = 0
    For r = OLF.Items.Count To 1 Step -1
        If TypeName(OLF.Items(r)) = "AppointmentItem" Then
            If InStr(1, OLF.Items(r).Categories, "TestAppointment", vbTextCompare) = 1 Then
                OLF.Items(r).Delete
                dCount = dCount + 1
            End If
        End If
    Next r
    Set olApp = Nothing
    Set OLF = Nothing
End Sub

 

[Luke M]

I'm not sure I understand your question. An email can't be from a mailing list...someone has to send it.

Also, I may have pointed this out before, but this block:
.Start = Cells(r, 1).Value + Cells(r, 2).Value
.End = Cells(r, 1).Value + Cells(r, 3).Value
.Start = Cells(r, 1).Value + Cells(r, 4).Value
.End = Cells(r, 1).Value + Cells(r, 5).Value
.Start = Cells(r, 1).Value + Cells(r, 6).Value
.End = Cells(r, 1).Value + Cells(r, 7).Value

is a bit, useless. Only the last 2 lines will be kept, the first 4 get overwritten.

 

[Afarag]

my first question related of mail lest, and you provide me that there isn't any way to do that, but your concern about last 2 lines that i have more than one time which i want to set the appointment, if you have any modification you can direct me to use, and i face an error
Runtime error 2147221233 (804010f) when run the macro

when click debug the row which highlighted was :
.Save ' saves the new appointment to the default folder
i hope if i can get help to solve this case