Error 438 when calling outlook function from excel

Slimsteve · Oct 28, 2010

What I am trying to do is add a vba function to a excel sheet which allows a user to send an email on certain actions. I have setup the following in my outlook session which works fine and sends an email:

Code:

Option Explicit

Private Sub Application_Startup()

    'IGNORE - This forces the VBA project to open and be accessible
    '         using automation at any point after startup

End Sub

Public Function sjhsendemail() As Boolean

On Error GoTo ErrorHandler:

    Dim MAPISession As Outlook.NameSpace
    Dim MAPIFolder As Outlook.MAPIFolder
    Dim MAPIMailItem As Outlook.MailItem
    Dim oRecipient As Outlook.Recipient
    
    Dim TempArray() As String
    Dim varArrayItem As Variant
    Dim strEmailAddress As String
    Dim strAttachmentPath As String
    
    Dim blnSuccessful As Boolean

    Dim strto As String
    Dim strSubject As String
    Dim strMessageBody As String
        
    strto = "test@test.com"
    strSubject = "Test email"
    strMessageBody = "Hello"
    

    'Get the MAPI NameSpace object
    Set MAPISession = Application.Session
    
    If Not MAPISession Is Nothing Then

      'Logon to the MAPI session
      MAPISession.Logon , , True, False

      'Create a pointer to the Outbox folder
      Set MAPIFolder = MAPISession.GetDefaultFolder(olFolderOutbox)
      If Not MAPIFolder Is Nothing Then

        'Create a new mail item in the "Outbox" folder
        Set MAPIMailItem = MAPIFolder.Items.Add(olMailItem)
        If Not MAPIMailItem Is Nothing Then
          
          With MAPIMailItem

            'Create the recipients TO
                          Set oRecipient = .Recipients.Add(strto)
                        oRecipient.Type = olTo
                        Set oRecipient = Nothing
       
                
            'Set the message SUBJECT
                .Subject = strSubject
            
            'Set the message BODY (HTML or plain text)
                If StrComp(Left(strMessageBody, 6), "<HTML>", _
                            vbTextCompare) = 0 Then
                    .HTMLBody = strMessageBody
                Else
                    .Body = strMessageBody
                End If


            .Send 'The message will remain in the outbox if this fails

            Set MAPIMailItem = Nothing
            
          End With

        End If

        Set MAPIFolder = Nothing
      
      End If

      MAPISession.Logoff
      
    End If
    
    'If we got to here, then we shall assume everything went ok.
    blnSuccessful = True
    
ExitRoutine:
    Set MAPISession = Nothing
    sjhsendemail = blnSuccessful
    
    Exit Function
    
ErrorHandler:
    MsgBox "An error has occured in the user defined Outlook VBA function " & _
            "FnSendMailSafe()" & vbCrLf & vbCrLf & _
            "Error Number: " & CStr(Err.Number) & vbCrLf & _
            "Error Description: " & Err.Description, _
                vbApplicationModal + vbCritical
    Resume ExitRoutine

End Function

I have then added the following to the excel session to call the outlook function to send an email through outlook, but it keeps failing with error code 438 and I cannot see why, any ideas?

Code:

Option Explicit

'This is the procedure that calls the exposed Outlook VBA function...
Public Function FnSafeSendEmail() As Boolean

    Dim objOutlook As Object ' Note: Must be late-binding.
    Dim objNameSpace As Object
    Dim objExplorer As Object
    Dim blnSuccessful As Boolean
    Dim blnNewInstance As Boolean
    
    blnSuccessful = True
    
    'Is an instance of Outlook already open that we can bind to?
    On Error Resume Next
    Set objOutlook = GetObject(, "Outlook.Application")
    On Error GoTo 0
    
    If objOutlook Is Nothing Then
    
        'Outlook isn't already running - create a new instance...
        Set objOutlook = CreateObject("Outlook.Application")
        blnNewInstance = True
        'We need to instantiate the Visual Basic environment... (messy)
        Set objNameSpace = objOutlook.GetNamespace("MAPI")
        Set objExplorer = objOutlook.Explorers.Add(objNameSpace.Folders(1), 0)
        objExplorer.CommandBars.FindControl(, 1695).Execute
                
        objExplorer.Close
                
        Set objNameSpace = Nothing
        Set objExplorer = Nothing
        
    End If

   ' ---> Stops here !!!!!!!!!!!!!!!!!
    blnSuccessful = objOutlook.Run.sjhsendemail()
                                
    If blnNewInstance = True Then objOutlook.Quit
    Set objOutlook = Nothing
    
    FnSafeSendEmail = blnSuccessful
    
End Function

SkipVought · Oct 28, 2010

Hi,

You might try using CDO objects instead. You don't get the nasty outlook messages, for one thing...

Code:

Public Function CdoSend(MailTo As String, MailFrom As String, Subject As String, MessageText As String, Optional CC As String, Optional BCC As String, Optional FileAttachment As String) As Boolean
On Error GoTo CdoSend_Err

' This example use late binding, you don't have to set a reference
' You must be online when you run the sub
    Dim oMsg As Object
    Dim oConf As Object
    Dim Flds As Variant
 
    Set oMsg = CreateObject("CDO.Message")
    Set oConf = CreateObject("CDO.Configuration")
 
        oConf.Load -1    ' CDO Source Defaults
        Set Flds = oConf.Fields
        With Flds
            .Item("[URL unfurl="true"]http://schemas.microsoft.com/cdo/configuration/sendusing")[/URL] = 2
            .Item("[URL unfurl="true"]http://schemas.microsoft.com/cdo/configuration/smtpserver")[/URL] = [b]"YourMailServer.com"[/b]
            .Item("[URL unfurl="true"]http://schemas.microsoft.com/cdo/configuration/smtpserverport")[/URL] = 25
            .Update
        End With
 
    With oMsg
        Set .Configuration = oConf
        
        .To = MailTo
        .CC = CC
        .BCC = BCC
        .FROM = MailFrom
        
        .Subject = Subject
        .TextBody = MessageText

        
        If Len(FileAttachment & "") > 0 Then
            
            '## Last make sure the file actually exists and send it!:
            Dim fso
            Set fso = CreateObject("Scripting.FileSystemObject")
            If fso.FileExists(FileAttachment) Then
                .AddAttachment FileAttachment
            Else
                'otherwise return that the send failed and exit function:
                Debug.Print "[CdoSend.Error]=> File attachment path does not exist, quitting..."
                CdoSend = False
                Exit Function
            End If
        
        End If
    
        '## Send zee message! ##
        .sEnd
    
    End With

    Set fso = Nothing
    Set oMsg = Nothing
    Set oConf = Nothing
    
    CdoSend = True

CdoSend_Exit:
    Exit Function
    
CdoSend_Err:
    Debug.Print "[CdoSend.Error(" & Err.Number & ")]=> " & Err.Description
    CdoSend = False
    Resume CdoSend_Exit
End Function

Skip,
[sub]
[glasses]

Just traded in my old subtlety...
for a NUANCE! [tongue]

[/sub]

Tek-Tips is the largest IT community on the Internet today!

Members share and learn making Tek-Tips Forums the best source of peer-reviewed technical information on the Internet!

Error 438 when calling outlook function from excel

Slimsteve

Technical User

SkipVought

Programmer

Similar threads

Part and Inventory Search

Sponsor