VBA Outlook - Converting working code early binding to late binding

Mallesh23

Well-known Member
Joined
Feb 4, 2009
Messages
853
Office Version
  1. 2010
Platform
  1. Windows
Hi Team,

Below outlook code works, Need help in converting Early binding outlook code to late Binding.
Task was Red flagged emails needs to attach to new email.

Public filename As String
VBA Code:
Sub Draft_Red_Flagged_emails()
       
    Dim Outlook_F_Path As String
    Outlook_F_Path = mac.Range("b4").Value  'Outlook folder path Example'\\abc@gmail.com\Inbox
        
    StartTime = Timer
     
     'Early Binding outlook
    Dim olApp As Outlook.Application
    Set olApp = New Outlook.Application
   
    Dim Main_Folder As Folder
    
    'Calling Function for outlook
    Set Main_Folder = GetOLFolder(Outlook_F_Path, olApp)
    Dim objMail As Outlook.MailItem
    
    Dim Item As Object
    Dim olItem As MailItem
    Dim objMsg As MailItem
    
    Set objMsg = olApp.CreateItem(olMailItem)
    Dim Filtered_Results As Object
    
    'Apply filter in outlook
    SFILTER = "[ReceivedTime]>'" & Format(Date, "DDDDD HH:NN") & "'"
    Set Filtered_Results = Main_Folder.Items.Restrict(SFILTER)
    
    'Date and Time for subject line
    T1 = Format(TimeValue(Now), "hh:mm AM/PM")
     D = Format(Date, "DD") & "/" & Format(Date, "MM") & "/" & Format(Date, "YYYY")
     
     
     'Check all mailItem which has Red Flag in search results (Restrict)
      
      For Each Item In Filtered_Results
        If TypeOf Item Is Outlook.MailItem Then
            
            MailRT = Item.ReceivedTime
            flagclr = Item.FlagIcon
            
            If flagclr = 6 Then
                    '3am to 2:30pm
                    'If TimeValue(currTime) >= TimeValue("3:00:00") And TimeValue(currTime) < TimeValue("14:30:00") Then
                If TimeValue(MailRT) >= mac.Range("A15").Value And TimeValue(MailRT) < mac.Range("B15").Value Then
                    With objMsg
                        .To = mac.Range("a10").Value
                        .CC = mac.Range("b10").Value
                        .Body = "Hi All," & vbNewLine & mac.Range("d11").Value
                        .Subject = mac.Range("c10").Value & " " & "(" & T1 & ")" & " - " & D  'Add Date and time to subject
                        .Attachments.Add Item
                        .Display
                      '.send
                    End With
                End If
            End If
        End If
    Next
               
  
  MsgBox "Macro Successful Time Taken " & Format(Timer - StartTime, "00:00") & " Seconds"
               
           
End Sub
 
 Sub PickOutlookFolder()
    Dim objNS As Namespace
    Dim objFolder As Object
    Dim strFolderPath As String
    Dim strEntryID As String
    'Set Outlook Object
    Set objNS = Outlook.GetNamespace("MAPI")
    Set objFolder = objNS.PickFolder
    If TypeName(objFolder) <> "Nothing" Then
        strFolderPath = objFolder.Folderpath
        strEntryID = objFolder.EntryID
    End If
    mac.Range("b4").Value = strFolderPath
    
End Sub


Function GetOLFolder(ByVal Folderpath As String, olApp As Outlook.Application) As Outlook.Folder
'Convert a string folder path to actual folder object, which lets you retrieve various folder properties
    Dim TestFolder      As Outlook.Folder
    Dim FoldersArray    As Variant
    Dim i               As Integer

    On Error GoTo GetFolder_Error
    If Left(Folderpath, 2) = "\\" Then
        Folderpath = Right(Folderpath, Len(Folderpath) - 2)
    End If
    'Convert folderpath to array
    FoldersArray = Split(Folderpath, "\")
    Set TestFolder = olApp.Session.Folders.Item(FoldersArray(0))
    If Not TestFolder Is Nothing Then
        For i = 1 To UBound(FoldersArray, 1)
            Dim SubFolders As Outlook.Folders
            Set SubFolders = TestFolder.Folders
            Set TestFolder = SubFolders.Item(FoldersArray(i))
            If TestFolder Is Nothing Then
                Set GetOLFolder = Nothing
            End If
        Next
    End If

    'Return the TestFolder
    Set GetOLFolder = TestFolder
    Exit Function

GetFolder_Error:
    Set GetOLFolder = Nothing
    Exit Function
End Function

Thanks
mg




T
 

Some videos you may like

Excel Facts

Create a Pivot Table on a Map
If your data has zip codes, postal codes, or city names, select the data and use Insert, 3D Map. (Found to right of chart icons).

6StringJazzer

Well-known Member
Joined
Jan 27, 2010
Messages
802
Office Version
  1. 365
Platform
  1. Windows
I think I got everything but this would have to be tested with your own file and environment.

Rich (BB code):
Const olMailItem = 0 ' insert at top of module

Public filename As String
Sub Draft_Red_Flagged_emails()
      
    Dim Outlook_F_Path As String
    Outlook_F_Path = mac.Range("b4").Value  'Outlook folder path Example'\\abc@gmail.com\Inbox
       
    StartTime = Timer
    
     'Late Binding outlook
    Dim olApp As Object ' Outlook.Application
    Set olApp = CreateObject("Outlook.Application") ' New Outlook.Application
  
    Dim Main_Folder As Folder
   
    'Calling Function for outlook
    Set Main_Folder = GetOLFolder(Outlook_F_Path, olApp)
    Dim objMail As Object ' Outlook.MailItem
   
    Dim Item As Object
    Dim olItem As Object ' MailItem
    Dim objMsg As Object ' MailItem
   
    Set objMsg = olApp.CreateItem(olMailItem)
    Dim Filtered_Results As Object
   
    'Apply filter in outlook
    SFILTER = "[ReceivedTime]>'" & Format(Date, "DDDDD HH:NN") & "'"
    Set Filtered_Results = Main_Folder.Items.Restrict(SFILTER)
   
    'Date and Time for subject line
    T1 = Format(TimeValue(Now), "hh:mm AM/PM")
     D = Format(Date, "DD") & "/" & Format(Date, "MM") & "/" & Format(Date, "YYYY")
    
    
     'Check all mailItem which has Red Flag in search results (Restrict)
     
      For Each Item In Filtered_Results
        If TypeOf Item Is Outlook.MailItem Then
           
            MailRT = Item.ReceivedTime
            flagclr = Item.FlagIcon
           
            If flagclr = 6 Then
                    '3am to 2:30pm
                    'If TimeValue(currTime) >= TimeValue("3:00:00") And TimeValue(currTime) < TimeValue("14:30:00") Then
                If TimeValue(MailRT) >= mac.Range("A15").Value And TimeValue(MailRT) < mac.Range("B15").Value Then
                    With objMsg
                        .To = mac.Range("a10").Value
                        .CC = mac.Range("b10").Value
                        .Body = "Hi All," & vbNewLine & mac.Range("d11").Value
                        .Subject = mac.Range("c10").Value & " " & "(" & T1 & ")" & " - " & D  'Add Date and time to subject
                        .Attachments.Add Item
                        .Display
                      '.send
                    End With
                End If
            End If
        End If
    Next
              
 
  MsgBox "Macro Successful Time Taken " & Format(Timer - StartTime, "00:00") & " Seconds"
              
          
End Sub

Sub PickOutlookFolder()
    Dim objNS As Object ' Namespace
    Dim objFolder As Object
    Dim strFolderPath As String
    Dim strEntryID As String
    'Set Outlook Object
    Dim olApp As Object ' Outlook.Application
    Set olApp = CreateObject("Outlook.Application") ' New Outlook.Application

    Set objNS = olApp.GetNamespace("MAPI")
    Set objFolder = objNS.PickFolder
    If TypeName(objFolder) <> "Nothing" Then
        strFolderPath = objFolder.Folderpath
        strEntryID = objFolder.EntryID
    End If
    mac.Range("b4").Value = strFolderPath
   
End Sub


Function GetOLFolder(ByVal Folderpath As String, olApp As Object) As Object
'Convert a string folder path to actual folder object, which lets you retrieve various folder properties
    Dim TestFolder      As Object ' Outlook.Folder
    Dim FoldersArray    As Variant
    Dim i               As Integer

    On Error GoTo GetFolder_Error
    If Left(Folderpath, 2) = "\\" Then
        Folderpath = Right(Folderpath, Len(Folderpath) - 2)
    End If
    'Convert folderpath to array
    FoldersArray = Split(Folderpath, "\")
    Set TestFolder = olApp.Session.Folders.Item(FoldersArray(0))
    If Not TestFolder Is Nothing Then
        For i = 1 To UBound(FoldersArray, 1)
            Dim SubFolders As Object ' Outlook.Folders
            Set SubFolders = TestFolder.Folders
            Set TestFolder = SubFolders.Item(FoldersArray(i))
            If TestFolder Is Nothing Then
                Set GetOLFolder = Nothing
            End If
        Next
    End If

    'Return the TestFolder
    Set GetOLFolder = TestFolder
    Exit Function

GetFolder_Error:
    Set GetOLFolder = Nothing
    Exit Function
End Function
 

Mallesh23

Well-known Member
Joined
Feb 4, 2009
Messages
853
Office Version
  1. 2010
Platform
  1. Windows
Hi 6StringJazzer,
Thanks for your help, When run on actual data
Through early binding code it worked, But when I removed Microsoft Outlook reference for Late binding ,

Got Error on below lines.

Dim Filtered_Results As folder
Compile Error , user defined type not defined.


If TypeOf Item Is Outlook.MailItem Then
' Compile Error , user defined type not defined.

.Attachments.Add Item
' Connection to the server is unavailable, outlook must be online or connected to complete this action.

Thanks once again for your help !!


Regards,
mg
 

6StringJazzer

Well-known Member
Joined
Jan 27, 2010
Messages
802
Office Version
  1. 365
Platform
  1. Windows
Dim Filtered_Results As folder
Compile Error , user defined type not defined.
Declare as Object instead of Folder

If TypeOf Item Is Outlook.MailItem Then
' Compile Error , user defined type not defined.
This is a difficult one. In late binding, a MailItem would be declared as an Object but then the TypeOf operator would return False. So we need a different way to determine the item type. I have used this:

At the top of the module, with the other constant, add
VBA Code:
Const olMail = 43

Then replace the line above with
VBA Code:
 If Item.Class = olMail

.Attachments.Add Item
' Connection to the server is unavailable, outlook must be online or connected to complete this action.
I do not recognize this error. If we can resolve all the other errors then we can return to this one.
 

Watch MrExcel Video

Forum statistics

Threads
1,126,965
Messages
5,621,871
Members
415,862
Latest member
nascaline

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Top