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

Am Wed, 11 Jan 2006 01:33:16 -0800 schrieb norhaya:

Start with the Inbox´s parent and use For Each again:

Dim oRoot as Outlook.MapiFolder
Dim oFld as Outlook.MapiFolder

' You have the code for the Inbox already so let´s start after that
Set oRoot=Inbox.Parent
For Each oFld in oRoot.Folders
...
Next

--
Viele Gruesse / Best regards
Michael Bauer - MVP Outlook



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

Hi Michael

Thank you for your prompt response. I've tried but I got

Error # 91 - Object variable or with block variable not set. Below is my
complete code. Can you check where did I go wrong. Also, can u guide/advise
if my inbox has a subfolder called customer. in customer subfolder has a
subfolder called Singapore airlines, malaysia airlines, garuda airlines. I
have create a rules for all incoming email for each customer to be moved to
respective folders. my intention is to save all the mails in each directory
e.g. singapore airlines will go to c:\singaporeairairlines\, Malaysia
airlines will go to c:\malaysia airlines....so on.

please help me to fix this and appreciate it very much. if this works, then
i can use this as template in my future projects.

Hear from you soonest.

Norhaya

Sub Mod9Rev3SaveEml_AtmtToFolder()

On Error GoTo Mod9Rev3SaveEml_AtmtToFolder_err

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 String
Dim strsender As String
Dim strDateTime As String
Dim strRead As String
Dim strSignature As String
Dim str1 As String
Dim i As Long
Dim b As Long
Dim e As Integer
Dim varResponse As VbMsgBoxResult
Dim oRoot As Outlook.MAPIFolder
Dim oFld As Outlook.MAPIFolder

Set NS = GetNamespace("MAPI")
Set Inbox = NS.GetDefaultFolder(olFolderInbox)
'Set SubFolder = Inbox.Folders("AutoSave")
'Set SubFolder1 = Inbox.Folders("AutoSaved")
Set oRoot = Inbox.Parent



e = 0
b = 0
str1 = ""

For Each oFld In oRoot.Folders

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

For i = SubFolder.Items.Count To 1 Step -1
Set Item = SubFolder.Items(i)

strSubject = Item.Subject
strSubject = ReplaceStr(strSubject)

strsender = Item.SenderName
strsender = ReplaceStr(strsender)

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, "yymmdd_hhnnss_") & Left([strSubject],
100) & "_" & strsender & ".txt", olTXT
Item.SaveAs "C:\2006\" & _
Format(Item.CreationTime, "yymmdd_hhnnss_") & Left([strSubject],
100) & "_" & strsender & ".txt", olTXT

e = e + 1

For Each Atmt In Item.Attachments
FileName = "C:\Autosave\" & _
Format(Item.CreationTime, "yymmdd_hhnnss_") &
Left([strSubject], 100) & "_" & strsender & "_" & Atmt.FileName
Atmt.SaveAsFile FileName
FileName = "C:\2006\" & _
Format(Item.CreationTime, "yymmdd_hhnnss_") &
Left([strSubject], 50) & "_" & strsender & "_" & Atmt.FileName
Atmt.SaveAsFile FileName

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

Next

If e 0 Or b 0 Then
varResponse = MsgBox("I found " & e & " messages + " & b & "
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

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

Mod9Rev3SaveEml_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 Mod9Rev3SaveEml_AtmtToFolder_exit
End Sub

Private Function ReplaceStr(str As String) As String

str = Replace(str, Chr(34), " ")
str = Replace(str, "/", " ")
str = Replace(str, "\", " ")
str = Replace(str, "", " ")
str = Replace(str, "", " ")
str = Replace(str, "&", " ")
str = Replace(str, "[", " ")
str = Replace(str, "]", " ")
str = Replace(str, "!", "")
str = Replace(str, "é", "e")
str = Replace(str, "(", " ")
str = Replace(str, ")", " ")
str = Replace(str, ":", " ")
str = Replace(str, "-", " ")
str = Replace(str, ",", " ")
str = Replace(str, ".", " ")
str = Replace(str, "?", " ")
str = Replace(str, "*", " ")
str = Replace(str, "°", " ")
str = Replace(str, ";", " ")
str = Replace(str, "#", " ")
str = Replace(str, "+", " ")
str = Replace(str, "@", " ")
str = Replace(str, ";", " ")
str = Replace(str, "=", " ")
str = Replace(str, "$", " dlr ")
str = Replace(str, "%", " percent ")
ReplaceStr = str
End Function


"Michael Bauer" wrote:

Am Wed, 11 Jan 2006 01:33:16 -0800 schrieb norhaya:

Start with the Inbox´s parent and use For Each again:

Dim oRoot as Outlook.MapiFolder
Dim oFld as Outlook.MapiFolder

' You have the code for the Inbox already so let´s start after that
Set oRoot=Inbox.Parent
For Each oFld in oRoot.Folders
...
Next

--
Viele Gruesse / Best regards
Michael Bauer - MVP Outlook



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

Am Wed, 11 Jan 2006 23:07:01 -0800 schrieb norhaya:

Please note, it´s not my intention to write any code for you. Instead I
really like to give you samples so that you can learn what´s going on.

The modification now uses oFld as the loop´s control variable. Do you
remember? Please watch your code where the error occurs. SubFolder isn´t
set. I´m sure you´ll get it yourself.

Very helpful is the Object Browser (F2), which shows you all object´s
properties. Each folder has e.g. a Name property, and each folder has a
Folders collection for all its subfolders. So you can easily check a
folder´s name and loop through its subfolders.

If you want to check if a particular folder name exists then use a separate
function, so it´s easy to ignore errors:

Private Funtion GetSubFolder(Parent as Outlook.MapiFolder, _
sName as string _
) as Outlook.Mapifolder
On Error Resume Next
Set GetSubfolder=Parent.Folders(sName)
End Function

The function returns Nothing if the folder doesn´t exist - without any
errors.

--
Viele Gruesse / Best regards
Michael Bauer - MVP Outlook



Hi Michael

Thank you for your prompt response. I've tried but I got

Error # 91 - Object variable or with block variable not set. Below is my
complete code. Can you check where did I go wrong. Also, can u
guide/advise
if my inbox has a subfolder called customer. in customer subfolder has a
subfolder called Singapore airlines, malaysia airlines, garuda airlines. I
have create a rules for all incoming email for each customer to be moved
to
respective folders. my intention is to save all the mails in each
directory
e.g. singapore airlines will go to c:\singaporeairairlines\, Malaysia
airlines will go to c:\malaysia airlines....so on.

please help me to fix this and appreciate it very much. if this works,
then
i can use this as template in my future projects.

Hear from you soonest.

Norhaya

Sub Mod9Rev3SaveEml_AtmtToFolder()

On Error GoTo Mod9Rev3SaveEml_AtmtToFolder_err

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 String
Dim strsender As String
Dim strDateTime As String
Dim strRead As String
Dim strSignature As String
Dim str1 As String
Dim i As Long
Dim b As Long
Dim e As Integer
Dim varResponse As VbMsgBoxResult
Dim oRoot As Outlook.MAPIFolder
Dim oFld As Outlook.MAPIFolder

Set NS = GetNamespace("MAPI")
Set Inbox = NS.GetDefaultFolder(olFolderInbox)
'Set SubFolder = Inbox.Folders("AutoSave")
'Set SubFolder1 = Inbox.Folders("AutoSaved")
Set oRoot = Inbox.Parent



e = 0
b = 0
str1 = ""

For Each oFld In oRoot.Folders

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

For i = SubFolder.Items.Count To 1 Step -1
Set Item = SubFolder.Items(i)

strSubject = Item.Subject
strSubject = ReplaceStr(strSubject)

strsender = Item.SenderName
strsender = ReplaceStr(strsender)

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, "yymmdd_hhnnss_") &
Left([strSubject],
100) & "_" & strsender & ".txt", olTXT
Item.SaveAs "C:\2006\" & _
Format(Item.CreationTime, "yymmdd_hhnnss_") &
Left([strSubject],
100) & "_" & strsender & ".txt", olTXT

e = e + 1

For Each Atmt In Item.Attachments
FileName = "C:\Autosave\" & _
Format(Item.CreationTime, "yymmdd_hhnnss_") &
Left([strSubject], 100) & "_" & strsender & "_" & Atmt.FileName
Atmt.SaveAsFile FileName
FileName = "C:\2006\" & _
Format(Item.CreationTime, "yymmdd_hhnnss_") &
Left([strSubject], 50) & "_" & strsender & "_" & Atmt.FileName
Atmt.SaveAsFile FileName

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

Next

If e 0 Or b 0 Then
varResponse = MsgBox("I found " & e & " messages + " & b & "
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

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

Mod9Rev3SaveEml_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 Mod9Rev3SaveEml_AtmtToFolder_exit
End Sub

Private Function ReplaceStr(str As String) As String

str = Replace(str, Chr(34), " ")
str = Replace(str, "/", " ")
str = Replace(str, "\", " ")
str = Replace(str, "", " ")
str = Replace(str, "", " ")
str = Replace(str, "&", " ")
str = Replace(str, "[", " ")
str = Replace(str, "]", " ")
str = Replace(str, "!", "")
str = Replace(str, "é", "e")
str = Replace(str, "(", " ")
str = Replace(str, ")", " ")
str = Replace(str, ":", " ")
str = Replace(str, "-", " ")
str = Replace(str, ",", " ")
str = Replace(str, ".", " ")
str = Replace(str, "?", " ")
str = Replace(str, "*", " ")
str = Replace(str, "°", " ")
str = Replace(str, ";", " ")
str = Replace(str, "#", " ")
str = Replace(str, "+", " ")
str = Replace(str, "@", " ")
str = Replace(str, ";", " ")
str = Replace(str, "=", " ")
str = Replace(str, "$", " dlr ")
str = Replace(str, "%", " percent ")
ReplaceStr = str
End Function


"Michael Bauer" wrote:

Am Wed, 11 Jan 2006 01:33:16 -0800 schrieb norhaya:

Start with the Inbox´s parent and use For Each again:

Dim oRoot as Outlook.MapiFolder
Dim oFld as Outlook.MapiFolder

' You have the code for the Inbox already so let´s start after that
Set oRoot=Inbox.Parent
For Each oFld in oRoot.Folders
...
Next

--
Viele Gruesse / Best regards
Michael Bauer - MVP Outlook



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

Hi Michael

of course not, not my intention either. I want to learn but i need your
guide only. Ok i will check the info you provide and work on it. cos it's
getting interesting and i do appreciate your help.

Norhaya

"Michael Bauer" wrote:

Am Wed, 11 Jan 2006 23:07:01 -0800 schrieb norhaya:

Please note, it´s not my intention to write any code for you. Instead I
really like to give you samples so that you can learn what´s going on.

The modification now uses oFld as the loop´s control variable. Do you
remember? Please watch your code where the error occurs. SubFolder isn´t
set. I´m sure you´ll get it yourself.

Very helpful is the Object Browser (F2), which shows you all object´s
properties. Each folder has e.g. a Name property, and each folder has a
Folders collection for all its subfolders. So you can easily check a
folder´s name and loop through its subfolders.

If you want to check if a particular folder name exists then use a separate
function, so it´s easy to ignore errors:

Private Funtion GetSubFolder(Parent as Outlook.MapiFolder, _
sName as string _
) as Outlook.Mapifolder
On Error Resume Next
Set GetSubfolder=Parent.Folders(sName)
End Function

The function returns Nothing if the folder doesn´t exist - without any
errors.

--
Viele Gruesse / Best regards
Michael Bauer - MVP Outlook



Hi Michael

Thank you for your prompt response. I've tried but I got

Error # 91 - Object variable or with block variable not set. Below is my
complete code. Can you check where did I go wrong. Also, can u
guide/advise
if my inbox has a subfolder called customer. in customer subfolder has a
subfolder called Singapore airlines, malaysia airlines, garuda airlines. I
have create a rules for all incoming email for each customer to be moved
to
respective folders. my intention is to save all the mails in each
directory
e.g. singapore airlines will go to c:\singaporeairairlines\, Malaysia
airlines will go to c:\malaysia airlines....so on.

please help me to fix this and appreciate it very much. if this works,
then
i can use this as template in my future projects.

Hear from you soonest.

Norhaya

Sub Mod9Rev3SaveEml_AtmtToFolder()

On Error GoTo Mod9Rev3SaveEml_AtmtToFolder_err

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 String
Dim strsender As String
Dim strDateTime As String
Dim strRead As String
Dim strSignature As String
Dim str1 As String
Dim i As Long
Dim b As Long
Dim e As Integer
Dim varResponse As VbMsgBoxResult
Dim oRoot As Outlook.MAPIFolder
Dim oFld As Outlook.MAPIFolder

Set NS = GetNamespace("MAPI")
Set Inbox = NS.GetDefaultFolder(olFolderInbox)
'Set SubFolder = Inbox.Folders("AutoSave")
'Set SubFolder1 = Inbox.Folders("AutoSaved")
Set oRoot = Inbox.Parent



e = 0
b = 0
str1 = ""

For Each oFld In oRoot.Folders

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

For i = SubFolder.Items.Count To 1 Step -1
Set Item = SubFolder.Items(i)

strSubject = Item.Subject
strSubject = ReplaceStr(strSubject)

strsender = Item.SenderName
strsender = ReplaceStr(strsender)

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, "yymmdd_hhnnss_") &
Left([strSubject],
100) & "_" & strsender & ".txt", olTXT
Item.SaveAs "C:\2006\" & _
Format(Item.CreationTime, "yymmdd_hhnnss_") &
Left([strSubject],
100) & "_" & strsender & ".txt", olTXT

e = e + 1

For Each Atmt In Item.Attachments
FileName = "C:\Autosave\" & _
Format(Item.CreationTime, "yymmdd_hhnnss_") &
Left([strSubject], 100) & "_" & strsender & "_" & Atmt.FileName
Atmt.SaveAsFile FileName
FileName = "C:\2006\" & _
Format(Item.CreationTime, "yymmdd_hhnnss_") &
Left([strSubject], 50) & "_" & strsender & "_" & Atmt.FileName
Atmt.SaveAsFile FileName

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

Next

If e 0 Or b 0 Then
varResponse = MsgBox("I found " & e & " messages + " & b & "
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

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

Mod9Rev3SaveEml_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 Mod9Rev3SaveEml_AtmtToFolder_exit
End Sub

Private Function ReplaceStr(str As String) As String

str = Replace(str, Chr(34), " ")
str = Replace(str, "/", " ")
str = Replace(str, "\", " ")
str = Replace(str, "", " ")
str = Replace(str, "", " ")
str = Replace(str, "&", " ")
str = Replace(str, "[", " ")
str = Replace(str, "]", " ")
str = Replace(str, "!", "")
str = Replace(str, "é", "e")
str = Replace(str, "(", " ")
str = Replace(str, ")", " ")
str = Replace(str, ":", " ")
str = Replace(str, "-", " ")
str = Replace(str, ",", " ")
str = Replace(str, ".", " ")
str = Replace(str, "?", " ")
str = Replace(str, "*", " ")
str = Replace(str, "°", " ")
str = Replace(str, ";", " ")
str = Replace(str, "#", " ")
str = Replace(str, "+", " ")
str = Replace(str, "@", " ")
str = Replace(str, ";", " ")
str = Replace(str, "=", " ")
str = Replace(str, "$", " dlr ")
str = Replace(str, "%", " percent ")
ReplaceStr = str
End Function


"Michael Bauer" wrote:

Am Wed, 11 Jan 2006 01:33:16 -0800 schrieb norhaya:

Start with the Inbox´s parent and use For Each again:

Dim oRoot as Outlook.MapiFolder
Dim oFld as Outlook.MapiFolder

' You have the code for the Inbox already so let´s start after that
Set oRoot=Inbox.Parent
For Each oFld in oRoot.Folders
...
Next

--
Viele Gruesse / Best regards
Michael Bauer - MVP Outlook



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), "&", " ")