Another email question using Outlook and VBA

[CD Tom]

I've been fighting this outlook problem and have finally figured out why the reference is missing when a person doesn't have outlook installed.
I have Office 365 on my development machine, and this has been the problem all along. Office 365 puts outlook in a different directory than all other version of Outlook. With Office 365 outlook if placed in a directory Program files(x86)\Microsoft office/root/office 16 and that was the reference my program was look at. I've switched back to Outlook 2007 and now the reference is pointing to c:\program files (x86)\Microsoft office\office12 and it seems like nobody gets the reference.
My development machine still has Outlook 365 on it but the program will not send out mail if Outlook is running, if I close Outlook and then run the email part of the program it will send out all email.
I'm using the following code

Const Err_APP_NOTRUNNING As Long = 429
Dim cdomsg As Object
Dim Vres As String
Dim stdmsg As String
Dim myItem As Object
Dim strFullPath As String
Dim strFilename As String
Dim VUserName As String
Dim VPassword As String
Dim EMailMsg As String
Dim strAttachPath As Variant
Dim intAttachments As Integer
Dim myObject As Outlook.Application
On Error Resume Next
Set myObject = GetObject(, "outlook.application")
If Err = Err_APP_NOTRUNNING Then
    Set myObject = CreateObject("outlook.Application")
End If
Set myItem = myObject.CreateItem(0)

There is more code but this is where I think the problem is.

When Outlook is running and the code gets to the set myObject = GetObject(, "outlook.application") tf sets there for maybe 30 seconds and then goes to the next statement but the myObject is set to nothing, and no emails are sent.
I guess my question is why can't I send email out when Outlook is running.
Thanks for lessoning to my rambling

[NeoPa]

I'm confused Tom. You explain about the folder where the Outlook executable is found then you as a question entirely unrelated to that (going by the posted code at least). What's the actual problem you'd like us to focus on?

[CD Tom]

Sorry about the confusion. I'm just frustrated with MS and the problems I'm having.
My problem is when I try and send emails out through my program if Outlook is running the emails are not sent, they don't even go into the outbox. However if Outlook isn't running then emails are sent out fine.
Like I mentioned in the first post. When outlook is running the Set MyObject = GetObject(, "Outlook.application') shows "Nothing" but when Outlook isn't running it shows Outlook.
Is there a way to have the email be sent if Outlook is running.

[twinnyfo]

Tom,

Have you tried looking at this article: Sending e-mails via MS Outlook? It is a slightly different approach, but I’ve never had to worry about the path in which the application resides.

[zmbd]

Look at line 13:
Dim myObject As Outlook.Application
and then at line 15:
Set myObject = GetObject(, "outlook.application")
Are you're trying to use late binding in your code? It's not quite fulling implemented for late binding and that may be part of the issue(s) you're having.

I don't normally post whole code; however, given that you've already been pounding your head against the wall, here's the email code template I use, and is currently in a dozen of my production databases so it should work well in yours. I've borrowed the basic framework from a few different places :).
... notice I have it as part of a command button click event :)

Also I prefer the late bind for this because often the company will incrementally role out updates... for example, half the plant is now on Office 2016 while the rest of us are on Office 2013 - IT actually comes out and pulls our PC and installs a new one when we do office version updates, IDK why, but it's a PITA and sounds a bit like what you are running into...

Private Sub CmdBtnSendEmail_Click()
    'Use following Dim statements for Late Binding
    'NOTE: Additional Const declaration
    Dim objOutlook As Object    'Outlook.Application  (Note dimensioned as Object)
    Dim objEmail As Object      'Outlook.MailItem     (Note dimensioned as Object)
    Dim objNameSpace As Object  'Outlook.NameSpace    (Note dimensioned as Object)
    Const olMailItem As Long = 0    'For Late Binding
    Const olFolderInbox As Long = 6 'For Late Binding
    Const olFormatHTML As Long = 2  'For Late Binding
    Dim strSubject As String
    Dim strAddress As String
    Dim strToAddress As String
 
    On Error GoTo zErrorTrap
    Set objOutlook = GetObject(, "Outlook.Application")
 
    If objOutlook Is Nothing Then
        Set objOutlook = CreateObject("Outlook.Application")
        Set objNameSpace = objOutlook.GetNamespace("MAPI")
        objNameSpace.GetDefaultFolder(olFolderInbox).Display
    End If
 
    Set objEmail = objOutlook.CreateItem(olMailItem)
 
    strSubject = "My Test Message"
    strToAddress = "[e-mail]"
 
    With objEmail
 
        .To = strToAddress  'Removed for privacy
 
        .Subject = strSubject
 
        .BodyFormat = olFormatHTML
 
        'uncomment to show the email and allow the user to edit before sending.
        .Display
        '
        'comment out display to send without visual
        '.Send
 
        'Full Name of window can change depending on Tools -> Options -> Mail Format
        'Changing this option for outgoing mail changes the window name.
        'However, AppActivate appears not to require entire name but needs up to end
        'of - Message which is included in heading following the Subject string
        'irrespective of the Mail Format option chosen.
        '>> NOTE: THIS WILL Error if the message is sent!
        '>> Comment out .Send line and uncomment the .Display line for the following to work.
        'AppActivate (strSubject & " - Message")
    End With
zRecover:
    If Not objOutlook Is Nothing Then Set objOutlook = Nothing
    If Not objEmail Is Nothing Then Set objOutlook = Nothing
    If Not objNameSpace Is Nothing Then Set objOutlook = Nothing
Exit Sub
zErrorTrap:
  Select Case Err.Number
    Case 429
      'no current outlook object resume the code and create an object
      Resume Next
    Case Else
    MsgBox "ErrSource: " & Err.Source & vbCrLf & "ErrNum: " & Err.Number & vbCrLf & "ErrDescription: " & vbCrLf & Err.Description
  End Select
Resume zRecover
End Sub

Cheers!
-Z

[CD Tom]

Your code works like mine, If outlook is running nothing works, If I close Outlook and run it everything works great. Why doesn't it like it when outlook is running. Can I close outlook if it's running, that sounds like a work around instead of having it work even if Outlook is running.
Do you have any problems when Outlook is running?

[zmbd]

CDTom,
1) In what environment is office running - are you in the webbased interface or on a PC? Office 365 has a bit of a different feel. Unfortunately, I do not use this version so some of the troubleshooting will be best-guess.

The reason I ask it that I am seeing a lot of chatter with Excel VBA macros failing from the "cloud interface" and a lot of very upset people that use very complex code to do their work - everything from chemistry labs to stock brokers. :(
I don't think Microsoft thought this thru very well when moving to the cloud-subscription model.

2)Using my code
Insert a Stop between line 14 and 15
Once the IDE opens use [F8] to step through the code, both with Outlook open and then when it's closed.
When Line 15 executes do we drop to the error trap in either case?

-Z

[CD Tom]

I on the PC based version.
With Outlook running when it hits line 15 it jumps to CASE 429 and then does the Resume next Then it gets another error when it hits the Set objOutlook = createObject("outlook.application") showing ErrNum -2146959355 ErrDescription Server execution failed.
With Outlook not running it jumps to Case 429 on line 15 does the resume next but this time the set ObjOutlook = CreateObject("Outlook.Application") sets ObjOutLook to Outlook and everything works.
Why when Outlook is running does Line 15 come up with nothing I thought that it was supposed to tell us if Outlook was running?

[zmbd]

+ So, from what I understand (thus I may be wrong) Line 15 is an application trick - if there's no local Instance running, then we cannot set a pointer to it; thus the error, trapped, recovery to create a new instance of the application.

+ Just to confirm my suspicion, can you start your PC without an internet connection? If so, then restart your PC, without an internet connection, start outlook, yes it will complain, you should still be able to start it. In this case, I suspect that the outlook will start from the local install. When this happens, try the code with outlook open. If what I think is happening is correct, things should work with the outlook open in this case because it's a local instance of the application.

[Rabbit]

Did the CDO object in this thread not work for you? https://bytes.com/topic/access/answe...nce-msoutl-olb

[CD Tom]

Yes but what I did to correct that problem was to eliminate the reference to Outlook 2016 and changed it back to Outlook 2007 and this took care of the function problem. This thread has to do with emailing from within Access and trying zmbd suggestion in the previous reply I found what he thought was happening. With Office 365 this comes with Access 2016 which I hate so I found a way to manually install Office 365 and pick the program you want to install. I found this at the following link https://www.askvg.com/tip-customize-...programs-only/
it worked find and I was able to eliminate Access 2016 from the installation and can now use Access 2007 which is much better (IMHO). However when I did ZMBD suggestion the process reverted back to the installation of the original installation which had Access 2016 and Access 2007 wouldn't run any more. I guess you can't have two different version of Access. So I uninstalled Office 365 again and did the manual installation and now I can use Access 2007.
I hope this makes some kind of sense.

[zmbd]

CD Tom,
Sorry for the inconvenience and the mess with your office installation, I've never had a revert happen like that!

To be very honest here, MS doesn't really support multiple versions of Office on the same PC and from the article below you'll see where they state that the subscription and standalone don't play well with each other.

https://support.office.com/en-us/art...7-b78c513788bf

If you have an Office 2010, it plays better with the newer versions; however, I think you'll still have the same issue... that is, no local instance of Outlook when 365 is running. In which case, the CDO method may be your best option.

[CD Tom]

Thanks for helping me sort out why this is happening, I can just make sure the outlook isn't running when I want to send out emails from within my Access app.
Thanks again.

[zmbd]

Good Morning CD Tom,
I have a thought, the reason the code seems to be failing with the Outlook 365 running is, from what I've been reading, that the app is "Sand Boxed" in an MS-InternetExplorer/Edge object therefor it is not available at the local level.

However, there appears to be a local install, to whit, if we can pull the install path then we my be able to start a local instance of the local installed version of the program.

Looking back at some old code, one of my first experiences with API calls was to read the registry. So my thought is pull the Outlook local install path from the registry, shell out an instance, and try to bind to that new instance.

I've ran this on a local install of Office2013(32Bit) under Windows 8.1(64bit) - ran flawlessly once I figured out how to do the second level of error trapping; however, your setup may cause a kink in the hose!

Outlook code:

'Proof of concept when Office365 is installed
Sub SendEmailOutlook365Running()
    'Use following Dim statements for Late Binding
    'NOTE: Additional Const declaration
    Dim objOutlook As Object    'Outlook.Application  (Note dimensioned as Object)
    Dim objEmail As Object      'Outlook.MailItem     (Note dimensioned as Object)
    Dim objNameSpace As Object  'Outlook.NameSpace    (Note dimensioned as Object)
    Const olMailItem As Long = 0    'For Late Binding
    Const olFolderInbox As Long = 6 'For Late Binding
    Const olFormatHTML As Long = 2  'For Late Binding
    Dim strSubject As String
    Dim strAddress As String
    Dim strToAddress As String
    Dim zerror911 As Boolean
    '
    On Error GoTo zErrorTrap
    zerror911 = False
    '
    Set objOutlook = GetObject(, "Outlook.Application")
    '
zResumeFromErr429:
    Set objEmail = objOutlook.CreateItem(olMailItem)
    '
    strSubject = "My Test Message"
    strToAddress = "[e-mail]"
 
    With objEmail
 
        .To = strToAddress  'Removed for privacy
 
        .Subject = strSubject
 
        .BodyFormat = olFormatHTML
 
        'uncomment to show the email and allow the user to edit before sending.
        .Display
        '
        'comment out display to send without visual
        '.Send
 
        'Full Name of window can change depending on Tools -> Options -> Mail Format
        'Changing this option for outgoing mail changes the window name.
        'However, AppActivate appears not to require entire name but needs up to end
        'of - Message which is included in heading following the Subject string
        'irrespective of the Mail Format option chosen.
        '>> NOTE: THIS WILL Error if the message is sent!
        '>> Comment out .Send line and uncomment the .Display line for the following to work.
        'AppActivate (strSubject & " - Message")
    End With
zRecover:
    If Not objOutlook Is Nothing Then Set objOutlook = Nothing
    If Not objEmail Is Nothing Then Set objOutlook = Nothing
    If Not objNameSpace Is Nothing Then Set objOutlook = Nothing
Exit Sub
zErrorTrap:
  'prevent infinate loop
  If zerror911 Then
    Err.Raise Number:=(vbObjectError + 911), Source:="Error Trapping", Description:="Infinate Loop Bail"
  End If
  Select Case Err.Number
    Case 429, -2146959355
    '* There is no local instance of outlook open, with Office 365 we have a sandboxed application that isn't _
     *  visible to VBA, so we're going to pull the local Office installation path and _
     *  and see if launching the local version directly will work...
    '
      Dim RtndKeyValue As String
      '
      'prevent infinite loop
      zerror911 = True
      '
      'Pull the key fromt he registry - dependency stdModule:=RegistryKeysByApiCall
      RtndKeyValue = GetRegistry(Key:="HKEY_LOCAL_MACHINE", _
        Path:="SOFTWARE\Microsoft\Windows\CurrentVersion\App Paths\outlook.exe", _
        ValueName:="path")
      RtndKeyValue = RtndKeyValue & "outlook.exe"
      '
      'attempt to shell out the call to the local install and wait...
      Shell (RtndKeyValue)
      Call FetchOutlookObject(zObj:=objOutlook)
      If Not objOutlook Is Nothing Then Resume zResumeFromErr429
    Case Else
    MsgBox "ErrSource: " & Err.Source & vbCrLf & "ErrNum: " & Err.Number & vbCrLf & "ErrDescription: " & vbCrLf & Err.Description
  End Select
Resume zRecover
End Sub

Add the following to the same module as the Email Code... Needed to pull the code out for a second level of error trapping.

Sub FetchOutlookObject(ByRef zObj As Object)
  Dim loopcount As Long
  On Error Resume Next
  Do While (zObj Is Nothing) And (loopcount <= 100000)
    Set zObj = GetObject(, "Outlook.Application")
    DoEvents
    loopcount = loopcount + 1
  Loop
  On Error GoTo zErrorTrap
  If (loopcount >= 100000) Then Err.Raise Number:=(vbObjectError + 411), Source:="FetchOutlookObject", Description:="Unable to start local instance of Outlook"
Exit Sub
zErrorTrap:
  MsgBox "ErrSource: " & Err.Source & vbCrLf & "ErrNum: " & Err.Number & vbCrLf & "ErrDescription: " & vbCrLf & Err.Description
End Sub

Dependency - I have this code in its own standard module and I suggest you do the same.

Option Compare Database
Option Explicit
'
'
' 32-bit declarations
'Originally by John Walkenbach
'I Added the Conditional compile when 64bit installs started popping up
'-Z
'
#If VBA7 Then
  Private Declare PtrSafe Function RegOpenKeyA Lib "ADVAPI32.DLL" _
      (ByVal hKey As Long, ByVal sSubKey As String, _
      ByRef hkeyResult As Long) As Long
 
  Private Declare PtrSafe Function RegCloseKey Lib "ADVAPI32.DLL" _
      (ByVal hKey As Long) As Long
 
  Private Declare PtrSafe Function RegSetValueExA Lib "ADVAPI32.DLL" _
      (ByVal hKey As Long, ByVal sValueName As String, _
      ByVal dwReserved As Long, ByVal dwType As Long, _
      ByVal sValue As String, ByVal dwSize As Long) As Long
 
  Private Declare PtrSafe Function RegCreateKeyA Lib "ADVAPI32.DLL" _
      (ByVal hKey As Long, ByVal sSubKey As String, _
      ByRef hkeyResult As Long) As Long
 
  Private Declare PtrSafe Function RegQueryValueExA Lib "ADVAPI32.DLL" _
      (ByVal hKey As Long, ByVal sValueName As String, _
      ByVal dwReserved As Long, ByRef lValueType As Long, _
      ByVal sValue As String, ByRef lResultLen As Long) As Long
#Else
  Private Declare Function RegOpenKeyA Lib "ADVAPI32.DLL" _
      (ByVal hKey As Long, ByVal sSubKey As String, _
      ByRef hkeyResult As Long) As Long
 
  Private Declare Function RegCloseKey Lib "ADVAPI32.DLL" _
      (ByVal hKey As Long) As Long
 
  Private Declare Function RegSetValueExA Lib "ADVAPI32.DLL" _
      (ByVal hKey As Long, ByVal sValueName As String, _
      ByVal dwReserved As Long, ByVal dwType As Long, _
      ByVal sValue As String, ByVal dwSize As Long) As Long
 
  Private Declare Function RegCreateKeyA Lib "ADVAPI32.DLL" _
      (ByVal hKey As Long, ByVal sSubKey As String, _
      ByRef hkeyResult As Long) As Long
 
  Private Declare Function RegQueryValueExA Lib "ADVAPI32.DLL" _
      (ByVal hKey As Long, ByVal sValueName As String, _
      ByVal dwReserved As Long, ByRef lValueType As Long, _
      ByVal sValue As String, ByRef lResultLen As Long) As Long
#End If
'
'
 
Public Function GetRegistry(Key, Path, ByVal ValueName As String)
'  Reads a value from the Windows Registry
 
    Dim hKey As Long
    Dim lValueType As Long
    Dim sResult As String
    Dim lResultLen As Long
    Dim ResultLen As Long
    Dim X As Long
    Dim TheKey As Long
 
    TheKey = -99
    Select Case UCase(Key)
        Case "HKEY_CLASSES_ROOT": TheKey = &H80000000
        Case "HKEY_CURRENT_USER": TheKey = &H80000001
        Case "HKEY_LOCAL_MACHINE": TheKey = &H80000002
        Case "HKEY_USERS": TheKey = &H80000003
        Case "HKEY_CURRENT_CONFIG": TheKey = &H80000004
        Case "HKEY_DYN_DATA": TheKey = &H80000005
    End Select
 
'   Exit if key is not found
    If TheKey = -99 Then
        GetRegistry = "Not Found"
        Exit Function
    End If
 
    If RegOpenKeyA(TheKey, Path, hKey) <> 0 Then _
        X = RegCreateKeyA(TheKey, Path, hKey)
 
    sResult = Space(100)
    lResultLen = 100
 
    X = RegQueryValueExA(hKey, ValueName, 0, lValueType, _
    sResult, lResultLen)
 
    Select Case X
        Case 0: GetRegistry = Left(sResult, lResultLen - 1)
        Case Else: GetRegistry = "Not Found"
    End Select
 
    RegCloseKey hKey
End Function
 
Public Function WriteRegistry(ByVal Key As String, _
    ByVal Path As String, ByVal entry As String, _
    ByVal value As String)
 
    Dim hKey As Long
    Dim lValueType As Long
    Dim sResult As String
    Dim lResultLen As Long
    Dim TheKey As Long
    Dim X As Long
 
    TheKey = -99
    Select Case UCase(Key)
        Case "HKEY_CLASSES_ROOT": TheKey = &H80000000
        Case "HKEY_CURRENT_USER": TheKey = &H80000001
        Case "HKEY_LOCAL_MACHINE": TheKey = &H80000002
        Case "HKEY_USERS": TheKey = &H80000003
        Case "HKEY_CURRENT_CONFIG": TheKey = &H80000004
        Case "HKEY_DYN_DATA": TheKey = &H80000005
    End Select
 
'   Exit if key is not found
    If TheKey = -99 Then
        WriteRegistry = False
        Exit Function
    End If
 
'   Make sure  key exists
    If RegOpenKeyA(TheKey, Path, hKey) <> 0 Then
        X = RegCreateKeyA(TheKey, Path, hKey)
    End If
 
    X = RegSetValueExA(hKey, entry, 0, 1, value, Len(value) + 1)
    If X = 0 Then WriteRegistry = True Else WriteRegistry = False
End Function