Edit VBA code to let it automaticlly create Folder

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:\Users\qaroosya\Documents\2023" 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 = "Qtest****com"   '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