VBA Outlook, Extract flagged mailitem of specified time

Mallesh23

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

I am using below code which works on my system, But its not working on Client System.
Client is using outlook 2010...... but his flagged mailitem is in shared folder of outlook.

Task is it has to select flagged mailitem of specified time selected by user from Dropdown.
all those mailitem has to be attached to new mail.

Can you suggest whats wrong with the below Code, or is it because user is using Shared outlook folder.

VBA Code:
 Sub PickOutlookFolder_Path()
    Dim objNS As Namespace
    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


Public filename As String
Public path As String
Public objFolder As Folder
Sub FX_Broker()

   If mac.Range("b4").Value = "" Then
        MsgBox " Your Master Workbooks File path should not be Blank", vbCritical, "Fx Broker"
        Exit Sub
    End If

StartTime = Timer

Dim objApp As Outlook.Application
Set objApp = New Outlook.Application
Dim objMail As Outlook.MailItem
Set objNS = GetNamespace("MAPI")
Dim olFolder As Outlook.MAPIFolder
Dim myNewFolder As Outlook.MAPIFolder
Set olFolder = objNS.GetDefaultFolder(olFolderInbox)
Set objFolder = objFolder


Dim Item As Object
Dim olItem As MailItem
Dim objMsg As MailItem
Dim objMsg2 As MailItem
Dim objMsg3 As MailItem

Set objMsg = objApp.CreateItem(olMailItem)
Set objMsg2 = objApp.CreateItem(olMailItem)
Set objMsg3 = objApp.CreateItem(olMailItem)




SFILTER = "[ReceivedTime]>'" & Format(Date, "DDDDD HH:NN") & "'"

Debug.Print vbCr & SFILTER
Set oOlResults = objFolder.Items.Restrict(SFILTER)


t1 = Format(TimeValue(Now), "hh:mm AM/PM")

d = Format(Date, "DD") & "/" & Format(Date, "MM") & "/" & Format(Date, "YYYY")
t = Time
Dim currTime As Date
currTime = Time()



For Each Item In oOlResults
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
        If TimeValue(MailRT) >= TimeValue("3:00:00") And TimeValue(MailRT) < TimeValue("14:30:00") 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
              .Attachments.Add Item
              .Display
              '.send
            End With
        End If
        End If

       '2:30pm to 6:30pm
        If TimeValue(MailRT) >= mac.Range("A15").Value And TimeValue(MailRT) < mac.Range("B15").Value Then
        If TimeValue(MailRT) >= TimeValue("14:30:00") And TimeValue(MailRT) < TimeValue("18:30:00") Then
           With objMsg2
              .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
              On Error Resume Next
              .Attachments.Add Item
              .Display
              '.send
            End With
        End If
    End If
      '6:30pm to 10:30pm
        If TimeValue(MailRT) >= mac.Range("A15").Value And TimeValue(MailRT) < mac.Range("B15").Value Then
       'If TimeValue(currTime) >= TimeValue("18:30:00") And TimeValue(currTime) < TimeValue("22:30:00") Then
      If TimeValue(MailRT) >= TimeValue("18:30:00") And TimeValue(MailRT) < TimeValue("22:30:00") Then
           With objMsg3
              .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
                   On Error Resume Next
              .Attachments.Add Item
              .Display
              '.send
            End With
            End If
        End If
     
    End If
End If


nxt:
Next
'GoTo nxt
    MsgBox "Macro Successful Time Taken " & Format(Timer - StartTime, "00:00") & " Seconds."
         
End Sub


Thanks
mg
 

Attachments

  • Time_Slot.png
    Time_Slot.png
    30.2 KB · Views: 2

Some videos you may like

Excel Facts

Remove leading & trailing spaces
Save as CSV to remove all leading and trailing spaces. It is faster than using TRIM().

Watch MrExcel Video

Forum statistics

Threads
1,123,377
Messages
5,601,264
Members
414,439
Latest member
norideen

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