Public xBook As Workbook
Public iSh As Worksheet




Sub EMAILLIST()

    Dim cell As Object
    Dim NR As Long
    Dim tagerror As String
    Dim Email_Send_To, Email_Send_From, Email_Subject, Email_Body As String
    Dim strUserEmail As String
    Dim strFirstClassPassword As String
    Dim errPar As String
    Dim iMsg As Object
    Dim iConfig As Object
    Dim sConfig As Variant
    Dim Row As Integer
    Dim Atc As String
    
    
    Set xBook = activeworkbook
    Set iSh = xBook.Sheets("INPUT")
    
        
    strUserEmail = xBook.Sheets("INPUT").Range("MMAIL")
    strFirstClassPassword = ""

    Set iMsg = CreateObject("CDO.Message")
    Set iConfig = CreateObject("CDO.Configuration")
    iConfig.Load -1
    Set sConfig = iConfig.Fields
        
        With sConfig
            .Item("http://schemas.microsoft.com/cdo/configuration/sendusing") = 2
            .Item("http://schemas.microsoft.com/cdo/configuration/smtpserver") = "192.168.0.5" 'Name or IP of remote SMTP server
            .Item("http://schemas.microsoft.com/cdo/configuration/smtpserverport") = 25  'Server Port
            .Item("http://schemas.microsoft.com/cdo/configuration/sendusername") = strUserEmail
            .Item("http://schemas.microsoft.com/cdo/configuration/sendpassword") = strFirstClassPassword
            .Update
        End With
     
With Application
    .ScreenUpdating = False
    .EnableEvents = False
End With
   

 '-----------------------------------------------------------------------------

    Email_Send_To = iSh.Range("AMAIL")
    Email_Send_From = iSh.Range("MMAIL")
    Email_Subject = "CHANGE REQUEST"
    Email_Body = "Dear " & iSh.Range("ANAME") & "," & vbNewLine & vbNewLine _
                & "Please complete this change request which was submitted by " & iSh.Range("MNAME") _
                & " on the " & Format(Now, "dd/mm/yyyy") & ". To complete this request please download the " _
                & "attached files to your desktop. If you only have a word document, please print this off, " _
                & "sign it and return it to HR. If there is also an excel sheet, once you have downloaded it " _
                & "open it and check the details. If you give permission for this change request, click the " _
                & "'Authorise' button. If you get a message saying unable to connect, then you must print off " _
                & "the word document and submit it to HR." & vbNewLine & vbNewLine _
                & "Any queries should be directed to your segment's HR team who will be happy to help." _
                & vbNewLine & vbNewLine _
                & "Kind regards," & vbNewLine & vbNewLine _
                & "HR"
                
    

'-----------------------------------------------------------------------------
         

    With iMsg
        Set .Configuration = iConfig
    End With
    
            iMsg.To = Email_Send_To
            iMsg.From = Email_Send_From
            iMsg.Subject = Email_Subject
            iMsg.Textbody = Email_Body
            iMsg.AddAttachment iSh.Range("PDESC")
            iMsg.Send
    
    Exit Sub

On Error GoTo tagerror


'clean_up:
'    With Application
'       .EnableEvents = True
'       .ScreenUpdating = True
'    End With
 

    
tagerror:
    MsgBox "Error: (" & Err.Number & ") " & Err.Description & " at " & Err.Source, vbCritical
    'Resume clean_up

    
End Sub

Sub OM_EmailToAviva()

'   =============================================================================================
'   This macro is the routine that is ran by the Fulfilment team on a daily basis.
'   =============================================================================================

    Dim AvivaAddress As String
    Dim OutApp, OutMail As Object
    Dim Sh As Worksheet

    Application.DisplayAlerts = False
    Application.ScreenUpdating = False
    
    AvivaAddress = "XXXXX"
    
    Set OutApp = CreateObject("Outlook.Application")
    OutApp.Session.Logon
    Set OutMail = OutApp.CreateItem(0)
    
    With OutMail
        .To = "" & AvivaAddress & ""
        .Subject = "OM Upload File: " & Format(Now, "dd-mmmm-yyyy")

'       =============================================================================================
'       These two options can be alternated between depending on the requirements.
        .Display
'       .Send
'       =============================================================================================
    End With

    Set OutMail = Nothing
    Set OutApp = Nothing
    
End Sub

Sub emailtest()

Dim TodayFile
Dim FileDate

Dim attachmnt2
Dim attachmnt
'Sends a specified range to a Outlook message and retains Excel formatting

'References needed :
'Microsoft Outlook Object Library := msoutl9olb
'Microsoft Scripting Runtime      := SCRRUN.DLL

'Dimension variables
'// ie. if Ol not installed then we need to Late bind & define as Obj
'// Use Late binding > Outlook.Application > olMail As Outlook.MailItem
'// Plus define olmailItem
Dim olApp As Object, olMail, olMailItem
Dim FSObj As Scripting.FileSystemObject, TStream As Scripting.TextStream
Dim rngeSend As Range, strHTMLBody As String

'On Error Resume Next

'Select the range to be sent
Set rngeSend = Range("B2:J32")

'Now create the HTML file
'// Changes by IFM
'// changed "C:\temp\sht.htm" to Dynamically get Sys Temp Dir
'// To cover the instance where Tmp Dir is NOT @ C:\
Dim SysTmp As String
SysTmp = TmpFolderLocation

ThisWorkbook.Sheets("sumpastetab").Range("A1").Select


ActiveWorkbook.PublishObjects.Add(xlSourceRange, SysTmp & "\sht.htm", _
    rngeSend.Parent.Name, rngeSend.Address, xlHtmlStatic).Publish True

'Create an instance of Outlook (or use existing instance if it already exists
Set olApp = CreateObject("Outlook.Application")

'Create a mail item
Set olMail = olApp.CreateItem(olMailItem)

'Open the HTML file using the FilesystemObject into a TextStream object
Set FSObj = New Scripting.FileSystemObject
Set TStream = FSObj.OpenTextFile(SysTmp & "\sht.htm", ForReading)

'Now set the HTMLBody property of the message to the text contained in the TextStream object
strHTMLBody = TStream.ReadAll

Worksheets("SumPasteTab").Activate
TodayFile = Range("Q27").Value
FileDate = Range("N2").Value

attachmnt = "S:\USA-HOUSTON\CPDS\GT FAMM\IctsOnline\Global Trading\Risk Control Daily Management Report\" & TodayFile & ".pdf"

attachmnt2 = "S:\USA-HOUSTON\CPDS\GT FAMM\IctsOnline\Global Trading\Risk Control Daily Management Report\" & "RMA GS&T Template-NEW BOOK STRUCTURE_TEST.pdf"


 

With olMail
    .To = "hlcu@chevron.com"
    .Subject = " Global DPR  " & Format(Date, "mm-dd-yyyy")
    '.Body = str & Application.Rept(Chr(13), 5) & str1 & Application.Rept(Chr(13), 5) & str2
    .HTMLBody = strHTMLBody
    .Attachments.Add (attachmnt) & (attachmnt2)
    .Display
    '.Send
End With
    
     
End Sub