By using this site, you agree to our updated Privacy Policy and our Terms of Use. Manage your Cookies Settings.
424,851 Members | 1,097 Online
Bytes IT Community
+ Ask a Question
Need help? Post your question and get tips & solutions from a community of 424,851 IT Pros & Developers. It's quick & easy.

Another email question using Outlook and VBA

100+
P: 441
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
Expand|Select|Wrap|Line Numbers
  1. Const Err_APP_NOTRUNNING As Long = 429
  2. Dim cdomsg As Object
  3. Dim Vres As String
  4. Dim stdmsg As String
  5. Dim myItem As Object
  6. Dim strFullPath As String
  7. Dim strFilename As String
  8. Dim VUserName As String
  9. Dim VPassword As String
  10. Dim EMailMsg As String
  11. Dim strAttachPath As Variant
  12. Dim intAttachments As Integer
  13. Dim myObject As Outlook.Application
  14. On Error Resume Next
  15. Set myObject = GetObject(, "outlook.application")
  16. If Err = Err_APP_NOTRUNNING Then
  17.     Set myObject = CreateObject("outlook.Application")
  18. End If
  19. 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
2 Weeks Ago #1

✓ answered by 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:
Expand|Select|Wrap|Line Numbers
  1. 'Proof of concept when Office365 is installed
  2. Sub SendEmailOutlook365Running()
  3.     'Use following Dim statements for Late Binding
  4.     'NOTE: Additional Const declaration
  5.     Dim objOutlook As Object    'Outlook.Application  (Note dimensioned as Object)
  6.     Dim objEmail As Object      'Outlook.MailItem     (Note dimensioned as Object)
  7.     Dim objNameSpace As Object  'Outlook.NameSpace    (Note dimensioned as Object)
  8.     Const olMailItem As Long = 0    'For Late Binding
  9.     Const olFolderInbox As Long = 6 'For Late Binding
  10.     Const olFormatHTML As Long = 2  'For Late Binding
  11.     Dim strSubject As String
  12.     Dim strAddress As String
  13.     Dim strToAddress As String
  14.     Dim zerror911 As Boolean
  15.     '
  16.     On Error GoTo zErrorTrap
  17.     zerror911 = False
  18.     '
  19.     Set objOutlook = GetObject(, "Outlook.Application")
  20.     '
  21. zResumeFromErr429:
  22.     Set objEmail = objOutlook.CreateItem(olMailItem)
  23.     '
  24.     strSubject = "My Test Message"
  25.     strToAddress = "bogusemail@bogus.com"
  26.  
  27.     With objEmail
  28.  
  29.         .To = strToAddress  'Removed for privacy
  30.  
  31.         .Subject = strSubject
  32.  
  33.         .BodyFormat = olFormatHTML
  34.  
  35.         'uncomment to show the email and allow the user to edit before sending.
  36.         .Display
  37.         '
  38.         'comment out display to send without visual
  39.         '.Send
  40.  
  41.         'Full Name of window can change depending on Tools -> Options -> Mail Format
  42.         'Changing this option for outgoing mail changes the window name.
  43.         'However, AppActivate appears not to require entire name but needs up to end
  44.         'of - Message which is included in heading following the Subject string
  45.         'irrespective of the Mail Format option chosen.
  46.         '>> NOTE: THIS WILL Error if the message is sent!
  47.         '>> Comment out .Send line and uncomment the .Display line for the following to work.
  48.         'AppActivate (strSubject & " - Message")
  49.     End With
  50. zRecover:
  51.     If Not objOutlook Is Nothing Then Set objOutlook = Nothing
  52.     If Not objEmail Is Nothing Then Set objOutlook = Nothing
  53.     If Not objNameSpace Is Nothing Then Set objOutlook = Nothing
  54. Exit Sub
  55. zErrorTrap:
  56.   'prevent infinate loop
  57.   If zerror911 Then
  58.     Err.Raise Number:=(vbObjectError + 911), Source:="Error Trapping", Description:="Infinate Loop Bail"
  59.   End If
  60.   Select Case Err.Number
  61.     Case 429, -2146959355
  62.     '* There is no local instance of outlook open, with Office 365 we have a sandboxed application that isn't _
  63.      *  visible to VBA, so we're going to pull the local Office installation path and _
  64.      *  and see if launching the local version directly will work...
  65.     '
  66.       Dim RtndKeyValue As String
  67.       '
  68.       'prevent infinite loop
  69.       zerror911 = True
  70.       '
  71.       'Pull the key fromt he registry - dependency stdModule:=RegistryKeysByApiCall
  72.       RtndKeyValue = GetRegistry(Key:="HKEY_LOCAL_MACHINE", _
  73.         Path:="SOFTWARE\Microsoft\Windows\CurrentVersion\App Paths\outlook.exe", _
  74.         ValueName:="path")
  75.       RtndKeyValue = RtndKeyValue & "outlook.exe"
  76.       '
  77.       'attempt to shell out the call to the local install and wait...
  78.       Shell (RtndKeyValue)
  79.       Call FetchOutlookObject(zObj:=objOutlook)
  80.       If Not objOutlook Is Nothing Then Resume zResumeFromErr429
  81.     Case Else
  82.     MsgBox "ErrSource: " & Err.Source & vbCrLf & "ErrNum: " & Err.Number & vbCrLf & "ErrDescription: " & vbCrLf & Err.Description
  83.   End Select
  84. Resume zRecover
  85. 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.
Expand|Select|Wrap|Line Numbers
  1. Sub FetchOutlookObject(ByRef zObj As Object)
  2.   Dim loopcount As Long
  3.   On Error Resume Next
  4.   Do While (zObj Is Nothing) And (loopcount <= 100000)
  5.     Set zObj = GetObject(, "Outlook.Application")
  6.     DoEvents
  7.     loopcount = loopcount + 1
  8.   Loop
  9.   On Error GoTo zErrorTrap
  10.   If (loopcount >= 100000) Then Err.Raise Number:=(vbObjectError + 411), Source:="FetchOutlookObject", Description:="Unable to start local instance of Outlook"
  11. Exit Sub
  12. zErrorTrap:
  13.   MsgBox "ErrSource: " & Err.Source & vbCrLf & "ErrNum: " & Err.Number & vbCrLf & "ErrDescription: " & vbCrLf & Err.Description
  14. End Sub
Dependency - I have this code in its own standard module and I suggest you do the same.
Expand|Select|Wrap|Line Numbers
  1. Option Compare Database
  2. Option Explicit
  3. '
  4. '
  5. ' 32-bit declarations
  6. 'Originally by John Walkenbach
  7. 'I Added the Conditional compile when 64bit installs started popping up
  8. '-Z
  9. '
  10. #If VBA7 Then
  11.   Private Declare PtrSafe Function RegOpenKeyA Lib "ADVAPI32.DLL" _
  12.       (ByVal hKey As Long, ByVal sSubKey As String, _
  13.       ByRef hkeyResult As Long) As Long
  14.  
  15.   Private Declare PtrSafe Function RegCloseKey Lib "ADVAPI32.DLL" _
  16.       (ByVal hKey As Long) As Long
  17.  
  18.   Private Declare PtrSafe Function RegSetValueExA Lib "ADVAPI32.DLL" _
  19.       (ByVal hKey As Long, ByVal sValueName As String, _
  20.       ByVal dwReserved As Long, ByVal dwType As Long, _
  21.       ByVal sValue As String, ByVal dwSize As Long) As Long
  22.  
  23.   Private Declare PtrSafe Function RegCreateKeyA Lib "ADVAPI32.DLL" _
  24.       (ByVal hKey As Long, ByVal sSubKey As String, _
  25.       ByRef hkeyResult As Long) As Long
  26.  
  27.   Private Declare PtrSafe Function RegQueryValueExA Lib "ADVAPI32.DLL" _
  28.       (ByVal hKey As Long, ByVal sValueName As String, _
  29.       ByVal dwReserved As Long, ByRef lValueType As Long, _
  30.       ByVal sValue As String, ByRef lResultLen As Long) As Long
  31. #Else
  32.   Private Declare Function RegOpenKeyA Lib "ADVAPI32.DLL" _
  33.       (ByVal hKey As Long, ByVal sSubKey As String, _
  34.       ByRef hkeyResult As Long) As Long
  35.  
  36.   Private Declare Function RegCloseKey Lib "ADVAPI32.DLL" _
  37.       (ByVal hKey As Long) As Long
  38.  
  39.   Private Declare Function RegSetValueExA Lib "ADVAPI32.DLL" _
  40.       (ByVal hKey As Long, ByVal sValueName As String, _
  41.       ByVal dwReserved As Long, ByVal dwType As Long, _
  42.       ByVal sValue As String, ByVal dwSize As Long) As Long
  43.  
  44.   Private Declare Function RegCreateKeyA Lib "ADVAPI32.DLL" _
  45.       (ByVal hKey As Long, ByVal sSubKey As String, _
  46.       ByRef hkeyResult As Long) As Long
  47.  
  48.   Private Declare Function RegQueryValueExA Lib "ADVAPI32.DLL" _
  49.       (ByVal hKey As Long, ByVal sValueName As String, _
  50.       ByVal dwReserved As Long, ByRef lValueType As Long, _
  51.       ByVal sValue As String, ByRef lResultLen As Long) As Long
  52. #End If
  53. '
  54. '
  55.  
  56. Public Function GetRegistry(Key, Path, ByVal ValueName As String)
  57. '  Reads a value from the Windows Registry
  58.  
  59.     Dim hKey As Long
  60.     Dim lValueType As Long
  61.     Dim sResult As String
  62.     Dim lResultLen As Long
  63.     Dim ResultLen As Long
  64.     Dim X As Long
  65.     Dim TheKey As Long
  66.  
  67.     TheKey = -99
  68.     Select Case UCase(Key)
  69.         Case "HKEY_CLASSES_ROOT": TheKey = &H80000000
  70.         Case "HKEY_CURRENT_USER": TheKey = &H80000001
  71.         Case "HKEY_LOCAL_MACHINE": TheKey = &H80000002
  72.         Case "HKEY_USERS": TheKey = &H80000003
  73.         Case "HKEY_CURRENT_CONFIG": TheKey = &H80000004
  74.         Case "HKEY_DYN_DATA": TheKey = &H80000005
  75.     End Select
  76.  
  77. '   Exit if key is not found
  78.     If TheKey = -99 Then
  79.         GetRegistry = "Not Found"
  80.         Exit Function
  81.     End If
  82.  
  83.     If RegOpenKeyA(TheKey, Path, hKey) <> 0 Then _
  84.         X = RegCreateKeyA(TheKey, Path, hKey)
  85.  
  86.     sResult = Space(100)
  87.     lResultLen = 100
  88.  
  89.     X = RegQueryValueExA(hKey, ValueName, 0, lValueType, _
  90.     sResult, lResultLen)
  91.  
  92.     Select Case X
  93.         Case 0: GetRegistry = Left(sResult, lResultLen - 1)
  94.         Case Else: GetRegistry = "Not Found"
  95.     End Select
  96.  
  97.     RegCloseKey hKey
  98. End Function
  99.  
  100. Public Function WriteRegistry(ByVal Key As String, _
  101.     ByVal Path As String, ByVal entry As String, _
  102.     ByVal value As String)
  103.  
  104.     Dim hKey As Long
  105.     Dim lValueType As Long
  106.     Dim sResult As String
  107.     Dim lResultLen As Long
  108.     Dim TheKey As Long
  109.     Dim X As Long
  110.  
  111.     TheKey = -99
  112.     Select Case UCase(Key)
  113.         Case "HKEY_CLASSES_ROOT": TheKey = &H80000000
  114.         Case "HKEY_CURRENT_USER": TheKey = &H80000001
  115.         Case "HKEY_LOCAL_MACHINE": TheKey = &H80000002
  116.         Case "HKEY_USERS": TheKey = &H80000003
  117.         Case "HKEY_CURRENT_CONFIG": TheKey = &H80000004
  118.         Case "HKEY_DYN_DATA": TheKey = &H80000005
  119.     End Select
  120.  
  121. '   Exit if key is not found
  122.     If TheKey = -99 Then
  123.         WriteRegistry = False
  124.         Exit Function
  125.     End If
  126.  
  127. '   Make sure  key exists
  128.     If RegOpenKeyA(TheKey, Path, hKey) <> 0 Then
  129.         X = RegCreateKeyA(TheKey, Path, hKey)
  130.     End If
  131.  
  132.     X = RegSetValueExA(hKey, entry, 0, 1, value, Len(value) + 1)
  133.     If X = 0 Then WriteRegistry = True Else WriteRegistry = False
  134. End Function
  135.  
  136.  

Share this Question
Share on Google+
13 Replies


NeoPa
Expert Mod 15k+
P: 31,308
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?
2 Weeks Ago #2

100+
P: 441
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.
2 Weeks Ago #3

twinnyfo
Expert Mod 2.5K+
P: 3,158
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.
2 Weeks Ago #4

zmbd
Expert Mod 5K+
P: 5,331
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...

Expand|Select|Wrap|Line Numbers
  1. Private Sub CmdBtnSendEmail_Click()
  2.     'Use following Dim statements for Late Binding
  3.     'NOTE: Additional Const declaration
  4.     Dim objOutlook As Object    'Outlook.Application  (Note dimensioned as Object)
  5.     Dim objEmail As Object      'Outlook.MailItem     (Note dimensioned as Object)
  6.     Dim objNameSpace As Object  'Outlook.NameSpace    (Note dimensioned as Object)
  7.     Const olMailItem As Long = 0    'For Late Binding
  8.     Const olFolderInbox As Long = 6 'For Late Binding
  9.     Const olFormatHTML As Long = 2  'For Late Binding
  10.     Dim strSubject As String
  11.     Dim strAddress As String
  12.     Dim strToAddress As String
  13.  
  14.     On Error GoTo zErrorTrap
  15.     Set objOutlook = GetObject(, "Outlook.Application")
  16.  
  17.     If objOutlook Is Nothing Then
  18.         Set objOutlook = CreateObject("Outlook.Application")
  19.         Set objNameSpace = objOutlook.GetNamespace("MAPI")
  20.         objNameSpace.GetDefaultFolder(olFolderInbox).Display
  21.     End If
  22.  
  23.     Set objEmail = objOutlook.CreateItem(olMailItem)
  24.  
  25.     strSubject = "My Test Message"
  26.     strToAddress = "bogusemail@bogus.com"
  27.  
  28.     With objEmail
  29.  
  30.         .To = strToAddress  'Removed for privacy
  31.  
  32.         .Subject = strSubject
  33.  
  34.         .BodyFormat = olFormatHTML
  35.  
  36.         'uncomment to show the email and allow the user to edit before sending.
  37.         .Display
  38.         '
  39.         'comment out display to send without visual
  40.         '.Send
  41.  
  42.         'Full Name of window can change depending on Tools -> Options -> Mail Format
  43.         'Changing this option for outgoing mail changes the window name.
  44.         'However, AppActivate appears not to require entire name but needs up to end
  45.         'of - Message which is included in heading following the Subject string
  46.         'irrespective of the Mail Format option chosen.
  47.         '>> NOTE: THIS WILL Error if the message is sent!
  48.         '>> Comment out .Send line and uncomment the .Display line for the following to work.
  49.         'AppActivate (strSubject & " - Message")
  50.     End With
  51. zRecover:
  52.     If Not objOutlook Is Nothing Then Set objOutlook = Nothing
  53.     If Not objEmail Is Nothing Then Set objOutlook = Nothing
  54.     If Not objNameSpace Is Nothing Then Set objOutlook = Nothing
  55. Exit Sub
  56. zErrorTrap:
  57.   Select Case Err.Number
  58.     Case 429
  59.       'no current outlook object resume the code and create an object
  60.       Resume Next
  61.     Case Else
  62.     MsgBox "ErrSource: " & Err.Source & vbCrLf & "ErrNum: " & Err.Number & vbCrLf & "ErrDescription: " & vbCrLf & Err.Description
  63.   End Select
  64. Resume zRecover
  65. End Sub
Cheers!
-Z
2 Weeks Ago #5

100+
P: 441
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?
2 Weeks Ago #6

zmbd
Expert Mod 5K+
P: 5,331
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
2 Weeks Ago #7

100+
P: 441
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?
2 Weeks Ago #8

zmbd
Expert Mod 5K+
P: 5,331
+ 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.
2 Weeks Ago #9

Rabbit
Expert Mod 10K+
P: 12,342
Did the CDO object in this thread not work for you? https://bytes.com/topic/access/answe...nce-msoutl-olb
2 Weeks Ago #10

100+
P: 441
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.
2 Weeks Ago #11

zmbd
Expert Mod 5K+
P: 5,331
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.
2 Weeks Ago #12

100+
P: 441
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.
2 Weeks Ago #13

zmbd
Expert Mod 5K+
P: 5,331
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:
Expand|Select|Wrap|Line Numbers
  1. 'Proof of concept when Office365 is installed
  2. Sub SendEmailOutlook365Running()
  3.     'Use following Dim statements for Late Binding
  4.     'NOTE: Additional Const declaration
  5.     Dim objOutlook As Object    'Outlook.Application  (Note dimensioned as Object)
  6.     Dim objEmail As Object      'Outlook.MailItem     (Note dimensioned as Object)
  7.     Dim objNameSpace As Object  'Outlook.NameSpace    (Note dimensioned as Object)
  8.     Const olMailItem As Long = 0    'For Late Binding
  9.     Const olFolderInbox As Long = 6 'For Late Binding
  10.     Const olFormatHTML As Long = 2  'For Late Binding
  11.     Dim strSubject As String
  12.     Dim strAddress As String
  13.     Dim strToAddress As String
  14.     Dim zerror911 As Boolean
  15.     '
  16.     On Error GoTo zErrorTrap
  17.     zerror911 = False
  18.     '
  19.     Set objOutlook = GetObject(, "Outlook.Application")
  20.     '
  21. zResumeFromErr429:
  22.     Set objEmail = objOutlook.CreateItem(olMailItem)
  23.     '
  24.     strSubject = "My Test Message"
  25.     strToAddress = "bogusemail@bogus.com"
  26.  
  27.     With objEmail
  28.  
  29.         .To = strToAddress  'Removed for privacy
  30.  
  31.         .Subject = strSubject
  32.  
  33.         .BodyFormat = olFormatHTML
  34.  
  35.         'uncomment to show the email and allow the user to edit before sending.
  36.         .Display
  37.         '
  38.         'comment out display to send without visual
  39.         '.Send
  40.  
  41.         'Full Name of window can change depending on Tools -> Options -> Mail Format
  42.         'Changing this option for outgoing mail changes the window name.
  43.         'However, AppActivate appears not to require entire name but needs up to end
  44.         'of - Message which is included in heading following the Subject string
  45.         'irrespective of the Mail Format option chosen.
  46.         '>> NOTE: THIS WILL Error if the message is sent!
  47.         '>> Comment out .Send line and uncomment the .Display line for the following to work.
  48.         'AppActivate (strSubject & " - Message")
  49.     End With
  50. zRecover:
  51.     If Not objOutlook Is Nothing Then Set objOutlook = Nothing
  52.     If Not objEmail Is Nothing Then Set objOutlook = Nothing
  53.     If Not objNameSpace Is Nothing Then Set objOutlook = Nothing
  54. Exit Sub
  55. zErrorTrap:
  56.   'prevent infinate loop
  57.   If zerror911 Then
  58.     Err.Raise Number:=(vbObjectError + 911), Source:="Error Trapping", Description:="Infinate Loop Bail"
  59.   End If
  60.   Select Case Err.Number
  61.     Case 429, -2146959355
  62.     '* There is no local instance of outlook open, with Office 365 we have a sandboxed application that isn't _
  63.      *  visible to VBA, so we're going to pull the local Office installation path and _
  64.      *  and see if launching the local version directly will work...
  65.     '
  66.       Dim RtndKeyValue As String
  67.       '
  68.       'prevent infinite loop
  69.       zerror911 = True
  70.       '
  71.       'Pull the key fromt he registry - dependency stdModule:=RegistryKeysByApiCall
  72.       RtndKeyValue = GetRegistry(Key:="HKEY_LOCAL_MACHINE", _
  73.         Path:="SOFTWARE\Microsoft\Windows\CurrentVersion\App Paths\outlook.exe", _
  74.         ValueName:="path")
  75.       RtndKeyValue = RtndKeyValue & "outlook.exe"
  76.       '
  77.       'attempt to shell out the call to the local install and wait...
  78.       Shell (RtndKeyValue)
  79.       Call FetchOutlookObject(zObj:=objOutlook)
  80.       If Not objOutlook Is Nothing Then Resume zResumeFromErr429
  81.     Case Else
  82.     MsgBox "ErrSource: " & Err.Source & vbCrLf & "ErrNum: " & Err.Number & vbCrLf & "ErrDescription: " & vbCrLf & Err.Description
  83.   End Select
  84. Resume zRecover
  85. 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.
Expand|Select|Wrap|Line Numbers
  1. Sub FetchOutlookObject(ByRef zObj As Object)
  2.   Dim loopcount As Long
  3.   On Error Resume Next
  4.   Do While (zObj Is Nothing) And (loopcount <= 100000)
  5.     Set zObj = GetObject(, "Outlook.Application")
  6.     DoEvents
  7.     loopcount = loopcount + 1
  8.   Loop
  9.   On Error GoTo zErrorTrap
  10.   If (loopcount >= 100000) Then Err.Raise Number:=(vbObjectError + 411), Source:="FetchOutlookObject", Description:="Unable to start local instance of Outlook"
  11. Exit Sub
  12. zErrorTrap:
  13.   MsgBox "ErrSource: " & Err.Source & vbCrLf & "ErrNum: " & Err.Number & vbCrLf & "ErrDescription: " & vbCrLf & Err.Description
  14. End Sub
Dependency - I have this code in its own standard module and I suggest you do the same.
Expand|Select|Wrap|Line Numbers
  1. Option Compare Database
  2. Option Explicit
  3. '
  4. '
  5. ' 32-bit declarations
  6. 'Originally by John Walkenbach
  7. 'I Added the Conditional compile when 64bit installs started popping up
  8. '-Z
  9. '
  10. #If VBA7 Then
  11.   Private Declare PtrSafe Function RegOpenKeyA Lib "ADVAPI32.DLL" _
  12.       (ByVal hKey As Long, ByVal sSubKey As String, _
  13.       ByRef hkeyResult As Long) As Long
  14.  
  15.   Private Declare PtrSafe Function RegCloseKey Lib "ADVAPI32.DLL" _
  16.       (ByVal hKey As Long) As Long
  17.  
  18.   Private Declare PtrSafe Function RegSetValueExA Lib "ADVAPI32.DLL" _
  19.       (ByVal hKey As Long, ByVal sValueName As String, _
  20.       ByVal dwReserved As Long, ByVal dwType As Long, _
  21.       ByVal sValue As String, ByVal dwSize As Long) As Long
  22.  
  23.   Private Declare PtrSafe Function RegCreateKeyA Lib "ADVAPI32.DLL" _
  24.       (ByVal hKey As Long, ByVal sSubKey As String, _
  25.       ByRef hkeyResult As Long) As Long
  26.  
  27.   Private Declare PtrSafe Function RegQueryValueExA Lib "ADVAPI32.DLL" _
  28.       (ByVal hKey As Long, ByVal sValueName As String, _
  29.       ByVal dwReserved As Long, ByRef lValueType As Long, _
  30.       ByVal sValue As String, ByRef lResultLen As Long) As Long
  31. #Else
  32.   Private Declare Function RegOpenKeyA Lib "ADVAPI32.DLL" _
  33.       (ByVal hKey As Long, ByVal sSubKey As String, _
  34.       ByRef hkeyResult As Long) As Long
  35.  
  36.   Private Declare Function RegCloseKey Lib "ADVAPI32.DLL" _
  37.       (ByVal hKey As Long) As Long
  38.  
  39.   Private Declare Function RegSetValueExA Lib "ADVAPI32.DLL" _
  40.       (ByVal hKey As Long, ByVal sValueName As String, _
  41.       ByVal dwReserved As Long, ByVal dwType As Long, _
  42.       ByVal sValue As String, ByVal dwSize As Long) As Long
  43.  
  44.   Private Declare Function RegCreateKeyA Lib "ADVAPI32.DLL" _
  45.       (ByVal hKey As Long, ByVal sSubKey As String, _
  46.       ByRef hkeyResult As Long) As Long
  47.  
  48.   Private Declare Function RegQueryValueExA Lib "ADVAPI32.DLL" _
  49.       (ByVal hKey As Long, ByVal sValueName As String, _
  50.       ByVal dwReserved As Long, ByRef lValueType As Long, _
  51.       ByVal sValue As String, ByRef lResultLen As Long) As Long
  52. #End If
  53. '
  54. '
  55.  
  56. Public Function GetRegistry(Key, Path, ByVal ValueName As String)
  57. '  Reads a value from the Windows Registry
  58.  
  59.     Dim hKey As Long
  60.     Dim lValueType As Long
  61.     Dim sResult As String
  62.     Dim lResultLen As Long
  63.     Dim ResultLen As Long
  64.     Dim X As Long
  65.     Dim TheKey As Long
  66.  
  67.     TheKey = -99
  68.     Select Case UCase(Key)
  69.         Case "HKEY_CLASSES_ROOT": TheKey = &H80000000
  70.         Case "HKEY_CURRENT_USER": TheKey = &H80000001
  71.         Case "HKEY_LOCAL_MACHINE": TheKey = &H80000002
  72.         Case "HKEY_USERS": TheKey = &H80000003
  73.         Case "HKEY_CURRENT_CONFIG": TheKey = &H80000004
  74.         Case "HKEY_DYN_DATA": TheKey = &H80000005
  75.     End Select
  76.  
  77. '   Exit if key is not found
  78.     If TheKey = -99 Then
  79.         GetRegistry = "Not Found"
  80.         Exit Function
  81.     End If
  82.  
  83.     If RegOpenKeyA(TheKey, Path, hKey) <> 0 Then _
  84.         X = RegCreateKeyA(TheKey, Path, hKey)
  85.  
  86.     sResult = Space(100)
  87.     lResultLen = 100
  88.  
  89.     X = RegQueryValueExA(hKey, ValueName, 0, lValueType, _
  90.     sResult, lResultLen)
  91.  
  92.     Select Case X
  93.         Case 0: GetRegistry = Left(sResult, lResultLen - 1)
  94.         Case Else: GetRegistry = "Not Found"
  95.     End Select
  96.  
  97.     RegCloseKey hKey
  98. End Function
  99.  
  100. Public Function WriteRegistry(ByVal Key As String, _
  101.     ByVal Path As String, ByVal entry As String, _
  102.     ByVal value As String)
  103.  
  104.     Dim hKey As Long
  105.     Dim lValueType As Long
  106.     Dim sResult As String
  107.     Dim lResultLen As Long
  108.     Dim TheKey As Long
  109.     Dim X As Long
  110.  
  111.     TheKey = -99
  112.     Select Case UCase(Key)
  113.         Case "HKEY_CLASSES_ROOT": TheKey = &H80000000
  114.         Case "HKEY_CURRENT_USER": TheKey = &H80000001
  115.         Case "HKEY_LOCAL_MACHINE": TheKey = &H80000002
  116.         Case "HKEY_USERS": TheKey = &H80000003
  117.         Case "HKEY_CURRENT_CONFIG": TheKey = &H80000004
  118.         Case "HKEY_DYN_DATA": TheKey = &H80000005
  119.     End Select
  120.  
  121. '   Exit if key is not found
  122.     If TheKey = -99 Then
  123.         WriteRegistry = False
  124.         Exit Function
  125.     End If
  126.  
  127. '   Make sure  key exists
  128.     If RegOpenKeyA(TheKey, Path, hKey) <> 0 Then
  129.         X = RegCreateKeyA(TheKey, Path, hKey)
  130.     End If
  131.  
  132.     X = RegSetValueExA(hKey, entry, 0, 1, value, Len(value) + 1)
  133.     If X = 0 Then WriteRegistry = True Else WriteRegistry = False
  134. End Function
  135.  
  136.  
2 Weeks Ago #14

Post your reply

Sign in to post your reply or Sign up for a free account.