'Subject line macros for Outlook 'Version 1.3 Kathy Needham Ext. 4148 '13/03/06 ' '***PERFORM THE FOLLOWING FROM NOTEPAD *** ' Do not use other editors ' 'Make sure Word-Wrap is turned OFF ' (See menu Format-> Word Wrap) '--------------------------------------------------------------------------- 'To copy this to Visual Basic for Outlook. '========================================= '1) Press Ctrl-A then Ctrl C, to ' copy all of this file to the clipboard. ' '2) Switch to the Outlook main window. ' '3) Press Alt-F11 which will open a window ' headed "Microsoft Visual Basic ...". ' '4) At top left, ensure that "Project1" then ' "Microsoft Office Outlook Objects" ' are expanded. Click on "ThisOutlookSession" near top left, ' then click on the pane to the right of this. ' '5) If a previous version of this code is ' present, press Ctrl-A, which will select ' the whole file ' '6) Press Ctrl-V, to paste this code. If code was ' selected in step 5, then it will be replaced ' '7) Press Alt-F11 to switch to the main Outlook ' window. Send a test email, without any date at the ' start of the subject, and with at ' least one address containing the "@" sign). ' You should receive two prompts: The first asks ' whether you want the today's date added to the ' subject line; the second asks whether ' you want "Internet-authorised: " added to the ' subject line. ' '8) If all is well, Save (file > Save VBA Project.OB) exit from Outlook, and ' answer "Yes" when asked if you want to save ' Project1. This will make the changes permanent. ' '---------------------------------------------------------------------------- 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