D.Moore
Senior Member
- Outlook version
- Outlook 2016 64 bit
- Email Account
- Office 365 Exchange
Hi!
I would like to ask your kind help on a VBA macro problem.
I would like to achieve the following 4 tasks:
1. When I send a message in Outlook, a form pops-up requesting to select the folder, where I want to move save/move the message instead of the Sent Items folder.
2. When the message contains my own name (typically happen when I push REPLY ALL), remove it.
3. When a message arrives with attachment, check all attachments of the message and if the name of the attachment is "ATT*.txt" or "ATT*.htm" , remove these attachments, but only these.
4. Add an extra button to the form pops-up (nr.1 point above). When this button pushed (instead of selecting a folder or cancel button), then the message is moved to the Draft folder, INSTEAD of being sent.
I was able to put together a working code, which accomplish nr. 1 and 2 task successfully, but I am unable to accomplish the nr. 3 and 4 tasks. Here is the code below.
May I ask your kind help to modify it to be able to achieve nr. 3 and 4 too?
Many thanks for your time and support,
Moore
The code:
VERSION 1.0 CLASS
BEGIN
MultiUse = -1 'True
END
Attribute VB_Name = "ThisOutlookSession"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = True
'myInspector
Option Explicit
Dim WithEvents oAppInspectors As Outlook.Inspectors
Attribute oAppInspectors.VB_VarHelpID = -1
Dim WithEvents oMailInspector As Outlook.Inspector
Attribute oMailInspector.VB_VarHelpID = -1
Dim WithEvents oOpenMail As Outlook.MailItem
Attribute oOpenMail.VB_VarHelpID = -1
Private Sub Application_Startup()
Set oAppInspectors = Application.Inspectors
End Sub
Private Sub Application_Quit()
End Sub
Private Sub oAppInspectors_NewInspector(ByVal Inspector As Inspector)
'Ha nem uj email ablakk akkor exit
If Inspector.CurrentItem.Class <> olMail Then
Exit Sub
End If
Set oOpenMail = Inspector.CurrentItem
Set oMailInspector = Inspector
End Sub
Private Sub oOpenMail_Open(Cancel As Boolean)
'Ha van saját email a To/Cc-ben akkor kiszedi !
Dim i As Integer
Dim deli As Integer
deli = 0
For i = 1 To oOpenMail.Recipients.Count
If oOpenMail.Recipients.Item(i).Name = "!" Then
deli = i
End If
Next
If deli <> 0 Then
oOpenMail.Recipients.Remove (deli)
End If
'Berakja a From mezõbe a megfelelõ emailcím
'On Error Resume Next
'oOpenMail.SentOnBehalfOfName = "Fitness Trade - Bakos András"
'oOpenMail.BCC = " "
'On Error GoTo 0
End Sub
Private Sub oOpenMail_Close(Cancel As Boolean)
Set oOpenMail = Nothing
End Sub
Private Sub Application_ItemSend(ByVal Item As Object, _
Cancel As Boolean)
Dim objNS As NameSpace
Dim objFolder As MAPIFolder
Set objNS = Application.GetNamespace("MAPI")
Set objFolder = objNS.PickFolder
If TypeName(objFolder) <> "Nothing" And _
IsInDefaultStore(objFolder) Then
Set Item.SaveSentMessageFolder = objFolder
End If
Set objFolder = Nothing
Set objNS = Nothing
End Sub
Public Function IsInDefaultStore(objOL As Object) As Boolean
Dim objApp As Outlook.Application
Dim objNS As Outlook.NameSpace
Dim objInbox As Outlook.MAPIFolder
On Error Resume Next
Set objApp = CreateObject("Outlook.Application")
Set objNS = objApp.GetNamespace("MAPI")
Set objInbox = objNS.GetDefaultFolder(olFolderInbox)
Select Case objOL.Class
Case olFolder
'If objOL.StoreID = objInbox.StoreID Then
IsInDefaultStore = True
'End If
Case olAppointment, olContact, olDistributionList, _
olJournal, olMail, olNote, olPost, olTask
If objOL.Parent.StoreID = objInbox.StoreID Then
IsInDefaultStore = True
End If
Case Else
MsgBox "This function isn't designed to work " & _
"with " & TypeName(objOL) & _
" items and will return False.", _
, "IsInDefaultStore"
End Select
Set objApp = Nothing
Set objNS = Nothing
Set objInbox = Nothing
End Function
I would like to ask your kind help on a VBA macro problem.
I would like to achieve the following 4 tasks:
1. When I send a message in Outlook, a form pops-up requesting to select the folder, where I want to move save/move the message instead of the Sent Items folder.
2. When the message contains my own name (typically happen when I push REPLY ALL), remove it.
3. When a message arrives with attachment, check all attachments of the message and if the name of the attachment is "ATT*.txt" or "ATT*.htm" , remove these attachments, but only these.
4. Add an extra button to the form pops-up (nr.1 point above). When this button pushed (instead of selecting a folder or cancel button), then the message is moved to the Draft folder, INSTEAD of being sent.
I was able to put together a working code, which accomplish nr. 1 and 2 task successfully, but I am unable to accomplish the nr. 3 and 4 tasks. Here is the code below.
May I ask your kind help to modify it to be able to achieve nr. 3 and 4 too?
Many thanks for your time and support,
Moore
The code:
VERSION 1.0 CLASS
BEGIN
MultiUse = -1 'True
END
Attribute VB_Name = "ThisOutlookSession"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = True
'myInspector
Option Explicit
Dim WithEvents oAppInspectors As Outlook.Inspectors
Attribute oAppInspectors.VB_VarHelpID = -1
Dim WithEvents oMailInspector As Outlook.Inspector
Attribute oMailInspector.VB_VarHelpID = -1
Dim WithEvents oOpenMail As Outlook.MailItem
Attribute oOpenMail.VB_VarHelpID = -1
Private Sub Application_Startup()
Set oAppInspectors = Application.Inspectors
End Sub
Private Sub Application_Quit()
End Sub
Private Sub oAppInspectors_NewInspector(ByVal Inspector As Inspector)
'Ha nem uj email ablakk akkor exit
If Inspector.CurrentItem.Class <> olMail Then
Exit Sub
End If
Set oOpenMail = Inspector.CurrentItem
Set oMailInspector = Inspector
End Sub
Private Sub oOpenMail_Open(Cancel As Boolean)
'Ha van saját email a To/Cc-ben akkor kiszedi !
Dim i As Integer
Dim deli As Integer
deli = 0
For i = 1 To oOpenMail.Recipients.Count
If oOpenMail.Recipients.Item(i).Name = "!" Then
deli = i
End If
Next
If deli <> 0 Then
oOpenMail.Recipients.Remove (deli)
End If
'Berakja a From mezõbe a megfelelõ emailcím
'On Error Resume Next
'oOpenMail.SentOnBehalfOfName = "Fitness Trade - Bakos András"
'oOpenMail.BCC = " "
'On Error GoTo 0
End Sub
Private Sub oOpenMail_Close(Cancel As Boolean)
Set oOpenMail = Nothing
End Sub
Private Sub Application_ItemSend(ByVal Item As Object, _
Cancel As Boolean)
Dim objNS As NameSpace
Dim objFolder As MAPIFolder
Set objNS = Application.GetNamespace("MAPI")
Set objFolder = objNS.PickFolder
If TypeName(objFolder) <> "Nothing" And _
IsInDefaultStore(objFolder) Then
Set Item.SaveSentMessageFolder = objFolder
End If
Set objFolder = Nothing
Set objNS = Nothing
End Sub
Public Function IsInDefaultStore(objOL As Object) As Boolean
Dim objApp As Outlook.Application
Dim objNS As Outlook.NameSpace
Dim objInbox As Outlook.MAPIFolder
On Error Resume Next
Set objApp = CreateObject("Outlook.Application")
Set objNS = objApp.GetNamespace("MAPI")
Set objInbox = objNS.GetDefaultFolder(olFolderInbox)
Select Case objOL.Class
Case olFolder
'If objOL.StoreID = objInbox.StoreID Then
IsInDefaultStore = True
'End If
Case olAppointment, olContact, olDistributionList, _
olJournal, olMail, olNote, olPost, olTask
If objOL.Parent.StoreID = objInbox.StoreID Then
IsInDefaultStore = True
End If
Case Else
MsgBox "This function isn't designed to work " & _
"with " & TypeName(objOL) & _
" items and will return False.", _
, "IsInDefaultStore"
End Select
Set objApp = Nothing
Set objNS = Nothing
Set objInbox = Nothing
End Function