Send Emails when PC is locked

Hi all.

I have inherited a macro that gathers information and then sends an email if certain criteria are met with Outlook desktop. The system have been working flawlessly for sometime. We have noticed that the macro stops only when our windows 10 PC locks or goes to sleep. I did some researched and it appear the sendkeys won't allow email to be sent when the PC is locked.

I read somewhere that I could use windows scheduler to create a process to send at certain intervals. Because of our group policys on our system, Scheduler is disabled. Besides, we need the macro to send emails immediately.

Is there another method that I can use to get emails to be send whether or not the PC is locked? Below is the working code stored in an excel class module.

'---------------------------------------------------------------------------------------------------------------------
'Class: Email
'
'   Description:    Holds information and methods used to create and send emails.
'   Instructions:   Create an email class object, assign variables, and use methods.
'                   Using the class helps standardize the look of each email and makes updating easier.
'---------------------------------------------------------------------------------------------------------------------


'***********************************************************************************
'EMAIL PROPERTIES
'***********************************************************************************
Private pTo As String               '"To" line
Private pFrom As String             '"From" line
Private pCC As String               '"CC" line
Private pBCC As String              '"BCC" line
Private pMessageTitle As String     'Header of the message; first line of the body.
Private pBody As String             'Body of the message.
Private pSubject As String          'Subject

Private pCopyAdmins As Boolean      'Copy the portal admins on the message? (Resets, etc.)

Public Property Get ToLine() As String
    ToLine = pTo
End Property
Public Property Let ToLine(Value As String)
    pTo = Value
End Property

Public Property Get Subject() As String
    Subject = pSubject
End Property
Public Property Let Subject(Value As String)
    pSubject = Value
End Property

Public Property Get FromLine() As String
    FromLine = pFrom
End Property
Public Property Let FromLine(Value As String)
    pFrom = Value
End Property

Public Property Get CCLine() As String
    CCLine = pCC
End Property
Public Property Let CCLine(Value As String)
    pCC = Value
End Property

Public Property Get BCCLine() As String
    BCCLine = pBCC
End Property
Public Property Let BCCLine(Value As String)
    pBCC = Value
End Property

Public Property Get MessageTitle() As String
    MessageTitle = pMessageTitle
End Property
Public Property Let MessageTitle(Value As String)
    pMessageTitle = Value
End Property

Public Property Get Body() As String
    Body = pBody
End Property
Public Property Let Body(Value As String)
    pBody = Value
End Property

Public Property Get CopyAdmins() As Boolean
    CopyAdmins = pCopyAdmins
End Property
Public Property Let CopyAdmins(Value As Boolean)
    pCopyAdmins = Value
End Property




'***********************************************************************************
'EMAIL METHODS
'***********************************************************************************

'Create an Outlook Email object.
Public Sub CreateEmail()

    Dim oLookApp As Object, oLookMail As Object, btime As String, ptype As String
    Application.DisplayAlerts = False
    
    On Error GoTo EmailError
    
    Set oLookApp = CreateObject("Outlook.Application")
    Set oLookMail = oLookApp.CreateItem(0)
    
    With oLookMail
        .To = pTo
        
        If pFrom <> "" Then
            .SentOnBehalfOfName = pFrom
        End If
        
        If pCC <> "" Then
            .CC = pCC
        End If
        
        If pBCC <> "" Then
            .BCC = pBCC
        End If
        
        If CopyAdmins = True Then
            .CC = PortalAdminAddr
        End If
        
        .Subject = pSubject
        
        .Body = pMessageTitle & vbLf & vbLf & pBody
        
        .display
        
        .send
        
    End With
    
Exit Sub

EmailError:
        MsgBox "Cannot open Outlook due to an error.  Please contact System Admin." & vbCrLf & _
        "Thank you.", vbOKOnly, "Outlook Error"
        
        Application.DisplayAlerts = True
    
End Sub


'Send email
Public Sub SendEmail()

    SendKeys "%{s}", True

End Sub

Sorry, that last piece of code is being used for something else. Still the sub CreateEmail, generates the email but won't send while the PC is locked.

Try commenting out the .Display line. If that doesn't work I will try to set up a test that is like what you are doing.

I am so sorry.. I inherited this and this is not my strongest field at all. It looks like I was interpreting the code wrong. Below is the code that I missed. Looks like it was using both the CreateEmail and SendEmail sub. Perhaps this method was used to get around the outlook prompts. We decided to not use outlook at all and just use CDO method. I tested the CDO and that work on a test. Can you by chance help me incorporate the CDO method for this instead of using Outlook and perhaps we will be able to send while the system is locked?

Private Function NewCaseToDatabase(ByRef oCase As cls_RMCase) ' As Boolean
    If oCase.IsEmpLoan = True Then
    
        ufPortalServices.txtIntAppLog.Value = ufPortalServices.txtIntAppLog.Value & "     " & oCase.CaseNo & " is an employee loan." & vbCrLf
        
        Dim oEmail As cls_Email
        Set oEmail = New cls_Email
        
        oEmail.ToLine = "lendingEmailAddress”
        oEmail.Subject = "New Employee Loan Application"
        oEmail.MessageTitle = "Employee Loan, Case #: " & oCase.CaseNo & vbCrLf
        oEmail.Body = "Case Data: " & vbCrLf & vbCrLf & oCase.CaseData
        oEmail.CreateEmail
        oEmail.SendEmail
         
        ufPortalServices.txtIntAppLog.Value = ufPortalServices.txtIntAppLog.Value & "     " & oCase.CaseNo & " was forwarded to the employee lending inbox." & vbCrLf
    
        Exit Function
    End If

Thank you... It won't let me post CDO code because it said I could post anything with links which the code contains. Perhaps I can send another way?

Hi the caseNo is a numeric value and we are using in-house server.

Thanks

That is the code I need help with incorporating into my existing code and didn't know how to do so. I tested it and it work to send in a separate workbook, but don't know how to replace it with mine without messing up things. Thanks

I am so excited and grateful to you guys. The solution below worked. Thank you so much.

Originally Posted by CK76

Did it work as is when you use his code? Without incorporating into your code. You should check that before you implement to existing code.

If it does it would be something like... Note that it's independent from your EMail class module.

Private Function NewCaseToDatabase(ByRef oCase As cls_RMCase)

    If oCase.IsEmpLoan = True Then
        ufPortalServices.txtIntAppLog.Value = ufPortalServices.txtIntAppLog.Value & "     " & oCase.CaseNo & " is an employee loan." & vbCrLf
        Dim iMsg As Object
        Dim iConf As Object
        Dim strbody As String
        Dim Flds As Variant
        Set iMsg = CreateObject("CDO.Message")
        Set iConf = CreateObject("CDO.Configuration")

        iConf.Load -1    ' CDO Source Defaults
        Set Flds = iConf.Fields
        With Flds
            .Item("http://schemas.microsoft.com/cdo/configuration/sendusing") = 2
            .Item("http://schemas.microsoft.com/cdo/configuration/smtpserver") = "Fill in your SMTP server here"
            .Item("http://schemas.microsoft.com/cdo/configuration/smtpserverport") = 25
            .Update
        End With

        strbody = "Case Data: " & vbCrLf & vbCrLf & oCase.CaseData

        With iMsg
            Set .Configuration = iConf
            .To = "lendingEmailAddress"
            .CC = ""
            .BCC = ""
            .From = "SenderEmailAddress"
            .Subject = "New Employee Loan Application"
            .TextBody = "Employee Loan, Case #: " & oCase.CaseNo & vbCrLf & vbCrLf & vbCrLf & strbody
            .Send
        End With
        ufPortalServices.txtIntAppLog.Value = ufPortalServices.txtIntAppLog.Value & "     " & oCase.CaseNo & " was forwarded to the employee lending inbox." & vbCrLf
        Set iMsg = Nothing
        Set iConf = Nothing
        Set Flds = Nothing
        Exit Function
    End If
End Function

The problem seems to be with windows 10.
I have tried this at work and I keep getting errors no matter what I try.

When the pc locks or sleep mode, it won't run.

Read this for deeper insight.

https://www.thespreadsheetguru.com/b...a-macros-daily


https://support.microsoft.com/en-us/...tion-of-office