PERSL
11-22-2023, 04:52 AM
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
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