Save .oft files at specific location with specific name using Excel Macros

[vinayuppalapati]

[FONT=&quot]We use Excel macros for mail merge.[/FONT]
[FONT=&quot]> We update to , from, subject, template address, attachment address, names, in the excel sheet and run the macro.[/FONT]
[FONT=&quot]> This will create draft copy of the messages in the outlook drafts folder.[/FONT]
[FONT=&quot]> We then individually save the draft messages to OFTs segregate as per the teams and send them to the team leads who in-turn send actual communication to the end user.[/FONT]
[FONT=&quot]
[/FONT]
[FONT=&quot]This entire process takes us around 16 hours as we have to save 100s of oft files.[/FONT]
[FONT=&quot]
[/FONT]
[FONT=&quot]I want to check if the existing macros in the excel can be modified so that it directly saves the oft files with the names and path specified in excel columns.[/FONT]
[FONT=&quot]
[/FONT]
[FONT=&quot]If we can achieve this, we will be able to complete the task in less than an hour which usually takes 16 hours.[/FONT]
[FONT=&quot]
[/FONT]
[FONT=&quot]Any help on this is much appreciated. Below is the current macros code.

[COLOR=#222222][FONT=&quot]Option Explicit[/FONT][/COLOR][/FONT][/COLOR]
[FONT=&quot]Sub Send_Emails()        Dim Out_App As Object, Mac As Object, Out_Mail As Object, Template As String, path As String    Dim MailItem As Variant    Dim Mails_to_Send As Integer, To_Col As Integer, Cc_Col As Integer, Attach1 As Integer, Attach2 As Integer, Sub_Col As Integer, Mail_Temp As Integer, From_Col As Integer, Bcc_Col As Integer, Ad_ResourceName As Integer, Barcode_Name As Integer, DueDate As Integer, Patronname_Name As Integer, Costdetails As Integer    Dim i As Integer, Col_Cnt As Integer, j As Integer        Set Out_App = CreateObject("Outlook.Application")    Set Out_Mail = Out_App.CreateItem(MailItem)    Set Mac = ThisWorkbook.Sheets("Macro")        Mails_to_Send = Mac.Cells(Rows.Count, 2).End(xlUp).Row    Col_Cnt = Mac.Cells(5, Columns.Count).End(xlToLeft).Column        To_Col = Mac.Rows(5).Find("To", lookat:=xlWhole).Column    Cc_Col = Mac.Rows(5).Find("Cc", lookat:=xlWhole).Column    Sub_Col = Mac.Rows(5).Find("Subject", lookat:=xlWhole).Column    Mail_Temp = Mac.Rows(5).Find("Email template", lookat:=xlWhole).Column    From_Col = Mac.Rows(5).Find("From Mailbox", lookat:=xlWhole).Column    Bcc_Col = Mac.Rows(5).Find("Bcc", lookat:=xlWhole).Column        On Error GoTo Err_Des    For i = 6 To Mails_to_Send        If Mac.Cells(i, To_Col).Value <> "" Then            Template = VBA.Trim(Mac.Cells(i, Mail_Temp).Value)            Set Out_Mail = Out_App.CreateItemFromTemplate(Template)            With Out_Mail                .To = Mac.Cells(i, To_Col).Value                If Mac.Cells(i, Cc_Col).Value <> "" Then                    .CC = Mac.Cells(i, Cc_Col).Value                End If                If Mac.Cells(i, Bcc_Col).Value <> "" Then                    .BCC = Mac.Cells(i, Bcc_Col).Value                End If                If Mac.Cells(i, From_Col).Value <> "" Then                    .SentOnBehalfOfName = Mac.Cells(i, From_Col).Value                End If                For j = 1 To Col_Cnt                    If InStr(VBA.Trim(Mac.Cells(5, j).Value), "Attachment") > 0 Then                        If Mac.Cells(i, j).Value <> "" Then                            .Attachments.Add VBA.Trim(Mac.Cells(i, j).Value)                        End If                    End If                Next                .Subject = Mac.Cells(i, Sub_Col).Value                For j = Mail_Temp + 1 To Col_Cnt                    .HTMLBody = Replace(.HTMLBody, Mac.Cells(5, j).Value, Mac.Cells(i, j))                Next            'ans = MsgBox("Do you want to send the emails or save it in drafts", vbYesNo)            'If ans = "Yes" Then                Out_Mail.Save            'Else             '   Out_Mail.Save '"Please make sure to keep your outlook in offline mode"            'End If            End With        End If    Next    MsgBox ("Please check your drafts folder")    Exit Sub    Err_Des:        MsgBox Err.Description, vbCritical [/FONT][COLOR=#1C1C1C][FONT=&quot][COLOR=#222222][FONT=&quot]End Sub[/FONT][/COLOR]

[/FONT]