In this exam I get the number of "attachment file" for an email in draft data.
Is there any way to get the name of this file in a msgbox or combobox or anything?
Private Sub CommandButton2_Click()
Dim a As Attachments
Dim myitem As Folder
Dim myitem1 As MailItem
Set myitem = Session.GetDefaultFolder(olFolderDrafts)
Dim i As Integer
For i = 1 To myitem.Items.Count
If myitem.Items(i) = test1 Then
Set myitem1 = myitem.Items(i)
Set a = myitem1.Attachments
MsgBox a.Count
End If
Next
End Sub
Private Sub CommandButton2_Click()
Dim a As Attachments
Dim myitem As Folder
Dim myitem1 As MailItem
Dim j As Long
Dim i As Integer
Set myitem = Session.GetDefaultFolder(olFolderDrafts)
For i = 1 To myitem.Items.Count
If myitem.Items(i) = test1 Then
Set myitem1 = myitem.Items(i)
Set a = myitem1.Attachments
MsgBox a.Count
' added this code
For j = 1 To myitem1.Attachments.Count
MsgBox myitem1.Attachments.Item(i).DisplayName ' or .Filename
Next j
End If
Next i
End Sub
Related
I have written a macro to open the path to a selected email in the results of the Outlook search.
The email is not automatically marked in the open folder so I search for the email in "ActiveExplorer". With .display, I can open the email, but I could not find a way to select the found email in "ActiveExplorer".
Public Sub MailOrdnerPfad()
Dim obj As Object
Dim Ordner As Outlook.MAPIFolder
Dim Betreff As String
Dim Mail As MailItem
Set obj = Application.ActiveWindow
If TypeOf obj Is Outlook.Inspector Then
Set obj = obj.CurrentItem
Else
Set obj = obj.Selection(1)
End If
Betreff = obj.ConversationTopic
Set Ordner = obj.Parent
Set Application.ActiveExplorer.CurrentFolder = Ordner
For Each Mail In Ordner.Items
If Mail.ConversationTopic = Betreff Then
Mail.Display
Exit For
End If
Next
End Sub
Clear the original selection then add the found item.
Option Explicit
Public Sub MailOrdnerPfad()
Dim obj As Object
Dim Ordner As Folder
Dim ordItem As Object
Dim Betreff As String
Dim myMail As MailItem
Set obj = ActiveWindow
If TypeOf obj Is Inspector Then
Set obj = obj.CurrentItem
Else
Set obj = obj.Selection(1)
End If
If obj.Class = olMail Then
Betreff = obj.ConversationTopic
Debug.Print "Betreff: " & Betreff
Set Ordner = obj.Parent
Set ActiveExplorer.CurrentFolder = Ordner
Debug.Print "Ordner.: " & Ordner
For Each ordItem In Ordner.items
If ordItem.Class = olMail Then
Set myMail = ordItem
Debug.Print "myMail.ConversationTopic: " & myMail.ConversationTopic
If myMail.ConversationTopic = Betreff Then
ActiveExplorer.ClearSelection
' myMail.Display
ActiveExplorer.AddToSelection myMail
Exit For
End If
End If
Next
End If
End Sub
I have a shared inbox that has several subfolders.
I want to use the subfolder names as the category for each email inside the relevant subfolder instead of creating a category and a rule for each folder.
As an example, I want to auto categorize the emails in "Support" with "Project A - Support" and the emails in "Project A" with "Project A"
Inbox
Project A
Support
Project B
Project C
Private WithEvents Items As Outlook.Items
Private Const AUTO_CATEGORY As String = "(test)"
Private Sub Application_Startup()
Dim Ns As Outlook.NameSpace
Dim Inbox As Outlook.MAPIFolder
Dim Subfolder As Outlook.MAPIFolder
Set Ns = Application.GetNamespace("MAPI")
Set Inbox = Ns.GetDefaultFolder(olFolderInbox)
Set Subfolder = Inbox.Folders
Set Items = Subfolder.Items
End Sub
Private Sub Items_ItemAdd(ByVal Item As Object)
Dim Cats() As String
Dim i&
Dim Exists As Boolean
If Len(Item.Categories) Then
Cats = Split(Item.Categories, ";")
For i = 0 To UBound(Cats)
If LCase$(Cats(i)) = LCase$(AUTO_CATEGORY) Then
Exists = True
Exit For
End If
Next
If Exists = False Then
Item.Categories = Item.Categories & ";" & AUTO_CATEGORY
Item.Save
End If
Else
Item.Categories = AUTO_CATEGORY
Item.Save
End If
End Sub
ItemAdd is as tedious as rules. You need code for each folder.
Option Explicit
Private WithEvents SubfolderProjectAItems As Items
Private WithEvents SubfolderProjectASupportItems As Items
Private WithEvents SubfolderProjectBItems As Items
Private WithEvents SubfolderProjectCItems As Items
Private Sub Application_Startup()
Dim myInbox As folder
Dim SubfolderProjectA As folder
Dim SubfolderProjectASupport As folder
Dim SubfolderProjectB As folder
Dim SubfolderProjectC As folder
Set Inbox = Session.GetDefaultFolder(olFolderInbox)
Set SubfolderProjectA = Inbox.folders("Project A")
Set SubProjectAItems = SubfolderProjectA.Items
Set SubfolderProjectASupport = SubfolderProjectA.folders("Support")
Set SubfolderProjectASupportItems = SubfolderProjectASupport.Items
Set SubfolderProjectB = Inbox.folders("Project B")
Set SubfolderProjectBItems = SubfolderProjectB.Items
Set SubfolderProjectC = Inbox.folders("Project C")
Set SubfolderProjectCItems = SubfolderProjectC.Items
End Sub
Private Sub testPA()
SubfolderProjectA_ItemAdd ActiveInspector.currentItem
End Sub
Private Sub SubfolderProjectA_ItemAdd(ByVal Item As Object)
Dim catStr As String
catStr = Item.Parent
If InStr(Item.categories, catStr) = 0 Then
Item.categories = Item.categories & ";" & catStr
Item.Save
End If
End Sub
Private Sub testPASupport()
SubfolderProjectASupportItems_ItemAdd ActiveInspector.currentItem
End Sub
Private Sub SubfolderProjectASupportItems_ItemAdd(ByVal Item As Object)
Dim catStr As String
catStr = Item.Parent.Parent & " - " & Item.Parent
If InStr(Item.categories, catStr) = 0 Then
Item.categories = Item.categories & ";" & catStr
Item.Save
End If
End Sub
I have a script that works on my main inbox. It will move the email to a sub folder when a category is assigned. The sub folder is the same name as the category.
How do I modify the code to reference a shared mailbox?
My code that works on main inbox:
Private WithEvents xInboxFld As Outlook.Folder
Private WithEvents xInboxItems As Outlook.Items
Private Sub Application_Startup()
Set xInboxFld = Outlook.Application.Session.GetDefaultFolder(olFolderInbox)
Set xInboxItems = xInboxFld.Items
End Sub
Private Sub xInboxItems_ItemChange(ByVal Item As Object)
Dim xMailItem As Outlook.MailItem
Dim xFlds As Outlook.Folders
Dim xFld As Outlook.Folder
Dim xTargetFld As Outlook.Folder
Dim xFlag As Boolean
On Error Resume Next
If Item.Class = olMail Then
Set xMailItem = Item
xFlag = False
If xMailItem.Categories <> "" Then
Set xFlds = Application.Session.GetDefaultFolder(olFolderInbox).Folders
If xFlds.Count <> 0 Then
For Each xFld In xFlds
If xFld.Name = xMailItem.Categories Then
xFlag = True
End If
Next
End If
If xFlag = False Then
Application.Session.GetDefaultFolder(olFolderInbox).Folders.Add xMailItem.Categories, olFolderInbox
End If
Set xTargetFld = Application.Session.GetDefaultFolder(olFolderInbox).Folders(xMailItem.Categories)
xMailItem.Move xTargetFld
End If
End If
End Sub
I was able to get it working with the below
Option Explicit
Private WithEvents SharedInboxFld As Outlook.Folder
Private WithEvents SharedInboxItems As Outlook.Items
Private Sub Application_Startup()
Set SharedInboxFld = Outlook.Application.Session.Folders.Item("Shared MailboxName").Folders("Inbox") 'use the appropriate folder name
Set SharedInboxItems = SharedInboxFld.Items
End Sub
Private Sub SharedInboxItems_ItemChange(ByVal Item As Object)
Dim xFlds As Outlook.Folders
Dim xFld As Outlook.Folder
Dim xTargetFld As Outlook.Folder
Dim xFlag As Boolean
On Error Resume Next
If Item.Class = olMail Then
xFlag = False
If Item.Categories <> "" Then
Set xFlds = SharedInboxFld.Folders
If xFlds.Count <> 0 Then
For Each xFld In xFlds
If xFld.Name = Item.Categories Then
xFlag = True
End If
Next
End If
If xFlag = False Then
SharedInboxFld.Folders.Add Item.Categories, olFolderInbox
End If
Set xTargetFld = SharedInboxFld.Folders(Item.Categories)
Item.Move xTargetFld
End If
End If
End Sub
Instead of GetDefaultFolder, call Outlook.Application.Session.CreateRecipient, and pass the returned Recipient object to GetSharedDefaultFolder.
We have a team email address that we CC for most correspondence, and then we all get a copy of all emails.
The problem is when we then reply all, and a team member has already been in the email chain that person will get the email 2 times.
This is what I tried.
Private Sub RemoveRecipientsWhenItemSend(Item As Outlook.MailItem)
Dim RemoveAddrList As VBA.Collection
Dim InfoAddrList As VBA.Collection
Dim Recipients As Outlook.Recipients
Dim aRecipient As Outlook.Recipient
Dim bRecipient As Outlook.Recipient
Dim i
Dim j
Dim a
Dim b
Dim info As Boolean
info = False
Set RemoveAddrList = New VBA.Collection
Set InfoAddrList = New VBA.Collection
InfoAddrList.Add "team#company.com"
RemoveAddrList.Add "member1#company.com"
RemoveAddrList.Add "member2#company.com"
Set Recipients = Item.Recipients
For i = Recipients.Count To 1 Step -1
Set aRecipient = Recipients.Item(i)
For j = 1 To InfoAddrList.Count
If LCase$(aRecipient.Address) = LCase$(InfoAddrList(j)) Then
For a = Recipients.Count To 1 Step -1
Set bRecipient = Recipients.Item(a)
For b = 1 To RemoveAddrList.Count
If LCase$(aRecipient.Address) = LCase$(RemoveAddrList(b)) Then
Recipients.Remove i
Exit For
End If
Next
Next
Exit For
End If
Next
Next
End Sub
Private Sub Application_ItemSend(ByVal Item As Object, Cancel As Boolean)
On Error Resume Next
RemoveRecipientsWhenItemSend Item
End Sub
A few Debug.Print statements proved helpful.
Option Explicit
Private Sub RemoveRecipientsWhenItemSend(Item As Outlook.mailitem)
Dim RemoveAddrList As VBA.Collection
Dim InfoAddrList As VBA.Collection
Dim Recipients As Outlook.Recipients
Dim aRecipient As Outlook.Recipient
Dim bRecipient As Outlook.Recipient
Dim i
Dim j
Dim a
Dim b
Dim info As Boolean
info = False
Set RemoveAddrList = New VBA.Collection
Set InfoAddrList = New VBA.Collection
InfoAddrList.Add "team#company.com"
RemoveAddrList.Add "member1#company.com"
RemoveAddrList.Add "member2#company.com"
Set Recipients = Item.Recipients
For i = Recipients.count To 1 Step -1
Set aRecipient = Recipients.Item(i)
For j = 1 To InfoAddrList.count
Debug.Print LCase$(aRecipient.Address)
Debug.Print LCase$(InfoAddrList(j))
If LCase$(aRecipient.Address) = LCase$(InfoAddrList(j)) Then
For a = Recipients.count To 1 Step -1
'Set bRecipient = Recipients.Item(a)
Set aRecipient = Recipients.Item(a)
For b = 1 To RemoveAddrList.count
Debug.Print vbCr & " a: " & a
Debug.Print " LCase$(aRecipient.Address): " & LCase$(aRecipient.Address)
Debug.Print " LCase$(RemoveAddrList(b)): " & LCase$(RemoveAddrList(b))
If LCase$(aRecipient.Address) = LCase$(RemoveAddrList(b)) Then
'Recipients.Remove i
Recipients.Remove a
Exit For
End If
Next
Next
Exit For
End If
Next
Next
End Sub
Private Sub RemoveRecipientsWhenItemSend_test()
RemoveRecipientsWhenItemSend ActiveInspector.currentItem
End Sub
Here is something I use to remove the duplicate recipients.
Set olemail = olapp.CreateItemFromTemplate(OutlookTemplate)
With olemail
' other stuff
' check duplicate recipients
' first resolve email address per global address book
For Each Recipient In .Recipients
Recipient.Resolve
Next
' go through each recipients and check for dup
If .Recipients.count > 1 Then
For i = .Recipients.count To 2 Step -1
For j = i - 1 To 1 Step -1
If .Recipients(i) = .Recipients(j) Then
.Recipients.Remove (i)
i = i - 1
End If
Next j
Next i
End If
end with
m.display works but m.move(A) does not.
The folder exist.
Private Sub Application_NewMailEx(ByVal EntryIDCollection As String)
Dim arr() As String
Dim myInbox As Outlook.Folder
Dim A As Outlook.Folder
Set myNameSpace = Application.GetNamespace("MAPI")
Set myInbox =
myNameSpace.GetDefaultFolder(olFolderInbox)
Set A = myInbox.Folders("A")
Dim i As Integer
Dim m As MailItem
On Error Resume Next
arr = Split(EntryIDCollection, ",")
For i = 0 To UBound(arr)
Set m = Application.Session.GetItemFromID(arr(i))
If m.SenderEmailAddress = "notifications#transcore.com" Then
'MsgBox (m.Body)
m.Display
m.Move (A)
End If
Next
End Sub
Move is a function, not a sub. Move the message first, then display it:
set m = m.Move(A)
m.Display