Sleeper: Edit VBA code to let it automaticlly create Folder
ood 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 = "email******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
Reply With Quote
