Save outlook draft through Excel

[SUDHIR VERMA]

Dear Experts,

Please help for modification for macro (save outlook draft through excel).

In this attached excel file, macro will work on single cell for body messages.

But there are required multiple column and row for body messages. As per format available in this excel file.

code of existing macro.

Option Explicit

Sub Mail_Draft_Outlook()

Dim cl As Range

Dim Lastrow As Integer

Dim Lastcol As Integer

Dim myarrTO() As String

Dim a As Variant

Dim k As Integer

Dim myarrCC() As String

Dim b As Variant

Dim L As Integer

Dim myarrBCC() As String

Dim c As Variant

Dim m As Integer

Dim myarrSUB() As String

Dim d As Variant

Dim n As Integer

Dim myarrBODY() As String

Dim e As Variant

Dim o As Integer

Dim myarrATTACHMENT() As String

Dim f As Variant

Dim p As Integer

Dim myarrIMPORTANCE() As String

Dim g As Variant

Dim q As Integer

Dim myarrREADRECEIPT() As String

Dim h As Variant

Dim r As Integer

Dim myarrDELIVERYREPORT() As String

Dim j As Variant

Dim s As Integer

Dim myarrBODYFORMAT() As String

Dim x As Variant

Dim z As Integer

Dim i As Integer

Dim oMailItem As Variant

Const DELIMITER = ";"

Dim strCellText As String, strAttachment

Dim strAttachments() As String

Lastrow = Cells.Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row

Lastcol = Cells.Find("*", SearchOrder:=xlByColumns, SearchDirection:=xlPrevious).Column

    k = Lastrow - 1

    ReDim myarrTO(k) As String

    For Each cl In Cells(2, 1).Resize(k, 1)

          

          myarrTO(a) = cl.Value

          a = a + 1

    Next

    L = Lastrow - 1

    ReDim myarrCC(L) As String

    For Each cl In Cells(2, 2).Resize(L, 1)

          

          myarrCC(b) = cl.Value

          b = b + 1

    Next

    

    m = Lastrow - 1

    ReDim myarrBCC(m) As String

    For Each cl In Cells(2, 3).Resize(m, 1)

          

          myarrBCC(c) = cl.Value

          c = c + 1

    Next

    n = Lastrow - 1

    ReDim myarrSUB(n) As String

    For Each cl In Cells(2, 4).Resize(n, 1)

          

          myarrSUB(d) = cl.Value

          d = d + 1

    Next

    o = Lastrow - 1

    ReDim myarrBODY(o) As String

    For Each cl In Cells(2, 5).Resize(o, 1)

          myarrBODY(e) = cl.Value

          e = e + 1

    Next

    p = Lastrow - 1

    ReDim myarrATTACHMENT(p) As String

    For Each cl In Cells(2, 10).Resize(p, 1)

          myarrATTACHMENT(f) = cl.Value

          k = k + 1

    Next

    

'    p = Lastrow - 1

'

'

'    For Each cl In Cells(2, 6).Resize(p, 1)

'    strCellText = Cells(2, 6).Resize(p, 1).Value

'    strAttachments = Split(strCellText, DELIMITER)

'

'    Next

'

    

    q = Lastrow - 1

    ReDim myarrIMPORTANCE(q) As String

    

    For Each cl In Cells(2, 6).Resize(q, 1)

        If cl.Value = "High" Then

            myarrIMPORTANCE(g) = olImportanceHigh

        End If

                

        If cl.Value = "Low" Then

            myarrIMPORTANCE(g) = olImportanceLow

        End If

        

        If IsEmpty(cl.Value) Then

            myarrIMPORTANCE(g) = olImportanceNormal

        End If

        g = g + 1

    Next

r = Lastrow - 1

    ReDim myarrREADRECEIPT(r) As String

    

    For Each cl In Cells(2, 7).Resize(r, 1)

        If cl.Value = "Yes" Then

            myarrREADRECEIPT(h) = True

        End If

                

        If cl.Value = "No" Then

            myarrREADRECEIPT(h) = False

        End If

        

        h = h + 1

    Next

s = Lastrow - 1

    ReDim myarrDELIVERYREPORT(s) As String

    

    For Each cl In Cells(2, 8).Resize(s, 1)

        If cl.Value = "Yes" Then

            myarrDELIVERYREPORT(j) = True

        End If

                

        If cl.Value = "No" Then

            myarrDELIVERYREPORT(j) = False

        End If

        

        j = j + 1

    Next

x = Lastrow - 1

    ReDim myarrBODYFORMAT(x) As String

    

    For Each cl In Cells(2, 9).Resize(q, 1)

        If cl.Value = "Rich" Then

            myarrBODYFORMAT(z) = olFormatRichText

        End If

                

        If cl.Value = "Plain" Then

            myarrBODYFORMAT(z) = olFormatPlain

        End If

        

        If cl.Value = "Html" Then

            myarrBODYFORMAT(z) = olFormatHTML

        End If

        z = z + 1

    Next

Dim OutApp As Outlook.Application

Dim OutMail As MailItem

    For i = 0 To Lastrow - 2

        For oMailItem = 0 To Lastrow - 2

        

        Set OutApp = CreateObject("Outlook.Application")

        Set oMailItem = OutApp.CreateItem(0)

        

        On Error Resume Next

            With oMailItem

                .To = myarrTO(i)

                .CC = myarrCC(i)

                .BCC = myarrBCC(i)

                .Subject = myarrSUB(i)

                .Body = myarrBODY(i)

                .Attachments.Add myarrATTACHMENT(i)

               

'               For Each strAttachment In strAttachments

'

'                    .Attachments.Add strAttachment

'                Next

                

                

                    

                .BodyFormat = myarrBODYFORMAT(i)

                .ReadReceiptRequested = myarrREADRECEIPT(i)

                .Importance = myarrIMPORTANCE(i)

                .OriginatorDeliveryReportRequested = myarrDELIVERYREPORT(i)

                .Save

            End With

            

        Next

    Next

On Error GoTo 0

    Set OutMail = Nothing

    Set OutApp = Nothing

End Sub

[Vaibhav Joshi]

can you elaborate, what data will go to 1st recipient?

--
www.ExcelVbaLab.com
---
You received this message because you are subscribed to the Google Groups "Excel VBA Lab - An Excel VBA Macro help Group" group.
To unsubscribe from this group and stop receiving emails from it, send an email to ExcelVbaLab...@googlegroups.com.
To post to this group, send email to Excel...@googlegroups.com.
Visit this group at https://groups.google.com/group/ExcelVbaLab.
To view this discussion on the web visit https://groups.google.com/d/msgid/ExcelVbaLab/CAGpm4DQi6qQfioeRP%3Db18uHb%3DBuaD7uegK1jcEojReJaJviZ6Q%40mail.gmail.com.
For more options, visit https://groups.google.com/d/optout.

[Vaibhav Joshi]

PFA, on the basis of mine understanding.. 

[SUDHIR VERMA]

Sir,

Error on running Macro as per below snap.

To view this discussion on the web visit https://groups.google.com/d/msgid/ExcelVbaLab/CALu41JC2qj_mUjFigvy%2BTHTAAb%3DPtL7w2U5Oh21zdS%2BD-T20MA%40mail.gmail.com.

[Vaibhav Joshi]

change [d2] to Range("D2").value

[Ashish Kumar]

Dear Vaibhav Sir,

It's Working prefect..!!

Regards

Ashish Kumar

[Vibhuti Shrotriya]

Dear Vaibhav Sir,

It's working perfect for me. Thanks for sharing.

Thanks & Regards

Vibhuti