Email Macro to add Date and Classification

Status
Not open for further replies.

Alison P

New Member
Outlook version
Email Account
Hi There, Can anyone help please? We have an email Macro for adding the date as a prefix before the subject and a classification at the end of the subject. i.e 20141007-Help with Macros-OS, it also adds Release-Authorised to the front of that if it picks up an @ in the email address.
We need to remove the Release-Authorised as it is not required now.

Can anyone help please? I am a complete biff with Code, also there are bits that don't work on this code, it doesnt recognise if there is a date on it already etc.

Here is the long code


Const AUTH = "release-authorised: " 'String to be prefixed to outgoing
Subject
Const MAX_DAYS_VALID = 7 'Number of days within which an existing date is
regarded as current
Const MAX_DISPLAYED_SUBJECT = 100 'Maximum no. of characters subject
displayed by macro
Dim mstrNewSubject As String 'This holds the proposed new Subject, prior to
it being applied to the email
Dim mstrNewSubject1 As String 'This holds the proposed new Subject, prior
to it being applied to the email
Dim mstrNewSubject2 As String 'This holds the proposed new Subject, prior
to it being applied to the email
Option Explicit
Private Sub Application_ItemSend(ByVal Item As Object, Cancel As Boolean)
'Changed the code to give the option of not putting a date prefix, how ever
is a bit
'of a bodge RORY
Dim intReply As Integer 'rory
If TypeOf Item Is Outlook.MailItem Then
intReply = MsgBox("Do you wish to add a date prefix?", vbYesNo +
vbMsgBoxSetForeground + vbQuestion, "Date Prefix") 'rory
If intReply = vbYes Then 'rory
CheckDatePrefix Item, Cancel
If Not Cancel Then
InternetAuthorise Item, Cancel
End If
Else
InternetAuthorise Item, Cancel
End If
If Cancel Then
MsgBox "The email remains open in another window.", _
vbOKOnly + vbInformation + vbMsgBoxSetForeground, _
"Email not sent!"
End If
End If
End Sub
'Decides whether add a date prefix to subject
'Only applies if subject does not already start with "Re:" or "Fw:"
Private Sub CheckDatePrefix(ByVal Item As MailItem, ByRef Cancel As
Boolean)
With Item
mstrNewSubject = .Subject
mstrNewSubject1 = .Subject
mstrNewSubject2 = .Subject
If SubjectNeedsChange(Item) Then
'Check with user
mstrNewSubject1 = (Format(Now, "YYYYMMDD") & "-" &
mstrNewSubject & "-OS")
mstrNewSubject2 = (Format(Now, "YYYYMMDD") & "-" &
mstrNewSubject & "")
'mstrNewSubject2 = (Format(Now, "YYYYMMDD") & "-U-" &
mstrNewSubject)
Select Case MsgBox("Is this email Official with no Sensitivity
(Unclassified)?" & vbCrLf & vbCrLf & vbCrLf & _
"Yes - Change subject to """ & Shorten(mstrNewSubject2)
& """" & vbCrLf & vbCrLf & _
"No - Change subject to """ & Shorten(mstrNewSubject1)
& """" & vbCrLf & vbCrLf & _
"Click ""Cancel"" to prevent this email being sent.", _
vbYesNoCancel + vbDefaultButton1 +
vbMsgBoxSetForeground + vbQuestion, _
"Sending email - Include today's date in Subject?")
Case vbYes 'Change string
.Subject = mstrNewSubject2
Case vbNo 'Send as normal
.Subject = mstrNewSubject1
Case vbCancel 'Cancel send
Cancel = True
End Select
End If
End With

End Sub
'Is a valid date already present?
Private Function SubjectNeedsChange(Item As MailItem) As Boolean
Dim strDate As String, varDate As Variant
Dim blnNearDate As Boolean ' True = date found within MAX_DAYS_VALID
With Item
SubjectNeedsChange = True
'Is "-" in position 9
'Check for YYYYMMDD being within MAX_DAYS_VALID days of today
If Mid(mstrNewSubject, 9, 1) = "-" Then
'Convert to dd/mm/yyyy
strDate = Mid(mstrNewSubject, 7, 2) & "/" & Mid(mstrNewSubject,
5, 2) & "/" & Left(mstrNewSubject, 4)
If IsDate(strDate) Then
'A valid date has been found - Is it within MAX_DAYS_VALID
days of today?
blnNearDate = Abs(Now - CVDate(strDate)) < MAX_DAYS_VALID
If blnNearDate Then
'Date is same / near today - therefore no change needed
SubjectNeedsChange = False
Else
'Remove existing date from start of subject
mstrNewSubject = Trim(Mid(mstrNewSubject, 10))
End If
End If
'Is "-" in position 7
'Check for YYMMDD being within MAX_DAYS_VALID days of today
ElseIf Mid(mstrNewSubject, 7, 1) = "-" Then
'Convert to dd/mm/yyyy
strDate = Mid(mstrNewSubject, 5, 2) & "/" & Mid(mstrNewSubject,
3, 2) & "/20" & Left(mstrNewSubject, 2)
If IsDate(strDate) Then
'A valid date has been found - Is it within MAX_DAYS_VALID
days of today?
blnNearDate = Abs(Now - CVDate(strDate)) < MAX_DAYS_VALID
If blnNearDate Then
'Date is same / near today - therefore no change needed
SubjectNeedsChange = False
Else
'Remove existing date from start of subject
mstrNewSubject = Trim(Mid(mstrNewSubject, 10))
End If
End If
End If
End With
End Function
Private Function Shorten(Subject As String) As String
'Returns a string not longer than MAX_DISPLAYED_SUBJECT
'If truncated, then adds ...
Select Case Len(Subject)
Case Is > MAX_DISPLAYED_SUBJECT
Shorten = Left(Subject, MAX_DISPLAYED_SUBJECT - 3) & "..."
Case Else
Shorten = Subject
End Select
End Function
'==========================================================================
'Decides whether to add Internet-authorised: to subject
Private Sub InternetAuthorise(ByVal Item As MailItem, ByRef Cancel As
Boolean)
With Item
'If internet authorised not yet added, and if to, cc or bcc contain
"@" then
If Not LeftMatch(.Subject, AUTH) And IsSMTP_Recipient(Item) Then
Select Case MsgBox("This email contains addressees which may
require it to be sent over the" & vbCrLf & _
"Internet." & vbCrLf & vbCrLf & _
"Official Sensitive material is only to be sent over
the internet" & vbCrLf & _
"in execptional circumstances. If this information is
compromised" & vbCrLf & _
"you will be held accountable. Check GSC guidance if in
doubt" & vbCrLf & vbCrLf & _
"Click ""Yes"" to authorise for the Internet and send."
& vbCrLf & _
"Click ""No"" to send as is (without Internet
authorisation)." & vbCrLf & _
"Click ""Cancel"" to prevent this email being sent.", _
vbYesNoCancel + vbDefaultButton2 +
vbMsgBoxSetForeground + vbQuestion, _
"Sending email - Internet Authorisation?")
Case vbYes 'Remove any existing auth string
' and add new one on left
.Subject = AUTH & RemoveString(.Subject, AUTH)
Case vbNo 'Send as Normal
Case vbCancel 'Cancel send
Cancel = True
End Select
End If
End With
End Sub
Private Function IsSMTP_Recipient(Item As Outlook.MailItem) As Boolean
Dim rcp As Recipient

For Each rcp In Item.Recipients 'Check recipients
With rcp
Select Case .Type
Case olTo, olCC, olBCC
'If "@" found in a recipient's address,
'signal this and exit immediately
If InStr(.Address, "@") Then
IsSMTP_Recipient = True
Exit Function
End If
Case Else
'Do nothing
End Select
End With
Next rcp
End Function
Private Function LeftMatch(Text As String, Match As String) As Boolean
LeftMatch = UCase(Left(Text, Len(Match))) = UCase(Match)
End Function

Private Function RemoveString(ByVal Text As String, Match As String) As
String
'Searches for Match in Text, and removes any instances
Dim intpos As Integer
Dim strUpperT As String, strUpperM As String
strUpperT = UCase(Text)
strUpperM = UCase(Match)
Do
intpos = InStr(strUpperT, strUpperM)
If intpos = 0 Then Exit Do

Text = Left(Text, intpos - 1) & Mid(Text, intpos + Len(Match))
'Update Uppercase string
strUpperT = Left(strUpperT, intpos - 1) & Mid(strUpperT, intpos +
Len(Match))
Loop
RemoveString = Text
End Function
 

Attachments

  • Email Macro 07102014.txt
    9.9 KB · Views: 664
Well, the super easy methis is to replace this:
Const AUTH = "release-authorised: " 'String to be prefixed to outgoing
Subject

with this
Const AUTH = "" 'String to be prefixed to outgoing
Subject

The correct way is to remove that line and remove auth from this line:
.Subject = AUTH & RemoveString(.Subject, AUTH)

actually, since it only adds and removes the auth string, you could delete the entire line, unless you need it removed from existing messages still in the system.
 
Diane, you're a star. Thank you so much, it's all up and running again. I must get myself a book so I can learn about code. Thanks again
 
Status
Not open for further replies.
Similar threads
Thread starter Title Forum Replies Date
P How do I create a macro to add contacts from email messages? Outlook VBA and Custom Forms 1
Witzker Outlook 2019 Macro to seach in all contact Folders for marked Email Adress Outlook VBA and Custom Forms 1
J Outlook 365 Outlook Macro to Sort emails by column "Received" to view the latest email received Outlook VBA and Custom Forms 0
J Macro to send email as alias Outlook VBA and Custom Forms 0
M Outlook Macro to save as Email with a file name format : Date_Timestamp_Sender initial_Email subject Outlook VBA and Custom Forms 0
Witzker Outlook 2019 Macro to send an Email Template from User Defined Contact Form Outlook VBA and Custom Forms 0
V Macro to mark email with a Category Outlook VBA and Custom Forms 4
D VBA Macro to Print and Save email to network location Outlook VBA and Custom Forms 1
A Outlook 2016 Macro to Reply, ReplyAll, or Forward(but with composing new email) Outlook VBA and Custom Forms 0
W Macro to Filter Based on Latest Email Outlook VBA and Custom Forms 6
S Macro to extract email addresses of recipients in current drafted email and put into clipboard Outlook VBA and Custom Forms 2
S Macro to move “Re:” & “FWD:” email recieved the shared inbox to a subfolder in outlook Outlook VBA and Custom Forms 0
S Macro or plug-in to see if specific person was included in this email Outlook VBA and Custom Forms 4
R Help Revising VBA macro to delete email over different time span Outlook VBA and Custom Forms 0
Healy Consultants Macro to remove inside organization distribution list email address when reply to all recepients Outlook VBA and Custom Forms 0
O Run macro automatically at sending an email Using Outlook 11
M Adding Macro to populate "to" "subject" "body" not deleting email string below. Outlook VBA and Custom Forms 5
B VBA Macro for assigning multiple Categories to an email in my Inbox Outlook VBA and Custom Forms 1
Sabastian Samuel HOW DO I FORWARD AN EMAIL WITH MACRO using an email that in the body of another email Outlook VBA and Custom Forms 3
A Forward Outlook Email by Filtering using Macro Rule Outlook VBA and Custom Forms 44
nathandavies Email Details to Excel & Save as .MSG on one macro - combination of 2 macros Outlook VBA and Custom Forms 3
R Macro to copy email to excel - Runtime Error 91 Object Variable Not Set Outlook VBA and Custom Forms 11
Diane Poremsky Use Word Macro to Apply Formatting to Email Using Outlook 0
Diane Poremsky Use a macro to copy data in Outlook email to Excel workbook Using Outlook 0
B Macro To Create Rule To Export From Certain Folder Email Information in one workbook multiple sheets Outlook VBA and Custom Forms 0
B Macro to delay email Outlook VBA and Custom Forms 0
H send reminder if no reply received on first or original email using macro Using Outlook 2
D Macro to scan email distribution list when replying Using Outlook 2
G VBA/Macro to remove page colour when replying or forwarding email Outlook VBA and Custom Forms 2
K Macro Not Executing then send email from Explorer Outlook VBA and Custom Forms 3
C Macro to send email after changing from address and adding signature Outlook VBA and Custom Forms 1
Bachelle Macro to Update Existing Task from New Email Outlook VBA and Custom Forms 3
Diane Poremsky Use a macro to copy data in Outlook email to Excel workbook Using Outlook 0
A Create Macro for hyperlink(email) in message body Outlook VBA and Custom Forms 9
J Macro for replying to One Email with another Using Outlook 1
W Macro to forward email Outlook VBA and Custom Forms 2
T Using a macro to send email to diffrent address Outlook VBA and Custom Forms 1
S Editing an email with notes and saving it for record using Macro Outlook VBA and Custom Forms 3
G email returns after running macro to move emails Outlook VBA and Custom Forms 1
divan Macro to format email in a certain folder then forward to email address Using Outlook 3
P Is it possible to write a macro to email to all addresses of selected contacts? Using Outlook 1
M Macro to Format certain words in email message Outlook VBA and Custom Forms 5
M Use a macro to send files by email Outlook VBA and Custom Forms 3
G Rule starting a VB macro against incoming email Outlook VBA and Custom Forms 3
P Macro/Alert for unreceived email Outlook VBA and Custom Forms 1
B Auto reply using macro include original email Using Outlook 4
Aussie Looking for Outlook macro to Copy Recipient Names into Email Body Outlook VBA and Custom Forms 3
A Macro to copy email body to new email Outlook VBA and Custom Forms 5
H Macro to file Outlook email by sender's email address Using Outlook 11
J Macro generating email using default signature and hyperlink Outlook VBA and Custom Forms 5

Similar threads

Back
Top