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
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
