VBA Save Email as draft

S

SupremeDr

New Member
Joined
Aug 15, 2019
Messages
34
Hello,

I am working on a project to save emails to a specific subfolder in the drafts. Everything works perfectly up to me putting them into a specific folder.

The folder would be "Drafts"\BACode

I just need help on inserting that into my code

Code: 
Option Explicit
 
Public Timing As String
Public BACode As Variant


Sub DraftOutlookEmails()
    
'*******************************************************************
'Microsoft Outlook XX.X Object Library is required to run this code
'*******************************************************************

Dim objOutlook As Outlook.Application
Dim Mail As Outlook.MailItem
Dim lCounter As Long
Set objOutlook = Outlook.Application

Dim wsMLOG As Excel.Worksheet
Set wsMLOG = Sheets("Master Log")
Dim rngTable1 As Excel.Range
Set rngTable1 = wsMLOG.Range("A4").CurrentRegion
Dim rngLessHeader As Excel.Range, rngRows As Long, rngRow1 As Long
Set rngLessHeader = gf_rngGet_TableData_Range(rngTable1)
Dim AdminWeek As Integer

BACode = InputBox("Enter BA Code")
AdminWeek = MsgBox("Admin Week?", vbYesNo)
UserForm1.Show vbModal

rngRows = rngLessHeader.Rows.Count
rngRow1 = rngLessHeader.Rows(1).Count

Dim pathStr As String
pathStr = "Path removed for security"
Dim fileStr As String
Dim fileStr2 As String
Dim mailAddress As String

Sheets("Master Log").Select

Dim i As Long
    
'

    If AdminWeek = vbNo Then
        For i = rngRow1 To rngRows
            If Cells(i, 5) = BACode Then
                If Cells(i, 7) = "E-mail" Then
                    If Cells(i, 9) = Timing Then
                        Set Mail = objOutlook.CreateItem(olMailItem)
                        Mail.To = wsMLOG.Range("L" & i).Value & ";" & wsMLOG.Range("M" & i).Value & ";" & wsMLOG.Range("N" & i).Value & ";" & wsMLOG.Range("O" & i).Value & ";" & wsMLOG.Range("P" & i).Value & ";" & wsMLOG.Range("Q" & i).Value & ";" & wsMLOG.Range("R" & i).Value & ";" & wsMLOG.Range("S" & i).Value & ";" & wsMLOG.Range("T" & i).Value & ";" & wsMLOG.Range("U" & i).Value & ";" & wsMLOG.Range("V" & i).Value & ";" & wsMLOG.Range("W" & i).Value & ";" & wsMLOG.Range("X" & i).Value & ";" & wsMLOG.Range("Y" & i).Value & ";" & wsMLOG.Range("Z" & i).Value & ";" & wsMLOG.Range("AA" & i).Value & ";" & wsMLOG.Range("AB" & i).Value
                        Mail.Subject = wsMLOG.Range("B" & i).Value & " " & wsMLOG.Range("C" & i).Value
                        Mail.Body = Sheets("Sheet1").Range("A1").Text
                        fileStr = wsMLOG.Range("C" & i).Value & ".pdf"
                        If FileExists(pathStr & BACode & "\" & fileStr) Then
                            Mail.Attachments.Add pathStr & BACode & "\" & fileStr
                        Else
                            Mail.Delete
                        End If
                        On Error Resume Next
                        Mail.Close (olSave)
                        Set Mail = Nothing
                    End If
                End If
            End If
         Next
     End If
[\Code]
 

Excel Facts

Why does 9 mean SUM in SUBTOTAL?
It is because Sum is the 9th alphabetically in Average, Count, CountA, Max, Min, Product, StDev.S, StDev.P, Sum, VAR.S, VAR.P.
Sort by date Sort by votes
Code correction

Code: 
 Option Explicit

 Public Timing As String
 Public BACode As Variant


 Sub DraftOutlookEmails()

 '*******************************************************************
 'Microsoft Outlook XX.X Object Library is required to run this code
 '*******************************************************************

 Dim objOutlook As Outlook.Application
 Dim Mail As Outlook.MailItem
 Dim lCounter As Long
 Set objOutlook = Outlook.Application

 Dim wsMLOG As Excel.Worksheet
 Set wsMLOG = Sheets("Master Log")
 Dim rngTable1 As Excel.Range
 Set rngTable1 = wsMLOG.Range("A4").CurrentRegion
 Dim rngLessHeader As Excel.Range, rngRows As Long, rngRow1 As Long
 Set rngLessHeader = gf_rngGet_TableData_Range(rngTable1)
 Dim AdminWeek As Integer

 BACode = InputBox("Enter BA Code")
 AdminWeek = MsgBox("Admin Week?", vbYesNo)
 UserForm1.Show vbModal

 rngRows = rngLessHeader.Rows.Count
 rngRow1 = rngLessHeader.Rows(1).Count

 Dim pathStr As String
 pathStr = "Path removed for security"
 Dim fileStr As String
 Dim fileStr2 As String
 Dim mailAddress As String

 Sheets("Master Log").Select

 Dim i As Long

 '

    If AdminWeek = vbNo Then
        For i = rngRow1 To rngRows
            If Cells(i, 5) = BACode Then
                If Cells(i, 7) = "E-mail" Then
                    If Cells(i, 9) = Timing Then
                        Set Mail = objOutlook.CreateItem(olMailItem)
                        Mail.To = wsMLOG.Range("L" & i).Value & ";" & wsMLOG.Range("M" & i).Value & ";" & wsMLOG.Range("N" & i).Value & ";" & wsMLOG.Range("O" & i).Value & ";" & wsMLOG.Range("P" & i).Value & ";" & wsMLOG.Range("Q" & i).Value & ";" & wsMLOG.Range("R" & i).Value & ";" & wsMLOG.Range("S" & i).Value & ";" & wsMLOG.Range("T" & i).Value & ";" & wsMLOG.Range("U" & i).Value & ";" & wsMLOG.Range("V" & i).Value & ";" & wsMLOG.Range("W" & i).Value & ";" & wsMLOG.Range("X" & i).Value & ";" & wsMLOG.Range("Y" & i).Value & ";" & wsMLOG.Range("Z" & i).Value & ";" & wsMLOG.Range("AA" & i).Value & ";" & wsMLOG.Range("AB" & i).Value
                        Mail.Subject = wsMLOG.Range("B" & i).Value & " " & wsMLOG.Range("C" & i).Value
                        Mail.Body = Sheets("Sheet1").Range("A1").Text
                        fileStr = wsMLOG.Range("C" & i).Value & ".pdf"
                        If FileExists(pathStr & BACode & "\" & fileStr) Then
                            Mail.Attachments.Add pathStr & BACode & "\" & fileStr
                        Else
                            Mail.Delete
                        End If
                        On Error Resume Next
                        Mail.Close (olSave)
                        Set Mail = Nothing
                    End If
                End If
            End If
         Next
     End If
 
Upvote 0
Adding the solution I came up with incase someone gets a similar issue

Code: 
Public Timing As String
Public BACode As Variant

Sub DraftOutlookEmails()
    
'*******************************************************************
'Microsoft Outlook XX.X Object Library is required to run this code
'*******************************************************************

Dim objOutlook As Outlook.Application
Dim Mail As Outlook.MailItem
Dim lCounter As Long
Set objOutlook = Outlook.Application

Dim myNameSpace As Outlook.Namespace
Set myNameSpace = Outlook.GetNamespace("MAPI")

Dim wsMLOG As Excel.Worksheet
Set wsMLOG = Sheets("Master Log")
Dim rngTable1 As Excel.Range
Set rngTable1 = wsMLOG.Range("A4").CurrentRegion
Dim rngLessHeader As Excel.Range, rngRows As Long, rngRow1 As Long
Set rngLessHeader = gf_rngGet_TableData_Range(rngTable1)
Dim AdminWeek As Integer
Dim myFolder As Outlook.Folder
Dim myNewFolder As Outlook.Folder

BACode = InputBox("Enter BA Code")
AdminWeek = MsgBox("Admin Week?", vbYesNo)
UserForm1.Show vbModal

rngRows = rngLessHeader.Rows.Count
rngRow1 = rngLessHeader.Rows(1).Count

Dim pathStr As String
pathStr = "\\Insert Path Here"

Set myFolder = myNameSpace.GetDefaultFolder(olFolderDrafts)
Set myNewFolder = myFolder.Folders(BACode)
Dim fileStr As String
Dim fileStr2 As String
Dim mailAddress As String

Sheets("Master Log").Select
Dim i As Long
    

    If AdminWeek = vbNo Then
        For i = rngRow1 To rngRows
            If Cells(i, 5) = BACode Then
                If Cells(i, 7) = "E-mail" Then
                    If Cells(i, 9) = Timing Then
                        Set Mail = objOutlook.CreateItem(olMailItem)
                        Mail.To = wsMLOG.Range("L" & i).Value & ";" & wsMLOG.Range("M" & i).Value & ";" & wsMLOG.Range("N" & i).Value & ";" & wsMLOG.Range("O" & i).Value & ";" & wsMLOG.Range("P" & i).Value & ";" & wsMLOG.Range("Q" & i).Value & ";" & wsMLOG.Range("R" & i).Value & ";" & wsMLOG.Range("S" & i).Value & ";" & wsMLOG.Range("T" & i).Value & ";" & wsMLOG.Range("U" & i).Value & ";" & wsMLOG.Range("V" & i).Value & ";" & wsMLOG.Range("W" & i).Value & ";" & wsMLOG.Range("X" & i).Value & ";" & wsMLOG.Range("Y" & i).Value & ";" & wsMLOG.Range("Z" & i).Value & ";" & wsMLOG.Range("AA" & i).Value & ";" & wsMLOG.Range("AB" & i).Value
                        Mail.Subject = wsMLOG.Range("B" & i).Value & " " & wsMLOG.Range("C" & i).Value
                        Mail.Body = Sheets("Sheet1").Range("A1").Text
                        fileStr = wsMLOG.Range("C" & i).Value & ".pdf"
                        If FileExists(pathStr & BACode & "\" & fileStr) Then
                            Mail.Attachments.Add pathStr & BACode & "\" & fileStr
                        Else
                            Mail.Delete
                        End If
                        On Error Resume Next
                        Mail.Close (olSave)
                        Mail.Move myNewFolder
                        Set Mail = Nothing
                    End If
                End If
            End If
         Next
     End If
 
Upvote 0
You must log in or register to reply here.

Similar threads

larinda4
  • Question Question
VBA: Send Outlook Email & Attach PDF
Replies
1
Views
613
Trebor76
T
I
  • Question Question
Email via VBA in Excel
Replies
0
Views
316
ING Hammer
I
E
  • Question Question
Excel VBA to Outlook Email Draft - How to save email draft copy to sharepoint / How to use template from sharepoint?
Replies
0
Views
798
elitef
E
melodramatic
  • Question Question
VBA Send Outlook email, Save email to file folder
Replies
3
Views
2K
melodramatic
melodramatic
M
  • Question Question
VBA for sending all emails in outlook draft folder
Replies
8
Views
1K
Moustafa Houssien
M

Forum statistics

Threads
1,223,893
Messages
6,175,246
Members
452,623
Latest member
cliftonhandyman

Share this page

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Back
Top