Good day all

I have the below code wich is working totally perfect.

which is take the worksheet and save it as pdf and xls format and before that the code ask me to specify the destination folder

then the code attach both file on new outlook mail

I need the code do do all the same but automaticlly create and select the distenation folder "C:UsersqaroosyaDocuments2023" and create a folder for each month

Sub Acreatepdf()

Dim EmailSubject As String, EmailSignature As String

Dim CurrentMonth As String, DestFolder As String, PDFFile As String

Dim Email_To As String, Email_CC As String, Email_BCC As String

Dim OpenPDFAfterCreating As Boolean, AlwaysOverwritePDF As Boolean, DisplayEmail As Boolean

Dim OverwritePDF As VbMsgBoxResult

Dim OutlookApp As Object, OutlookMail As Object

Dim NewWB As Workbook

Dim ActiveWS As Worksheet

Dim Qaroos As String

Qaroos = "WSX"

CurrentMonth = ""

Set ActiveWS = ActiveSheet

Application.CalculateFullRebuild

Application.ScreenUpdating = False

Application.DisplayAlerts = False

Application.EnableEvents = False

ActiveSheet.PageSetup.PrintArea = "Qpmr"

' **************************************************

' ** You Can Change These Variables ******

EmailSubject = [SubMG] 'Change this to change the subject of the email. The current month is added to end of subj line

OpenPDFAfterCreating = False 'Change this if you want to open the PDF after creating it : TRUE or FALSE

AlwaysOverwritePDF = False 'Change this if you always want to overwrite a PDF that already exists :TRUE or FALSE

DisplayEmail = True 'Change this if you don't want to display the email before sending. Note, you must have a TO email address specified for this to work

Email_To = "[email protected]" 'Change this if you want to specify To email e.g. ActiveSheet.Range("H1") to get email from cell H1

 

Email_CC = [CCMG]

Email_BCC = ""

' ***************************************************

'Prompt for file destination

With Application.FileDialog(msoFileDialogFolderPicker)

If .Show = True Then

DestFolder = .SelectedItems(1)

Else

MsgBox "You must specify a folder to save the PDF into." & vbCrLf & vbCrLf & "Press OK to exit this macro.", vbCritical, "Must Specify Destination Folder"

Exit Sub

End If

End With

'Current month/year stored in H6 (this is a merged cell)

CurrentMonth = Mid(ActiveSheet.Range("H6").Value, InStr(1, ActiveSheet.Range("H6").Value, " ") + 1)

'Create new PDF file name including path and file extension

PDFFile = DestFolder & Application.PathSeparator & [TitMG] & ".pdf"

'If the PDF already exists

If Len(Dir(PDFFile)) > 0 Then

If AlwaysOverwritePDF = False Then

OverwritePDF = MsgBox(PDFFile & " already exists." & vbCrLf & vbCrLf & "Do you want to overwrite it?", vbYesNo + vbQuestion, "File Exists")

On Error Resume Next

'If you want to overwrite the file then delete the current one

If OverwritePDF = vbYes Then

Kill PDFFile

Kill Replace(PDFFile, ".pdf", ".xlsx")

Else

MsgBox "OK then, if you don't overwrite the existing PDF, I can't continue." _

& vbCrLf & vbCrLf & "Press OK to exit this macro.", vbCritical, "Exiting Macro"

Exit Sub

End If

Else

On Error Resume Next

Kill PDFFile

Kill Replace(PDFFile, ".pdf", ".xlsx")

End If

If Err.Number <> 0 Then

MsgBox "Unable to delete existing file. Please make sure the file is not open or write protected." _

& vbCrLf & vbCrLf & "Press OK to exit this macro.", vbCritical, "Unable to Delete File"

Exit Sub

End If

End If

'Create the PDF

ActiveWS.ExportAsFixedFormat Type:=xlTypePDF, Filename:=PDFFile, Quality:=xlQualityStandard, IncludeDocProperties:=True, IgnorePrintAreas _

:=False, OpenAfterPublish:=OpenPDFAfterCreating

Set NewWB = Workbooks.Add

ActiveWS.copy Before:=NewWB.Sheets(1)

NewWB.SaveAs Replace(PDFFile, ".pdf", ".xlsx")

NewWB.Close

'Create an Outlook object and new mail message

Set OutlookApp = CreateObject("Outlook.Application")

Set OutlookMail = OutlookApp.CreateItem(0)

'Display email and specify To, Subject, etc

With OutlookMail

.To = Email_To

.CC = Email_CC

.BCC = Email_BCC

.Subject = [SubMG]

.Attachments.Add PDFFile

.Attachments.Add Replace(PDFFile, ".pdf", ".xlsx")

.HTMLBody = RangetoHTML(Sheets("Index").Range("AF564:AW632"))

.Display

Application.DisplayAlerts = True

Application.EnableEvents = True

If Err Then

MsgBox "E-mail not created", vbExclamation

Else

MsgBox "E-mail successfully Created, You may display your Morning report from your Outlook for final check ... ", vbInformation

End If

If DisplayEmail = False Then

If Sheets("Index").Range("AG561").Value = "Timer" Then

Application.OnTime TimeValue("AI561").Value, Procedure:="MYcode"

Else

End If

End If

End With

ActiveSheet.Unprotect Qaroos

 

If ActiveSheet.Range("Z3").Value = "S" Then

 

For Each Pr In ActiveSheet.Pictures

If Not Intersect(Pr.TopLeftCell, Range("K17:V33,K66:V82,K114:V130,K161:V178,K210:V226,K257:V273,K304:V320,K350:V366")) Is Nothing Then

Pr.Delete

End If

Next Pr

For Each Pr In ActiveSheet.Pictures

If Not Intersect(Pr.BottomRightCell, Range("K17:V33,K66:V82,K114:V130,K161:V178,K210:V226,K257:V273,K304:V320,K350:V366")) Is Nothing Then

Pr.Delete

End If

Next Pr

Call histor

Call seplit

Call Updateuncoplatedjob

Call Clearreport

Call indexclear

 

Sheets("DAILY OPS REPORT8").Select

Application.ScreenUpdating = True

ActiveSheet.Protect Qaroos, DrawingObjects:=False, Contents:=True, Scenarios:=True _

, AllowFormattingCells:=True, AllowFormattingRows:=True, _

AllowFormattingColumns:=False, AllowInsertingColumns:=False, _

AllowInsertingRows:=False, AllowInsertingHyperlinks:=False, _

AllowDeletingColumns:=False, AllowDeletingRows:=False, _

AllowSorting:=False, AllowFiltering:=False, AllowUsingPivotTables:=False

MsgBox (" " & ActiveSheet.Range("D1").Value & " Empty Morning report ready to use.")

 

Else

 

Call histor

Call seplit

Call Updateuncoplatedjob

Call Clearreport

Call indexclear

Sheets("DAILY OPS REPORT8").Select

Application.ScreenUpdating = True

ActiveSheet.Protect Qaroos, DrawingObjects:=True, Contents:=True, Scenarios:=True _

, AllowFormattingCells:=True, AllowFormattingRows:=True

Application.ScreenUpdating = True

MsgBox (" " & ActiveSheet.Range("D1").Value & " Empty Morning report ready to use")

 

End If

 

ThisWorkbook.Save

 

End Sub

Function RangetoHTML(Rng As Range)

' Working in Office 2000-2016

Dim fso As Object

Dim ts As Object

Dim TempFile As String

Dim TempWB As Workbook

TempFile = Environ$("temp") & "" & Format(Now, "dd-mm-yy h-mm-ss") & ".htm"

'Copy the range and create a new workbook to past the data in

Rng.copy

Set TempWB = Workbooks.Add(1)

With TempWB.Sheets(1)

.Cells(1).PasteSpecial Paste:=8

.Cells(1).PasteSpecial xlPasteValues, , False, False

.Cells(1).PasteSpecial xlPasteFormats, , False, False

.Cells(1).Select

Application.CutCopyMode = False

On Error Resume Next

.DrawingObjects.Visible = True

.DrawingObjects.Delete

On Error GoTo 0

End With

'Publish the sheet to a htm file

With TempWB.PublishObjects.Add( _

SourceType:=xlSourceRange, _

Filename:=TempFile, _

Sheet:=TempWB.Sheets(1).Name, _

Source:=TempWB.Sheets(1).UsedRange.Address, _

HtmlType:=xlHtmlStatic)

.Publish (True)

End With

'Read all data from the htm file into RangetoHTML

Set fso = CreateObject("Scripting.FileSystemObject")

Set ts = fso.GetFile(TempFile).OpenAsTextStream(1, -2)

RangetoHTML = ts.readall

ts.Close

RangetoHTML = Replace(RangetoHTML, "align=center x:publishsource=", _

"align=left x:publishsource=")

'Close TempWB

TempWB.Close SaveChanges:=False

'Delete the htm file we used in this function

Kill TempFile

Set ts = Nothing

Set fso = Nothing

Set TempWB = Nothing

End Function