Problem with saving .txt attachement

G

Guest

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
 
M

Michael Bauer

Am Thu, 5 Jan 2006 19:47:02 -0800 schrieb norhaya:

You can cut a string e.g. with the Left function: Left(txt, 8) returns the
first 8 characters of txt.

With the many Replace function calls you replace some characters, which
aren´t allowed for file names (and some other characters, too) by blank
spaces. Then for the file name you use also the SenderName, which also can
contain not allowed chars ("<" e.g.). That is, you need to qualify that
string, too.

You will need to change the For Each Item loop. Because you´re moving the
item at the end out of the list you can use e.g. a backwards loop:

For i=Items.Count to 1 step -1
....
next

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


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
Click to expand...
 
G

Guest

Mr Bauer

Thank you for your prompt response, I will work on the cutting the string
for the attachement n let u know i made it.

u mentioned that i could replace the sendername too, can you show sample
code. I've been trying to work on so many time, i was told by sue mosher that
sendername is read-only so i cannot change it. but if u can assist that will
be fantastic.

sorry, i have to ask you where in my code that you suggested i replace with
this code
For i=Items.Count to 1 step -1
....
next
Click to expand...

thanks, norhaya
..

Michael Bauer said:
Am Thu, 5 Jan 2006 19:47:02 -0800 schrieb norhaya:

You can cut a string e.g. with the Left function: Left(txt, 8) returns the
first 8 characters of txt.

With the many Replace function calls you replace some characters, which
aren´t allowed for file names (and some other characters, too) by blank
spaces. Then for the file name you use also the SenderName, which also can
contain not allowed chars ("<" e.g.). That is, you need to qualify that
string, too.

You will need to change the For Each Item loop. Because you´re moving the
item at the end out of the list you can use e.g. a backwards loop:

For i=Items.Count to 1 step -1
....
next

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


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
Click to expand...
Click to expand...
 
M

Michael Bauer

Am Fri, 6 Jan 2006 01:16:04 -0800 schrieb norhaya:

1)

You do have a sample for replacing the sendername already.

A simple change would do it:

strSubject = Item.Subject
strSubject = Replace(strSubject, Chr(34), " ")

With that could you don´t change the Item itself, but read the subject into
a variable and then change the variable. The same works for the sender.

A good approach would be not to copy all the code, but use another function
that could handle both the subject and the sender:

Private Function ReplaceStr(str as string) as string
str = Replace(str, Chr(34), " ")
' insert here all the other replace statements, too, and use
' the new variable 'str'
ReplaceStr = str
End function

Sample for calling the function for the subject:

strSubject = Item.Subject
strSubject = ReplaceStr(strSubject)

2)

In your code you have the line "For Each Item...". You need to replace that
with:

For i=Items.Count to 1 step -1
Set Item = Subfolder.Item(i)

That´s all.

Maybe another point: In your code you have declared the variable 'i' as
Integer. For attachments that´s surely ok. But now you´re using the same
variable for the folder´s Items. A folder can contain more then 32767 items
(upper bound for an integer), so you should declare it as Long instead.

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


Mr Bauer

Thank you for your prompt response, I will work on the cutting the string
for the attachement n let u know i made it.

u mentioned that i could replace the sendername too, can you show sample
code. I've been trying to work on so many time, i was told by sue mosher that
sendername is read-only so i cannot change it. but if u can assist that will
be fantastic.

sorry, i have to ask you where in my code that you suggested i replace with
this code
For i=Items.Count to 1 step -1
....
next
Click to expand...

thanks, norhaya
.

Michael Bauer said:
Am Thu, 5 Jan 2006 19:47:02 -0800 schrieb norhaya:

You can cut a string e.g. with the Left function: Left(txt, 8) returns the
first 8 characters of txt.

With the many Replace function calls you replace some characters, which
aren´t allowed for file names (and some other characters, too) by blank
spaces. Then for the file name you use also the SenderName, which also can
contain not allowed chars ("<" e.g.). That is, you need to qualify that
string, too.

You will need to change the For Each Item loop. Because you´re moving the
item at the end out of the list you can use e.g. a backwards loop:

For i=Items.Count to 1 step -1
....
next

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


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
Click to expand...
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
Click to expand...
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
Click to expand...
Click to expand...
Click to expand...
 
G

Guest

Hello Michael

Thank you so much for your help. Just fantastic. But working on the
function, below is my revised code which I encounter problem. "Compile Error:
Invalid Next Control variable reference"

Sub Mod9Rev2SaveEml_AtmtToFolder()

On Error GoTo Mod9Rev2SaveEml_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 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 i = Item.Count To 1 Step -1
Set Item = SubFolder.Item(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], 100) & "_" & strsender & "_" & Atmt.FileName
Atmt.SaveAsFile FileName

i = i + 1
Next Atmt
Item.Move SubFolder1
Next Item 'Compile Error: Invalid Next Control variable reference


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


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

Mod9Rev2SaveEml_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 Mod9Rev2SaveEml_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 said:
Am Fri, 6 Jan 2006 01:16:04 -0800 schrieb norhaya:

1)

You do have a sample for replacing the sendername already.

A simple change would do it:

strSubject = Item.Subject
strSubject = Replace(strSubject, Chr(34), " ")

With that could you don´t change the Item itself, but read the subject into
a variable and then change the variable. The same works for the sender.

A good approach would be not to copy all the code, but use another function
that could handle both the subject and the sender:

Private Function ReplaceStr(str as string) as string
str = Replace(str, Chr(34), " ")
' insert here all the other replace statements, too, and use
' the new variable 'str'
ReplaceStr = str
End function

Sample for calling the function for the subject:

strSubject = Item.Subject
strSubject = ReplaceStr(strSubject)

2)

In your code you have the line "For Each Item...". You need to replace that
with:

For i=Items.Count to 1 step -1
Set Item = Subfolder.Item(i)

That´s all.

Maybe another point: In your code you have declared the variable 'i' as
Integer. For attachments that´s surely ok. But now you´re using the same
variable for the folder´s Items. A folder can contain more then 32767 items
(upper bound for an integer), so you should declare it as Long instead.

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


Mr Bauer

Thank you for your prompt response, I will work on the cutting the string
for the attachement n let u know i made it.

u mentioned that i could replace the sendername too, can you show sample
code. I've been trying to work on so many time, i was told by sue mosher that
sendername is read-only so i cannot change it. but if u can assist that will
be fantastic.

sorry, i have to ask you where in my code that you suggested i replace with
this code
For i=Items.Count to 1 step -1
....
next
Click to expand...

thanks, norhaya
.

Michael Bauer said:
Am Thu, 5 Jan 2006 19:47:02 -0800 schrieb norhaya:

You can cut a string e.g. with the Left function: Left(txt, 8) returns the
first 8 characters of txt.

With the many Replace function calls you replace some characters, which
aren´t allowed for file names (and some other characters, too) by blank
spaces. Then for the file name you use also the SenderName, which also can
contain not allowed chars ("<" e.g.). That is, you need to qualify that
string, too.

You will need to change the For Each Item loop. Because you´re moving the
item at the end out of the list you can use e.g. a backwards loop:

For i=Items.Count to 1 step -1
....
next

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



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
Click to expand...
Click to expand...
Click to expand...
 
M

Michael Bauer

Am Tue, 10 Jan 2006 20:18:02 -0800 schrieb norhaya:
For i = Item.Count To 1 Step -1
Click to expand...

In your code "Item" is a variable for one single item. The list which
contains all these items is (in your code) SubFolder.Items. So the For
statement has to be:

For i= SubFolder.Items.Count to 1 step -1

The control variable in that loop is i. So if you want to mention the
control variable together with the Next statement (you don´t need to) then
you must write

....
Next i

Also allowed is simple

....
Next

(without the control variable).

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


Hello Michael

Thank you so much for your help. Just fantastic. But working on the
function, below is my revised code which I encounter problem. "Compile Error:
Invalid Next Control variable reference"

Sub Mod9Rev2SaveEml_AtmtToFolder()

On Error GoTo Mod9Rev2SaveEml_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 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 i = Item.Count To 1 Step -1
Set Item = SubFolder.Item(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], 100) & "_" & strsender & "_" & Atmt.FileName
Atmt.SaveAsFile FileName

i = i + 1
Next Atmt
Item.Move SubFolder1
Next Item 'Compile Error: Invalid Next Control variable reference


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


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

Mod9Rev2SaveEml_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 Mod9Rev2SaveEml_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 said:
Am Fri, 6 Jan 2006 01:16:04 -0800 schrieb norhaya:

1)

You do have a sample for replacing the sendername already.
Item.Subject = Replace(Item.Subject, Chr(34), " ")

strSubject = Item.Subject
Click to expand...

A simple change would do it:

strSubject = Item.Subject
strSubject = Replace(strSubject, Chr(34), " ")

With that could you don´t change the Item itself, but read the subject into
a variable and then change the variable. The same works for the sender.

A good approach would be not to copy all the code, but use another function
that could handle both the subject and the sender:

Private Function ReplaceStr(str as string) as string
str = Replace(str, Chr(34), " ")
' insert here all the other replace statements, too, and use
' the new variable 'str'
ReplaceStr = str
End function

Sample for calling the function for the subject:

strSubject = Item.Subject
strSubject = ReplaceStr(strSubject)

2)

In your code you have the line "For Each Item...". You need to replace that
with:

For i=Items.Count to 1 step -1
Set Item = Subfolder.Item(i)

That´s all.

Maybe another point: In your code you have declared the variable 'i' as
Integer. For attachments that´s surely ok. But now you´re using the same
variable for the folder´s Items. A folder can contain more then 32767 items
(upper bound for an integer), so you should declare it as Long instead.

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


Mr Bauer

Thank you for your prompt response, I will work on the cutting the string
for the attachement n let u know i made it.

u mentioned that i could replace the sendername too, can you show sample
code. I've been trying to work on so many time, i was told by sue mosher that
sendername is read-only so i cannot change it. but if u can assist that will
be fantastic.

sorry, i have to ask you where in my code that you suggested i replace with
this code
For i=Items.Count to 1 step -1
....
next

thanks, norhaya
.

:

Am Thu, 5 Jan 2006 19:47:02 -0800 schrieb norhaya:

You can cut a string e.g. with the Left function: Left(txt, 8) returns the
first 8 characters of txt.

With the many Replace function calls you replace some characters, which
aren´t allowed for file names (and some other characters, too) by blank
spaces. Then for the file name you use also the SenderName, which also can
contain not allowed chars ("<" e.g.). That is, you need to qualify that
string, too.

You will need to change the For Each Item loop. Because you´re moving the
item at the end out of the list you can use e.g. a backwards loop:

For i=Items.Count to 1 step -1
....
next

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



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
Click to expand...
Click to expand...
Click to expand...
 
G

Guest

Hi Michael

Thank you once again. it helps alot n no more headaches

Michael Bauer said:
Am Tue, 10 Jan 2006 20:18:02 -0800 schrieb norhaya:
For i = Item.Count To 1 Step -1
Click to expand...

In your code "Item" is a variable for one single item. The list which
contains all these items is (in your code) SubFolder.Items. So the For
statement has to be:

For i= SubFolder.Items.Count to 1 step -1

The control variable in that loop is i. So if you want to mention the
control variable together with the Next statement (you don´t need to) then
you must write

....
Next i

Also allowed is simple

....
Next

(without the control variable).

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


Hello Michael

Thank you so much for your help. Just fantastic. But working on the
function, below is my revised code which I encounter problem. "Compile Error:
Invalid Next Control variable reference"

Sub Mod9Rev2SaveEml_AtmtToFolder()

On Error GoTo Mod9Rev2SaveEml_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 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 i = Item.Count To 1 Step -1
Set Item = SubFolder.Item(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], 100) & "_" & strsender & "_" & Atmt.FileName
Atmt.SaveAsFile FileName

i = i + 1
Next Atmt
Item.Move SubFolder1
Next Item 'Compile Error: Invalid Next Control variable reference


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


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

Mod9Rev2SaveEml_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 Mod9Rev2SaveEml_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 said:
Am Fri, 6 Jan 2006 01:16:04 -0800 schrieb norhaya:

1)

You do have a sample for replacing the sendername already.

Item.Subject = Replace(Item.Subject, Chr(34), " ")

strSubject = Item.Subject

A simple change would do it:

strSubject = Item.Subject
strSubject = Replace(strSubject, Chr(34), " ")

With that could you don´t change the Item itself, but read the subject into
a variable and then change the variable. The same works for the sender.

A good approach would be not to copy all the code, but use another function
that could handle both the subject and the sender:

Private Function ReplaceStr(str as string) as string
str = Replace(str, Chr(34), " ")
' insert here all the other replace statements, too, and use
' the new variable 'str'
ReplaceStr = str
End function

Sample for calling the function for the subject:

strSubject = Item.Subject
strSubject = ReplaceStr(strSubject)

2)

In your code you have the line "For Each Item...". You need to replace that
with:

For i=Items.Count to 1 step -1
Set Item = Subfolder.Item(i)

That´s all.

Maybe another point: In your code you have declared the variable 'i' as
Integer. For attachments that´s surely ok. But now you´re using the same
variable for the folder´s Items. A folder can contain more then 32767 items
(upper bound for an integer), so you should declare it as Long instead.

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



Mr Bauer

Thank you for your prompt response, I will work on the cutting the string
for the attachement n let u know i made it.

u mentioned that i could replace the sendername too, can you show sample
code. I've been trying to work on so many time, i was told by sue mosher
that
sendername is read-only so i cannot change it. but if u can assist that
will
be fantastic.

sorry, i have to ask you where in my code that you suggested i replace
with
this code
For i=Items.Count to 1 step -1
....
next

thanks, norhaya
.

:

Am Thu, 5 Jan 2006 19:47:02 -0800 schrieb norhaya:

You can cut a string e.g. with the Left function: Left(txt, 8) returns
the
first 8 characters of txt.

With the many Replace function calls you replace some characters, which
aren´t allowed for file names (and some other characters, too) by blank
spaces. Then for the file name you use also the SenderName, which also
can
contain not allowed chars ("<" e.g.). That is, you need to qualify that
string, too.

You will need to change the For Each Item loop. Because you´re moving the
item at the end out of the list you can use e.g. a backwards loop:

For i=Items.Count to 1 step -1
....
next

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



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
Click to expand...
Click to expand...
Click to expand...
 
G

Guest

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 said:
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
Click to expand...
 
M

Michael Bauer

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 said:
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
Click to expand...
Click to expand...
 
G

Guest

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 said:
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 said:
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
Click to expand...
Click to expand...
Click to expand...
 
M

Michael Bauer

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 said:
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.

:

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
Click to expand...
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
Click to expand...
&
"_"
& strsender & ".txt", olTXT
Item.SaveAs "C:\Documents and
Settings\ops7\Desktop\Norhaya\E-Filing\SCANNED DOC\Emails And
Click to expand...
Attachement
-
Saved\" & _
Format(Item.CreationTime, "yyyymmdd_hhnnss_") & strSubject
Click to expand...
&
"_"
& 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
Click to expand...
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
Click to expand...
Click to expand...
Click to expand...
 
G

Guest

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 said:
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 said:
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.

:

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), "&", " ")
Click to expand...
Click to expand...
Click to expand...
 

Ask a Question

Want to reply to this thread or ask your own question?

You'll need to choose a username for the site, which only take a couple of moments. After that, you can post your question and our members will help you out.

Ask a Question

Similar Threads

Outlook Cannot access more than the Outlook VBA 250 Mail Items 1
Better way of writing Macro? Identify multiple types of attachmen 5
How to get my macro as rule in Outlook? 0
Macro Runs Manually but not Automatically 0
Strange error numbers when running code 9
Saving outlook attachment to a different file 0
Moving emails to trash using VBA in Outlook 0
Saving attachment from shared mailbox 1

Top