Modified code to Send mail with two attachment.|VBA & Macros|Excel Forum|My Online Training Hub

this is the cod that I try to modify but not successes

Sub AZ()

Dim rng As Range
Dim olApp As Object
Dim NewMail As Object
Dim TempFilePath As String
Dim FileExt As String
Dim TempFileName As String
Dim FileFullPath As String
Dim FileFormat As Variant
Dim FolderName As String
Dim Wb1 As Workbook
Dim Wb2 As Workbook
Dim StrBody As String
Set rng = Nothing
On Error Resume Next
Set Wb1 = ThisWorkbook
ActiveSheet.Copy
Set Wb2 = ActiveWorkbook
With Application
.ScreenUpdating = False
.EnableEvents = False
End With

With Wb2
If Val(Application.Version) < 12 Then
FileExt = ".xls": FileFormat = -4143
Else
Select Case Wb1.FileFormat
Case 51: FileExt = ".xlsx": FileFormat = 51
Case 52:
If .HasVBProject Then
FileExt = ".xlsx": FileFormat = 51
Else
FileExt = ".xlsx": FileFormat = 51
End If
Case 56: FileExt = ".xls": FileFormat = 56
Case Else: FileExt = ".xlsx": FileFormat = 51

End Select
End If
End With

TempFilePath = Environ$("temp") & "\"

TempXLFileName = [SubMG]

TempPDFFileName = [TitMG] & ".pdf"

xlFileFullPath = TempFilePath & TempXLFileName & FileExt

pdfFileFullPath = TempFilePath & TempPDFFileName

Wb2.SaveAs xlFileFullPath, FileFormat:=FileFormat

With ActiveSheet
.ExportAsFixedFormat _
Type:=xlTypePDF, _
Filename:=pdfFileFullPath, _
Quality:=xlQualityStandard, _
IncludeDocProperties:=True, _
IgnorePrintAreas:=False, _
OpenAfterPublish:=False
End With

Set rng = Sheets("index").Range("J743:S760").SpecialCells(xlCellTypeVisible)

On Error GoTo 0

With Application
.EnableEvents = False
.ScreenUpdating = False
End With

Set olApp = CreateObject("Outlook.Application")
Set NewMail = olApp.CreateItem(0)

On Error Resume Next
With NewMail
.Subject = [SubMG]
.To = [toMG]
If [CCMG] <> "" Then .CC = [CCMG]
.HTMLBody = RangetoHTML(rng)
.Body = "This E-mail contains the morning report and has been created and sent automatically by the NAPEOFFWSD's Morning report software V 1.72" & vbLf & vbLf _
& "Regards," & vbLf _
& Application.UserName & vbLf & vbLf
.Attachments.Add xlFileFullPath
.Attachments.Add pdfFileFullPath
.send
Application.Visible = True
If Err Then
MsgBox "E-mail not sent", vbExclamation
Else
MsgBox "E-mail successfully Created, You may display your Morning report from your Outlook ... ", vbInformation
End If
End With
On Error GoTo 0

Wb2.Close savechanges:=False
Kill xlFileFullPath
Kill pdfFileFullPath

Set NewMail = Nothing
Set olApp = Nothing

With Application
.ScreenUpdating = True
.EnableEvents = True
End With
End Sub

Function RangetoHTML(rng As Range)

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"

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

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

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=")

TempWB.Close savechanges:=False

Kill TempFile

Set ts = Nothing
Set fso = Nothing
Set TempWB = Nothing
End Function

any update in previous issue ?

even if the same result come from another Code  

Good day purfleet

as you say I am not that good on coding but I try to learn and discuss with others.

you could find [SubMG] in DAILY OPS REPORT8!C362 and it should =index!EG147

regarding ("index") worksheet, its on the file before the macro create copy of ("DAILY OPS REPORT8") worksheet

Hi Philip

welcome back after 3 years, it was long time.

please I need your help to modify the code you made

the code work perfectly nice, but I want it to not ask me to select a folder where to save the files, I need to let the code automateclly save the files on "C:\Users\qaroosya\Documents\" & "yeaer" & "\" & "Month" which is "C:\Users\qaroosya\Documents\2023\November" 

So the code will create a folder of the year then will create a folder inside it for each month if the folder doesn't exist

if found the folder for the current month just save the files inside it and let the code do the remaining command