Help to clean up my code - Outlook VBA - add to subject line

[wish2bflying]

G'day all - I found this code and modified it to apply to ReplyAll and Forward as well as just Reply, but I'm no programmer. I couldn't work out how to turn the ReplyCurrentMailAndAddSubject() function into a "ActOnCurrentMailAndAddSubject()" function based on which button is actually pressed, so I had to create three separate functions for each of the modes. This works fine, but it offends my neat personality type. There should be a way of doing this with much less code, yes?

This should be easy for the experts out there. I'm no programmer, just use what I can find then get back to work!

Also I can't use the VB HTML Maker on my work computer so I apologise in advance for the dodgy formatting below.

Cheers,

wish2bflying

~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
Option Explicit
Private WithEvents ReplyButton As Office.CommandBarButton
Private WithEvents ReplyAllButton As Office.CommandBarButton
Private WithEvents ForwardButton As Office.CommandBarButton

Private Sub Application_Startup()
Set ReplyButton = Application.ActiveExplorer.CommandBars.FindControl(, 354)
Set ReplyAllButton = Application.ActiveExplorer.CommandBars.FindControl(, 355)
Set ForwardButton = Application.ActiveExplorer.CommandBars.FindControl(, 356)
End Sub

Private Sub ReplyButton_Click(ByVal Ctrl As Office.CommandBarButton, _
CancelDefault As Boolean)
CancelDefault = ReplyCurrentMailAndAddSubject
End Sub

Private Sub ReplyAllButton_Click(ByVal Ctrl As Office.CommandBarButton, _
CancelDefault As Boolean)
CancelDefault = ReplyAllCurrentMailAndAddSubject
End Sub

Private Sub ForwardButton_Click(ByVal Ctrl As Office.CommandBarButton, _
CancelDefault As Boolean)
CancelDefault = ForwardCurrentMailAndAddSubject
End Sub

Private Function ReplyCurrentMailAndAddSubject() As Boolean

Dim obj As Object
Dim oMail As Outlook.MailItem
Dim oReply As Outlook.MailItem
Dim oReplyAll As Outlook.MailItem
Dim oForward As Outlook.MailItem

Const FIX_SUBJECT As String = "[your special text here]"

Select Case True
Case TypeOf Application.ActiveWindow Is Outlook.Inspector
Set obj = Application.ActiveInspector.CurrentItem
Case Else
With Application.ActiveExplorer.Selection
If .Count Then
Set obj = .Item(1)
End If
End With
End Select

If TypeOf obj Is Outlook.MailItem Then
Set oMail = obj
Set oReply = oMail.Reply

If InStr(1, oReply.Subject, FIX_SUBJECT, vbTextCompare) = 0 Then
oReply.Subject = FIX_SUBJECT & oReply.Subject
End If

oReply.Display
ReplyCurrentMailAndAddSubject = True
End If
End Function

Private Function ReplyAllCurrentMailAndAddSubject() As Boolean

Dim obj As Object
Dim oMail As Outlook.MailItem
Dim oReply As Outlook.MailItem
Dim oReplyAll As Outlook.MailItem
Dim oForward As Outlook.MailItem

Const FIX_SUBJECT As String = "[your special text here]"

Select Case True
Case TypeOf Application.ActiveWindow Is Outlook.Inspector
Set obj = Application.ActiveInspector.CurrentItem
Case Else
With Application.ActiveExplorer.Selection
If .Count Then
Set obj = .Item(1)
End If
End With
End Select

If TypeOf obj Is Outlook.MailItem Then
Set oMail = obj
Set oReplyAll = oMail.ReplyAll

If InStr(1, oReplyAll.Subject, FIX_SUBJECT, vbTextCompare) = 0 Then
oReplyAll.Subject = FIX_SUBJECT & oReplyAll.Subject
End If

oReplyAll.Display
ReplyAllCurrentMailAndAddSubject = True
End If
End Function

Private Function ForwardCurrentMailAndAddSubject() As Boolean

Dim obj As Object
Dim oMail As Outlook.MailItem
Dim oReply As Outlook.MailItem
Dim oReplyAll As Outlook.MailItem
Dim oForward As Outlook.MailItem

Const FIX_SUBJECT As String = "[your special text here]"

Select Case True
Case TypeOf Application.ActiveWindow Is Outlook.Inspector
Set obj = Application.ActiveInspector.CurrentItem
Case Else
With Application.ActiveExplorer.Selection
If .Count Then
Set obj = .Item(1)
End If
End With
End Select

If TypeOf obj Is Outlook.MailItem Then
Set oMail = obj
Set oForward = oMail.Forward

If InStr(1, oForward.Subject, FIX_SUBJECT, vbTextCompare) = 0 Then
oForward.Subject = FIX_SUBJECT & oForward.Subject
End If

oForward.Display
ForwardCurrentMailAndAddSubject = True
End If
End Function

 

[wish2bflying]

did it myself

Amazing what a bit of perserverance can do!

~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~

Option Explicit
Private WithEvents ReplyButton As Office.CommandBarButton
Private WithEvents ReplyAllButton As Office.CommandBarButton
Private WithEvents ForwardButton As Office.CommandBarButton

Private Sub Application_Startup()
Set ReplyButton = Application.ActiveExplorer.CommandBars.FindControl(, 354)
Set ReplyAllButton = Application.ActiveExplorer.CommandBars.FindControl(, 355)
Set ForwardButton = Application.ActiveExplorer.CommandBars.FindControl(, 356)
End Sub

Private Sub ReplyButton_Click(ByVal Ctrl As Office.CommandBarButton, CancelDefault As Boolean)
CancelDefault = ActOnCurrentMailAndAddSubject(1)
End Sub

Private Sub ReplyAllButton_Click(ByVal Ctrl As Office.CommandBarButton, CancelDefault As Boolean)
CancelDefault = ActOnCurrentMailAndAddSubject(2)
End Sub

Private Sub ForwardButton_Click(ByVal Ctrl As Office.CommandBarButton, CancelDefault As Boolean)
CancelDefault = ActOnCurrentMailAndAddSubject(3)
End Sub

Private Function ActOnCurrentMailAndAddSubject(mControl As Integer) As Boolean

Dim obj As Object
Dim oMail As Outlook.MailItem
Dim oReply As Outlook.MailItem
Dim oReplyAll As Outlook.MailItem
Dim oForward As Outlook.MailItem

Const FIX_SUBJECT As String = "[your special text here] "

Select Case True
Case TypeOf Application.ActiveWindow Is Outlook.Inspector
Set obj = Application.ActiveInspector.CurrentItem
Case Else
With Application.ActiveExplorer.Selection
If .Count Then
Set obj = .Item(1)
End If
End With
End Select

If TypeOf obj Is Outlook.FormDescription Or TypeOf obj Is Outlook.MailItem Then
Set oMail = obj

If mControl = "1" Then
Set oReply = oMail.Reply
If InStr(1, oReply.Subject, FIX_SUBJECT, vbTextCompare) = 0 Then
oReply.Subject = FIX_SUBJECT & oReply.Subject
End If
oReply.Display
ActOnCurrentMailAndAddSubject = True
oMail.Close olDiscard

ElseIf mControl = "2" Then
Set oReplyAll = oMail.ReplyAll

If InStr(1, oReplyAll.Subject, FIX_SUBJECT, vbTextCompare) = 0 Then
oReplyAll.Subject = FIX_SUBJECT & oReplyAll.Subject
End If

oReplyAll.Display
ActOnCurrentMailAndAddSubject = True
oMail.Close olDiscard

ElseIf mControl = "3" Then
Set oForward = oMail.Forward

If InStr(1, oForward.Subject, FIX_SUBJECT, vbTextCompare) = 0 Then
oForward.Subject = FIX_SUBJECT & oForward.Subject
End If

oForward.Display
ActOnCurrentMailAndAddSubject = True
oMail.Close olDiscard

End If
End If
End Function