D
DStrong
Using outlook 2003 I am trying to get outlook to close the currently opened
email after it saves it. I have got everything working but the closeing part.
Can someone give me some ideas, suggestions or the write code to get this to
work. Here is what I have at this point:
Sub SaveAsOF()
'## Saves current email to users My Documents and Emails folder
Dim myItem As Outlook.Inspector
Dim objItem As Object
Set myItem = Application.ActiveInspector
If Not TypeName(myItem) = "Nothing" Then
Set objItem = myItem.CurrentItem
strname = objItem.Subject
strInvalidSequences = "`+
+~+!+@+$+%+^+&+*+=+{+}+[+]+|+\+""+:+;+<+>+/"
strArrInvalidSequence = Split(strInvalidSequences, "+")
For x = 0 To UBound(strArrInvalidSequence)
Text = strArrInvalidSequence(x)
strname = Replace(strname, Text, "_")
Next x
strpath = Environ("HOMEdrive") & "My Documents\Emails\" & strname &
".msg"
'Prompt the user for confirmation
Dim strPrompt As String
strPrompt = "The email has been saved as " & strpath
CheckFolder
objItem.SaveAs Environ("HOMEdrive") & "\My Documents\Emails\" &
strname & ".msg", olMSG
MsgBox (strPrompt)
Else
MsgBox "You must open the email to save it, please double click the
email and try again."
End If
End Sub
Sub CheckFolder()
Dim fso
Dim fol As String
fol = Environ("HOMEdrive") & "My Documents\Emails"
Set fso = CreateObject("Scripting.FileSystemObject")
If Not fso.FolderExists(fol) Then
fso.CreateFolder (fol)
End If
End Sub
Since some people do not have the "Emails" folder the second macro included
here adds it. Thanks in advance for any help on this.
email after it saves it. I have got everything working but the closeing part.
Can someone give me some ideas, suggestions or the write code to get this to
work. Here is what I have at this point:
Sub SaveAsOF()
'## Saves current email to users My Documents and Emails folder
Dim myItem As Outlook.Inspector
Dim objItem As Object
Set myItem = Application.ActiveInspector
If Not TypeName(myItem) = "Nothing" Then
Set objItem = myItem.CurrentItem
strname = objItem.Subject
strInvalidSequences = "`+
+~+!+@+$+%+^+&+*+=+{+}+[+]+|+\+""+:+;+<+>+/"
strArrInvalidSequence = Split(strInvalidSequences, "+")
For x = 0 To UBound(strArrInvalidSequence)
Text = strArrInvalidSequence(x)
strname = Replace(strname, Text, "_")
Next x
strpath = Environ("HOMEdrive") & "My Documents\Emails\" & strname &
".msg"
'Prompt the user for confirmation
Dim strPrompt As String
strPrompt = "The email has been saved as " & strpath
CheckFolder
objItem.SaveAs Environ("HOMEdrive") & "\My Documents\Emails\" &
strname & ".msg", olMSG
MsgBox (strPrompt)
Else
MsgBox "You must open the email to save it, please double click the
email and try again."
End If
End Sub
Sub CheckFolder()
Dim fso
Dim fol As String
fol = Environ("HOMEdrive") & "My Documents\Emails"
Set fso = CreateObject("Scripting.FileSystemObject")
If Not fso.FolderExists(fol) Then
fso.CreateFolder (fol)
End If
End Sub
Since some people do not have the "Emails" folder the second macro included
here adds it. Thanks in advance for any help on this.