---------- Forwarded message ---------- From: SUDHIR VERMA <newinex...@gmail.com> Date: 19 March 2016 at 22:08 Subject: Excel VBA Macro Help Group [excelvbalab] Save outlook draft through Excel To: Excel VBA Lab <excelvba...@googlegroups.com>
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
--
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+unsubscr...@googlegroups.com.
To post to this group, send email to excelvba...@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
<https://groups.google.com/d/msgid/ExcelVbaLab/CAGpm4DQi6qQfioeRP%3Db18uHb%3DBuaD7uegK1jcEojReJaJviZ6Q%40mail.gmail.com?utm_medium=email&utm_source=footer>
.
For more options, visit https://groups.google.com/d/optout.
--
Are you =EXP(E:RT) or =NOT(EXP(E:RT)) in Excel? And do you wanna be? It’s
=TIME(2,DO:IT,N:OW) ! Join official Facebook page of this forum @
https://www.facebook.com/discussexcel
FORUM RULES
1) Use concise, accurate thread titles. Poor thread titles, like Please Help,
Urgent, Need Help, Formula Problem, Code Problem, and Need Advice will not get
quick attention or may not be answered.
2) Don't post a question in the thread of another member.
3) Don't post questions regarding breaking or bypassing any security measure.
4) Acknowledge the responses you receive, good or bad.
5) Jobs posting is not allowed.
6) Sharing copyrighted material and their links is not allowed.
NOTE : Don't ever post confidential data in a workbook. Forum owners and
members are not responsible for any loss.
---
You received this message because you are subscribed to the Google Groups "MS
EXCEL AND VBA MACROS" group.
To unsubscribe from this group and stop receiving emails from it, send an email
to excel-macros+unsubscr...@googlegroups.com.
To post to this group, send email to excel-macros@googlegroups.com.
Visit this group at https://groups.google.com/group/excel-macros.
For more options, visit https://groups.google.com/d/optout.
save draft mails in outlook.xlsm
Description: application/vnd.ms-excel.sheet.macroenabled.12
