P
PJFry
The code below archives my messages into a local folder. What I want to do
is to have each message stamped with an 'Archived' noted so I know it has
already been done and have the code skip that message.
The problem I am having is that the 'Archived to" string is only inserted
into the message body that I have selected when I exectute the code. If I
have no messages select, none of them are altered.
The messages save ok, but what am I missing that keeps the itm.Body from
being updated?
Sub SaveMessages()
Dim OL As Application
Dim NmeSpace As NameSpace
Dim SubTxt As String
Set OL = CreateObject("Outlook.Application")
Set NmeSpace = OL.GetNamespace("MAPI")
Set Inbx = NmeSpace.GetDefaultFolder(olFolderInbox)
Set fldr = Application.ActiveExplorer.CurrentFolder
DirName = "C:\Documents and Settings\PJFry\Email\"
For Each itm In fldr.Items
SubTxt = itm.Subject
SubTxt = Replace(SubTxt, "_", "")
SubTxt = Replace(SubTxt, "´", "'")
SubTxt = Replace(SubTxt, "`", "'")
SubTxt = Replace(SubTxt, "{", "(")
SubTxt = Replace(SubTxt, "[", "(")
SubTxt = Replace(SubTxt, "]", ")")
SubTxt = Replace(SubTxt, "}", ")")
SubTxt = Replace(SubTxt, "/", "-")
SubTxt = Replace(SubTxt, "\", "-")
SubTxt = Replace(SubTxt, ":", "")
SubTxt = Replace(SubTxt, ",", "")
'Cut out invalid signs.
SubTxt = Replace(SubTxt, "*", "'")
SubTxt = Replace(SubTxt, "?", "")
SubTxt = Replace(SubTxt, """", "'")
SubTxt = Replace(SubTxt, "<", "")
SubTxt = Replace(SubTxt, ">", "")
SubTxt = Replace(SubTxt, "|", "")
FNme = DirName & Trim(SubTxt) & " " & Format(itm.ReceivedTime,
"yy.mm.dd") & " " & itm.SenderName & ".msg"
If itm.Class = olMail Then
If InStr(1, itm.Body, "Archived to") > 0 Then
'do nothing
Else
itm.Body = itm.Body & vbCrLf & _
"Archived to " & DirName & " on " & Now()
itm.SaveAs FNme, olMSG
End If
End If
Next itm
End Sub
If there is a better way to accomplish the same thing, I would also love to
hear it.
Thanks!
PJ
is to have each message stamped with an 'Archived' noted so I know it has
already been done and have the code skip that message.
The problem I am having is that the 'Archived to" string is only inserted
into the message body that I have selected when I exectute the code. If I
have no messages select, none of them are altered.
The messages save ok, but what am I missing that keeps the itm.Body from
being updated?
Sub SaveMessages()
Dim OL As Application
Dim NmeSpace As NameSpace
Dim SubTxt As String
Set OL = CreateObject("Outlook.Application")
Set NmeSpace = OL.GetNamespace("MAPI")
Set Inbx = NmeSpace.GetDefaultFolder(olFolderInbox)
Set fldr = Application.ActiveExplorer.CurrentFolder
DirName = "C:\Documents and Settings\PJFry\Email\"
For Each itm In fldr.Items
SubTxt = itm.Subject
SubTxt = Replace(SubTxt, "_", "")
SubTxt = Replace(SubTxt, "´", "'")
SubTxt = Replace(SubTxt, "`", "'")
SubTxt = Replace(SubTxt, "{", "(")
SubTxt = Replace(SubTxt, "[", "(")
SubTxt = Replace(SubTxt, "]", ")")
SubTxt = Replace(SubTxt, "}", ")")
SubTxt = Replace(SubTxt, "/", "-")
SubTxt = Replace(SubTxt, "\", "-")
SubTxt = Replace(SubTxt, ":", "")
SubTxt = Replace(SubTxt, ",", "")
'Cut out invalid signs.
SubTxt = Replace(SubTxt, "*", "'")
SubTxt = Replace(SubTxt, "?", "")
SubTxt = Replace(SubTxt, """", "'")
SubTxt = Replace(SubTxt, "<", "")
SubTxt = Replace(SubTxt, ">", "")
SubTxt = Replace(SubTxt, "|", "")
FNme = DirName & Trim(SubTxt) & " " & Format(itm.ReceivedTime,
"yy.mm.dd") & " " & itm.SenderName & ".msg"
If itm.Class = olMail Then
If InStr(1, itm.Body, "Archived to") > 0 Then
'do nothing
Else
itm.Body = itm.Body & vbCrLf & _
"Archived to " & DirName & " on " & Now()
itm.SaveAs FNme, olMSG
End If
End If
Next itm
End Sub
If there is a better way to accomplish the same thing, I would also love to
hear it.
Thanks!
PJ