Code to get email id from Outlook stopped working suddenly, please help

[inddon]

Hello There,

A piece of code which checks if the outlook is open, if yes then I do some truncation to get the email id, etc.

All of a sudden this just stopped working. In order to check the error message I marked out the 'On Error Resume Next and gave a msgbox to display oOutlook.session.Accounts.Count and it gives below error message:

----------------------------------------------------------------------
Runtime Error '-2147467263 (80004001)';
Not implemented
----------------------------------------------------------------------

I have no clue, attached sample workbook. Could you please help?

Many thanks & regards,
Don

Option Explicit
' ----------------------------------------------------------------
' Purpose: Outlook
' Base Source : http://www.geeksengine.com/article/validate-email-vba.html
' ----------------------------------------------------------------
Public oOutlook As Object
Public FirstName, LastName, CheckServerName, ServerName, UserId, Module_Name As String
Public UserEmailID As String


' ----------------------------------------------------------------
' Purpose: Check if MS Outlook is Open
' ----------------------------------------------------------------
Public Function CheckOutlookOpen() As Integer
  Dim SpacePos, TotalLen, AtSign, AtDot, i, Success As Integer

  'On Error Resume Next
  Module_Name = "CheckOutlookOpen"

  Set oOutlook = GetObject(, "Outlook.Application")
  ServerName = "abc.com"
   
'When Outlook is open then this does not enter the If condition

  If oOutlook Is Nothing Then
     CheckOutlookOpen = 1
     Exit Function
  End If

'----------------------------------------------------------------------
'I get an error message on oOutlook.session.Accounts.Count

'Runtime Error '-2147467263 (80004001)';
'Not implemented

MsgBox "Hello  " & oOutlook.session.Accounts.Count

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

  'Loop through the Accounts in Outlook
  For i = 1 To oOutlook.session.Accounts.Count
    TotalLen = Len(oOutlook.session.Accounts.Item(i))
    AtSign = InStr(1, oOutlook.session.Accounts.Item(i), "@")
    CheckServerName = LCase(Right(oOutlook.session.Accounts.Item(i), TotalLen - AtSign))
     
    'Check for the concerned Server Name
    If ServerName = CheckServerName Then
       AtDot = InStr(1, oOutlook.session.Accounts.Item(i), ".")
       SpacePos = InStr(1, oOutlook.session.CurrentUser, " ")
       FirstName = Left(oOutlook.session.CurrentUser, SpacePos - 1)
       UserId = LCase(Left(oOutlook.session.Accounts.Item(i), AtSign - 1))
     
       'Assign User ID to Login screen "User ID"
       UserFormLogin.TBUserID = UserId
     
       Success = 0
       Exit For
    End If
     
  Next i
  If Success = 1 Then
     CheckOutlookOpen = 1
     MsgBox "Invalid User Name. Please contact System Administrator"
     Exit Function
  End If
  UserEmailID = UserId & "@" & CheckServerName
End Function

 

[Chihiro]

Code itself has nothing wrong with it from what I can see. Also tested on my machines and ran fine on all.

I suspect it is your machine and/or environment that's the issue. I'd recommend restarting your computer and test. If that does not solve, isolate the update that took place prior to this error showing up. Try roll back the update and see if the code runs.

 

[inddon]

Thank you Chihiro for the tip. I uninstalled Ms office and reinstalled it. Now it works. A big relief.

It is good this issue came up, now will have to add some conditions to tackle it as well.

Regards,
Don