Mustafa elkarim
New Member
- Joined
- Nov 25, 2019
- Messages
- 6
- Office Version
- 2016
- Platform
- Windows
Sub Email()
Set OutApp = GetObject(, "Outlook.Application")
Dim IsCreated As Boolean
Dim i As Long
Dim ab, ac, ad, emTo, emCC As String
Dim PdfFile As String, Title As String
Dim OutlApp As Object
Application.ScreenUpdating = False
LoginName = UCase(GetUserID)
Worksheets("DB").Visible = True
Sheets("DB").Select
Range("AM5").Select
Selection.Copy
Range("AW8").Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Worksheets("DB").Visible = xlSheetVeryHidden
Sheets("PDF").Visible = True
Sheets("PDF").Select
ActiveSheet.Shapes.Range(Array("Picture 3")).Select
Selection.ShapeRange.Width = 72.72
PdfFile = ActiveWorkbook.FullName
i = InStrRev(PdfFile, ".")
If i > 1 Then PdfFile = Left(PdfFile, i - 1)
emTo = Worksheets("DB").Range("B10").Value
emCC = Worksheets("DB").Range("B14").Value
ab = Worksheets("DB").Range("AP25").Value
' Not sure for what the Title is
Title = " - " & Sheets("DB").Range("D6")
titlef = Sheets("DB").Range("D6") & " - " & Sheets("PDF").Range("F8") & " - " & Format(ab, "ddd dd-mmm-yyyy")
i = InStrRev(PdfFile, ".")
If i > 1 Then PdfFile = Left(PdfFile, i - 1)
PdfFile = "C:\Users\" & LoginName & "\Desktop\" & Sheets("DB").Range("D6") & " - " & Sheets("PDF").Range("F8") & ".pdf"
'Specify the worksheet name
Sheets("PDF").Activate
ActiveSheet.UsedRange.Select
'ThisWorkbook.Sheets(Array("PDF")).Select
Set xsht = ThisWorkbook.Sheets("PDF")
xsht.ExportAsFixedFormat Type:=xlTypePDF, _
Filename:=PdfFile, _
Quality:=xlQualityStandard, _
IncludeDocProperties:=True, _
IgnorePrintAreas:=False, _
OpenAfterPublish:=False
' Use already open Outlook if possible
On Error Resume Next
Set OutlApp = GetObject(, "Outlook.Application")
If Err Then
Set OutlApp = CreateObject("Outlook.Application")
IsCreated = True
End If
OutlApp.Visible = True
On Error GoTo 0
' Prepare e-mail with PDF attachment
With OutlApp.CreateItem(0)
' Prepare e-mail
.Subject = titlef
.To = emTo ' <-- Put email of the recipient here
.cc = emCC ' <-- Put email of 'copy to' recipient here
.HTMLBody = "Greetings, " & vbLf & vbLf _
& "<p> The attachment here displays the results of the candidate: " & Sheets("pdf").Range("f8") & vbLf _
& "<p> Please open the attachment to see the number of correct and answers and correct the 5 essay questions." & vbLf _
& "<p><i>FYI: The candidate spent " & Sheets("DB").Range("AT25") & " hours & " & Sheets("DB").Range("AT26") & " minutes and got " & Sheets("PDF").Range("E11") & " correct answers in the MCQs.</i>" & vbLf & vbLf _
& "<p><p>All the Best,<br>" & vbLf _
& " " & vbLf & vbLf
.Attachments.Add PdfFile
' Try to send
On Error Resume Next
Set .SendUsingAccount = OutlApp.Session.Accounts.Item(1) 'Use 2nd Account in the list
.DISPLAY
Application.Wait (Now + TimeValue("0:00:01"))
Application.SendKeys "%s"
Application.Visible = True
On Error GoTo 0
End With
' Delete PDF file
Kill PdfFile
' Quit Outlook if it was created by this code
If IsCreated Then OutlApp.Quit
' Release the memory of object variable
Set OutlApp = Nothing
Worksheets("PDF").Visible = xlSheetVeryHidden
Application.ScreenUpdating = True
End Sub
Set OutApp = GetObject(, "Outlook.Application")
Dim IsCreated As Boolean
Dim i As Long
Dim ab, ac, ad, emTo, emCC As String
Dim PdfFile As String, Title As String
Dim OutlApp As Object
Application.ScreenUpdating = False
LoginName = UCase(GetUserID)
Worksheets("DB").Visible = True
Sheets("DB").Select
Range("AM5").Select
Selection.Copy
Range("AW8").Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Worksheets("DB").Visible = xlSheetVeryHidden
Sheets("PDF").Visible = True
Sheets("PDF").Select
ActiveSheet.Shapes.Range(Array("Picture 3")).Select
Selection.ShapeRange.Width = 72.72
PdfFile = ActiveWorkbook.FullName
i = InStrRev(PdfFile, ".")
If i > 1 Then PdfFile = Left(PdfFile, i - 1)
emTo = Worksheets("DB").Range("B10").Value
emCC = Worksheets("DB").Range("B14").Value
ab = Worksheets("DB").Range("AP25").Value
' Not sure for what the Title is
Title = " - " & Sheets("DB").Range("D6")
titlef = Sheets("DB").Range("D6") & " - " & Sheets("PDF").Range("F8") & " - " & Format(ab, "ddd dd-mmm-yyyy")
i = InStrRev(PdfFile, ".")
If i > 1 Then PdfFile = Left(PdfFile, i - 1)
PdfFile = "C:\Users\" & LoginName & "\Desktop\" & Sheets("DB").Range("D6") & " - " & Sheets("PDF").Range("F8") & ".pdf"
'Specify the worksheet name
Sheets("PDF").Activate
ActiveSheet.UsedRange.Select
'ThisWorkbook.Sheets(Array("PDF")).Select
Set xsht = ThisWorkbook.Sheets("PDF")
xsht.ExportAsFixedFormat Type:=xlTypePDF, _
Filename:=PdfFile, _
Quality:=xlQualityStandard, _
IncludeDocProperties:=True, _
IgnorePrintAreas:=False, _
OpenAfterPublish:=False
' Use already open Outlook if possible
On Error Resume Next
Set OutlApp = GetObject(, "Outlook.Application")
If Err Then
Set OutlApp = CreateObject("Outlook.Application")
IsCreated = True
End If
OutlApp.Visible = True
On Error GoTo 0
' Prepare e-mail with PDF attachment
With OutlApp.CreateItem(0)
' Prepare e-mail
.Subject = titlef
.To = emTo ' <-- Put email of the recipient here
.cc = emCC ' <-- Put email of 'copy to' recipient here
.HTMLBody = "Greetings, " & vbLf & vbLf _
& "<p> The attachment here displays the results of the candidate: " & Sheets("pdf").Range("f8") & vbLf _
& "<p> Please open the attachment to see the number of correct and answers and correct the 5 essay questions." & vbLf _
& "<p><i>FYI: The candidate spent " & Sheets("DB").Range("AT25") & " hours & " & Sheets("DB").Range("AT26") & " minutes and got " & Sheets("PDF").Range("E11") & " correct answers in the MCQs.</i>" & vbLf & vbLf _
& "<p><p>All the Best,<br>" & vbLf _
& " " & vbLf & vbLf
.Attachments.Add PdfFile
' Try to send
On Error Resume Next
Set .SendUsingAccount = OutlApp.Session.Accounts.Item(1) 'Use 2nd Account in the list
.DISPLAY
Application.Wait (Now + TimeValue("0:00:01"))
Application.SendKeys "%s"
Application.Visible = True
On Error GoTo 0
End With
' Delete PDF file
Kill PdfFile
' Quit Outlook if it was created by this code
If IsCreated Then OutlApp.Quit
' Release the memory of object variable
Set OutlApp = Nothing
Worksheets("PDF").Visible = xlSheetVeryHidden
Application.ScreenUpdating = True
End Sub