Hello Michael

I have a questions, can we loop the code to read into each subfolder and
save to separate individual directory?

if possible, any idea how can we code it, any example?

Appreciate the assistance very much.

"norhaya" wrote:

Hi

I've problems with saving any attached in text format, or attachement name
is long, also when subject is long too.

pls advise

1) if outlook having problem in saving .txt file which is an attachement?
2) how can i shorten the attachement name or subject name automatically. can
you show me the sample code.

appreciate the help very much.

below is my code

Dim NS As NameSpace
Dim Inbox As MAPIFolder
Dim SubFolder As MAPIFolder
Dim SubFolder1 As MAPIFolder
Dim Item As Object
Dim Atmt As Attachment
Dim FileName As String
Dim strSubject As Variant
Dim strsender As Variant
Dim strDateTime As String
Dim strRead As String
Dim strSignature As String
Dim str1 As String
Dim i As Integer
Dim e As Integer
Dim varResponse As VbMsgBoxResult

Set NS = GetNamespace("MAPI")
Set Inbox = NS.GetDefaultFolder(olFolderInbox)
Set SubFolder = Inbox.Folders("AutoSave")
Set SubFolder1 = Inbox.Folders("AutoSaved")
e = 0
i = 0
str1 = ""

If SubFolder.Items.Count = 0 Then
MsgBox "There are no messages in the folder.", vbInformation, _
"Nothing Found"
Exit Sub
End If

For Each Item In SubFolder.Items
Item.Subject = Replace(Trim(Item.Subject), ":", " ")
Item.Subject = Replace(Trim(Item.Subject), "/", " ")
Item.Subject = Replace(Trim(Item.Subject), "\", " ")
Item.Subject = Replace(Trim(Item.Subject), "-", " ")
Item.Subject = Replace(Trim(Item.Subject), ",", " ")
Item.Subject = Replace(Trim(Item.Subject), "", " ")
Item.Subject = Replace(Trim(Item.Subject), "", " ")
Item.Subject = Replace(Trim(Item.Subject), ".", " ")
Item.Subject = Replace(Trim(Item.Subject), "&", " ")
Item.Subject = Replace(Trim(Item.Subject), "!", " ")
Item.Subject = Replace(Trim(Item.Subject), "!!", " ")
Item.Subject = Replace(Trim(Item.Subject), "é", "e")
Item.Subject = Replace(Trim(Item.Subject), "(", " ")
Item.Subject = Replace(Trim(Item.Subject), ")", " ")
Item.Subject = Replace(Trim(Item.Subject), "?", " ")
Item.Subject = Replace(Trim(Item.Subject), "*", " ")
Item.Subject = Replace(Trim(Item.Subject), "°", " ")
Item.Subject = Replace(Trim(Item.Subject), "[", " ")
Item.Subject = Replace(Trim(Item.Subject), "]", " ")
Item.Subject = Replace(Trim(Item.Subject), ";", " ")
Item.Subject = Replace(Trim(Item.Subject), "#", " ")
Item.Subject = Replace(Trim(Item.Subject), "+", " ")
Item.Subject = Replace(Trim(Item.Subject), "@", " ")
Item.Subject = Replace(Trim(Item.Subject), ";", " ")
Item.Subject = Replace(Trim(Item.Subject), "=", " ")
Item.Subject = Replace(Trim(Item.Subject), "$", " dlr ")
Item.Subject = Replace(Trim(Item.Subject), "%", " percent ")
Item.Subject = Replace(Item.Subject, Chr(34), " ")

strSubject = Item.Subject
strsender = Item.SenderName
strDateTime = Now()
strRead = " - *(Read by NS on - "
strSignature = "(this email saved by Norhaya on - "

Item.Subject = Item.Subject & strRead & strDateTime & ")"
Item.Body = vbCrLf & Item.Body & strSignature & strDateTime & ")"
Item.SaveAs "C:\Autosave\" & _
Format(Item.CreationTime, "yyyymmdd_hhnnss_") & strSubject & "_"
& strsender & ".txt", olTXT
Item.SaveAs "C:\Documents and
Settings\ops7\Desktop\Norhaya\E-Filing\SCANNED DOC\Emails And Attachement -
Saved\" & _
Format(Item.CreationTime, "yyyymmdd_hhnnss_") & strSubject & "_"
& strsender & ".txt", olTXT

e = e + 1

For Each Atmt In Item.Attachments
FileName = "C:\Autosave\" & _
Format(Item.CreationTime, "yyyymmdd_hhnnss_") &
strSubject & "_" & strsender & "_" & Atmt.FileName
Atmt.SaveAsFile FileName
FileName = "C:\Documents and
Settings\ops7\Desktop\Norhaya\E-Filing\SCANNED DOC\Emails And Attachement -
Saved\" & _
Format(Item.CreationTime, "yyyymmdd_hhnnss_") &
strSubject & "_" & strsender & "_" & Atmt.FileName
Atmt.SaveAsFile FileName

i = i + 1
Next Atmt
Item.Move SubFolder1
Next Item

If e 0 Or i 0 Then
varResponse = MsgBox("I found " & e & " messages + " & i & "
attachments in autosave folder." _
& vbCrLf & "I have saved them into the C:\Autosave\ folder." _
& vbCrLf & vbCrLf & "Would you like to view the files now?" _
, vbQuestion + vbYesNo, "Finished!")

If varResponse = vbYes Then
Shell "Explorer.exe /e,C:\Autosave\ ", vbNormalFocus
End If
Else
MsgBox "I didn't find any messages in your autosave folder.",
vbInformation, "Finished!"
End If


Mod9SaveEml_AtmtToFolder_exit:
Set Atmt = Nothing
Set Item = Nothing
Set NS = Nothing
Exit Sub

Mod9SaveEml_AtmtToFolder_err:
MsgBox "An unexpected error has occurred." _
& vbCrLf & "Please note and report the following information." _
& vbCrLf & "Macro Name: GetAttachments" _
& vbCrLf & "Error Number: " & Err.Number _
& vbCrLf & "Error Description: " & Err.Description _
, vbCritical, "Error!"
Resume Mod9SaveEml_AtmtToFolder_exit