Outlook Macro

[dhosi439]

I am trying to create a macro in Outlook to open a selected message in the inbox, append a string of text to the subject, then save, and close the open message.

This is what I have so far, the only step in the process that I still need is the ability to open the message when the macro is started. I can add the text to the subject, save, and close.

Option Explicit

Public Sub Application_InitialDH()
On Error Resume Next
    Dim MsgColl As Object
    Dim msg As Outlook.MailItem
    Dim objNS As Outlook.NameSpace
    Dim i As Long
    Dim subjectname As String
         
    Select Case TypeName(Application.ActiveWindow)
    Case "Explorer"
         ' a collection of selected items
        Set MsgColl = ActiveExplorer.Selection
        subjectname = MsgColl.Subject & " ~DH"
    Case "Inspector"
         ' only one item was selected
        Set msg = ActiveInspector.CurrentItem
        subjectname = msg.Subject & " ~DH"
    End Select
    On Error GoTo 0
     
    If (MsgColl Is Nothing) And (msg Is Nothing) Then
        GoTo ExitProc
    End If
    
    If Not MsgColl Is Nothing Then
        For i = 1 To MsgColl.Count
             ' set an obj reference to each mail item so we can move it
            Set msg = MsgColl.Item(i)
            With msg
                .Subject = subjectname
                .Close (olSave)
            End With
        Next i
    ElseIf Not msg Is Nothing Then
        msg.Subject = subjectname
        msg.Close (olSave)
    End If
ExitProc:
    Set msg = Nothing
    Set MsgColl = Nothing
    Set objNS = Nothing
End Sub

Any help would be great.

 

[dhosi439]

Or if it is possible to add text to the subject of a currently selected message in the inbox. That will work too.

 

[dhosi439]

This works both ways if anyone is interested in doing this.

Option Explicit

Public Sub Application_InitialTest()

On Error Resume Next

    Dim objApp As Outlook.Application
    Dim GetCurrentItem As Object
    Dim msg As Outlook.MailItem
    Dim subjectname As String
        
    Set objApp = CreateObject("Outlook.Application")
    On Error Resume Next
    Select Case TypeName(objApp.ActiveWindow)
        Case "Explorer"
            Set GetCurrentItem = objApp.ActiveExplorer.Selection.Item(1)
            subjectname = GetCurrentItem.Subject & " test"
                If Not GetCurrentItem Is Nothing Then
                    GetCurrentItem.Subject = subjectname
                    GetCurrentItem.Close (olSave)
                End If
            
        Case "Inspector"
            Set GetCurrentItem = objApp.ActiveInspector.CurrentItem
            subjectname = GetCurrentItem.Subject & " test"
                If Not GetCurrentItem Is Nothing Then
                    GetCurrentItem.Subject = subjectname
                    GetCurrentItem.Close (olSave)
                End If
            
        Case Else
            ' anything else will result in an error, which is
            ' why we have the error handler above
    End Select
    
    
    
    Set objApp = Nothing
    Set msg = Nothing
    Set GetCurrentItem = Nothing
    
End Sub

 

[jimrward]

here is some code I wrote for some users to take a selection of messages and get the actual received date and time and tag it on the subject, read rest of comment in code for explanation, there is also the converse to remove the date info

'>>from here
' Author Jim Ward
' Creation 31st March 2004
'
' Description
'
' The following 2 routines allow the user to select a number of emails
' For each member of the selection prefix the subject with the received date and time
' in the format yyyymmdd_hhmm_<subject content>
'
' This allows for the messages to be filed outwith OUTLOOK as message files, when OUTLOOK
' saves these it uses the <SUBJECT> field for the filename. In introducing the date, we can
' now use the directory sort to get the messages in chronological order, without this the
' messages will be in the order of when they were saved to the drive, NOT the received date.
'
'
' The second routine takes a date stamped SUBJECT email and removes the date stamp.
'
' Modification History
' ====================
' Jim Ward
' 27th May 2004
' Added in logic to stop untagged subjects being unintentionally stripped of characters(1-14)
' checking that characters (1-8) are numeric and positions 9 and 14 are underscore
'
'
'
Sub PrefixSubjectWithDate()
'
' Declare variables
'
Dim myOlSel As Outlook.Selection
Dim olExp, olCurrentFolder
Dim x As Integer
'
' setup what we require
'
Set olExp = Outlook.ActiveExplorer
Set olCurrentFolder = olExp.CurrentFolder
Set myOlSel = olExp.Selection
'
' Process each message selected
' Modify the subject In the message, And save the changes
'
For x = 1 To myOlSel.count
thissubject = myOlSel.Item(x).Subject
thisdate = myOlSel.Item(x).ReceivedTime
newdate = Format(thisdate, "yyyymmdd_hhmm_")
myOlSel.Item(x).Subject = newdate & thissubject
myOlSel.Item(x).Save
Next x

End Sub
Sub UndoPrefixSubjectWithDate()
Dim myOlSel As Outlook.Selection
Dim olExp, olCurrentFolder
Dim x As Integer

Set olExp = Outlook.ActiveExplorer
Set olCurrentFolder = olExp.CurrentFolder
Set myOlSel = olExp.Selection
'
' modify the subject In the message, And save the changes
'
' Check that we have some resemblance to our date stamp string to stop users
' unwittingly removing untagged messages.
'
' We should have an underscore in positions 9 and 14 and
' numeric data in 1-8 and 10-13
'
For x = 1 To myOlSel.count
thissubject = myOlSel.Item(x).Subject

dash1 = InStr(1, thissubject, "_")
dash2 = 0
If dash1 = 9 Then
dash2 = InStr(dash1 + 1, thissubject, "_")
mytest = Mid(thissubject, dash1 + 1, 4)
If dash2 = 14 And IsNumeric(Left(thissubject, 8)) = True And IsNumeric(Mid(thissubject, dash + 1, 4)) = True Then
newSubject = Right(thissubject, Len(thissubject) - 14)
myOlSel.Item(x).Subject = newSubject
myOlSel.Item(x).Save
End If
End If
Next x

End Sub
'>>to here