Save Attachment and Save E-mail Content

[nicknicknick]

Hi All

PLEASE HELP

This is where i have got so far

I have spent quite a lot of time trying to do this and it is more involved than i first thought.

This is the code which works but has flaws in it.

It does all i want and i have stored it in ThisOutlookSession.
It has as mentioned flaws with reply,forward and also i have found out flaws when contacts are opened or any kind of outlook item when opened.

Can you offer perhaps a better way of doing this!

All i want to do is when a new e-mail is opened - save the content of the e-mail and if an attachment then save that as well to a paricular location based on the input given in the msg boxes - i.e the case number relates to a folder already on the c:/ drive - i.e. if the user inputs 1234 it will store the files in 1234 folder if it exist!!

can you try running this code and give me some help... I am lost now!!

Dim WithEvents colInspectors As Outlook.Inspectors

Private Sub Application_Startup()
Set colInspectors = Application.Inspectors
End Sub

Private Sub colInspectors_NewInspector(ByVal Inspector As Inspector)
' your code to work with Inspector goes here
' if you want to work with the actual item that's opened,
' use this:
'Dim objItem As Object
'Set objItem = Inspector.CurrentItem


Dim myolApp As Object
Dim myMessageItem As Object
Dim myAttachmentItems As Object
Dim myJobnumber As String
Dim MyDrive As String
Dim Title As String

Set myolApp = CreateObject("Outlook.Application")
Set myMessageItem = Inspector.CurrentItem
Set myAttachmentItems = myMessageItem.Attachments
'Set objreply = myMessageItem.Reply


With myMessageItem
If .To = "" Then GoTo Getout

'If Not objreply = "" Then GoTo Getout
'basic info about message
Debug.Print .To
Debug.Print .CC
Debug.Print .Subject
Debug.Print .Body
If .UnRead Then
Debug.Print "Message has not been read"
Else
Debug.Print "Message has been read"
End If

myJobnumber = InputBox("Title prefix?", Title, "99999")

If myJobnumber = "" Then GoTo Getout
MyDrive = InputBox("What is the case number", Title, "Case Number")
MyDrive = "C:\" & MyDrive & "\1\"

If MyDrive = "" Then

Dim AbortRetryIgnore

AbortRetryIgnore = MsgBox("Not a valid case number - Retry or Cancel?", vbRetryCancel + vbCritical)

Select Case AbortRetryIgnore

Case vbRetry
MyDrive = InputBox("What is the case number", Title, "Case Number")

Case vbCancel
GoTo Getout

End Select


End If

If Dir(MyDrive, vbDirectory) = "" Then
MsgBox "No such Customer!"
GoTo Getout

End If

.SaveAs MyDrive & myJobnumber & "-" & myMessageItem & ".txt", olTXT

End With

DoEvents

'start of attachment process

For Each myMessageItem In myAttachmentItems



myJobnumber = InputBox("Title prefix?", Title, "99999")

If myJobnumber = "" Then GoTo Getout
MyDrive = InputBox("What is the case number", Title, "Case Number")
MyDrive = "C:\" & MyDrive & "\1\"

If MyDrive = "" Then

'Dim AbortRetryIgnore

AbortRetryIgnore = MsgBox("Not a valid case number - Retry or Cancel?", vbRetryCancel + vbCritical)

Select Case AbortRetryIgnore

Case vbRetry
MyDrive = InputBox("What is the case number", Title, "Case Number")

Case vbCancel
GoTo Getout

End Select

'If Dir(MyDrive, vbDirectory) = "" Then
'MkDir MyDrive
End If

'myMessageItem.SaveAsFile MyDrive & myJobnumber & "-" & myMessageItem.DisplayName

If Dir(MyDrive, vbDirectory) = "" Then
MsgBox "No such Customer!"
GoTo Getout

End If

myMessageItem.SaveAsFile MyDrive & myJobnumber & "-" & myMessageItem.DisplayName

Next
Getout:
Set myolApp = Nothing
Set myMessageItem = Nothing
Set myAttachmentItems = Nothing
End Sub


Post Feedback