Save email as text file macro

[Simon]

Hi, I have a seperate folders in outlook that receives 3 emails a day,
all with the same name but containing different data. I have a macro
that looks through the folder, copies the emails as a .txt file and
then places them in another folder. This all works, the only thing is,
it saves the email 3 times using the subject as a file name and so only
leaves me with one file on my (K) drive.
Is there a simple way to save the emails a different name each, though
they have to be consistent as I use a macro in excel daily to take data
out of them, so don't want them named by date of receipt or anything
like that. Here is the code.....thanks....

Public Sub LoopMailFolder()
On Error GoTo ERR_HANDLER
Dim o2Fld As Outlook.MAPIFolder
Dim O2ArcFld As Outlook.MAPIFolder
Dim Obj As Object
Dim Atmt As Attachment
Dim i As Integer
Dim Filename As String
Dim Item As Object


Set o2Fld = GetFolder("Mailbox - Stewart, Simon\Inbox\Ian")
Set O2ArcFld = GetFolder("Mailbox - Stewart,
Simon\Inbox\Ian\IanArchive")


For Each Obj In o2Fld.Items
For Each Atmt In Obj.Attachments
Filename = "K:\Fiapps\supportteam\Performance\" & Atmt.Filename

Next Atmt
Next Obj

For Each Obj In o2Fld.Items
If ExportMailToTxt(Obj) Then
End If

Obj.Move O2ArcFld
Next


For Each Obj In o2Fld.Items
If ExportMailToTxt(Obj) Then
End If

Obj.Move O2ArcFld
Next
For Each Obj In o2Fld.Items
If ExportMailToTxt(Obj) Then
End If

Obj.Move O2ArcFld
Next
For Each Obj In o2Fld.Items
If ExportMailToTxt(Obj) Then
End If

Obj.Move O2ArcFld
Next
For Each Obj In o2Fld.Items
If ExportMailToTxt(Obj) Then
End If

Obj.Move O2ArcFld
Next

'For Each obj In oFld.Items
'obj.Move OArcFld
'Next
'For Each obj In oFld.Items
'obj.Move OArcFld
'Next
'For Each obj In oFld.Items
'obj.Move OArcFld
'Next


Set o2Fld = Nothing
Set O2ArcFld = Nothing
Set Obj = Nothing
Set Atmt = Nothing

Exit Sub
ERR_HANDLER:
MsgBox Err.Description, vbExclamation

End Sub


Public Function GetFolder(strFolderPath As String) As MAPIFolder
' folder path needs to be something like
' "Public Folders\All Public Folders\Company\Sales"
Dim objApp As Outlook.Application
Dim objNS As Outlook.NameSpace
Dim colFolders As Outlook.Folders
Dim objFolder As Outlook.MAPIFolder
Dim arrFolders() As String
Dim i As Long
On Error Resume Next

strFolderPath = Replace(strFolderPath, "/", "\")
arrFolders() = Split(strFolderPath, "\")
Set objApp = CreateObject("Outlook.Application")
Set objNS = objApp.GetNamespace("MAPI")
Set objFolder = objNS.Folders.Item(arrFolders(0))
If Not objFolder Is Nothing Then
For i = 1 To UBound(arrFolders)
Set colFolders = objFolder.Folders
Set objFolder = Nothing
Set objFolder = colFolders.Item(arrFolders(i))
If objFolder Is Nothing Then
Exit For
End If
Next
End If

Set GetFolder = objFolder
Set colFolders = Nothing
Set objNS = Nothing
Set objApp = Nothing
End Function


Public Function ExportMailToTxt(oMail As Outlook.MailItem) As Boolean
' On Error Resume Next
Dim sPath As String: sPath = "K:\Fiapps\supportteam\Performance\"
Dim sName As String
Dim sFile As String


sName = oMail.Subject
sName = sName & ".txt"
oMail.SaveAs sPath & sName, olTXT
ExportMailToTxt = (Err.Number = 0)
End Function

 

[Eric Legault [MVP - Outlook]]

If the subject line is always the same and you are using that as your file
name, then declare an Integer variable and increment that every time you
write your file so that the file name will always be unique (by using the
Integer to append to the file name).

 

[Michael Bednarek]

Hi, I have a seperate folders in outlook that receives 3 emails a day,
all with the same name but containing different data. I have a macro
that looks through the folder, copies the emails as a .txt file and
then places them in another folder. This all works, the only thing is,
it saves the email 3 times using the subject as a file name and so only
leaves me with one file on my (K) drive.
Is there a simple way to save the emails a different name each, though
they have to be consistent as I use a macro in excel daily to take data
out of them, so don't want them named by date of receipt or anything
like that. Here is the code.....thanks....

[snip]

The simplest method would be to incorporate the current date/time into
the filename. e.g.:
sName = oMail.Subject & Format(Now()," YYYYMMDD-hhmmss") & ".TXT"

As it happens, I wrote the following recursive function some years ago
which appends " (nn)" to the file name in a fashion similar to some
other programs. Call it like this:

Dim fs As Object
Dim strFN As String
Set fs = CreateObject("Scripting.FileSystemObject")
strFN = sPath & sName
If fs.FileExists(strFN) Then
strFN =IncrementFilename(fs, strFN)
End If

Function IncrementFilename(fs As Object, fn As String) As String

' Increment (or add) the "(nn") part at the end of a filename.

Dim nLeft As Long, n As Long, bTwoB As Boolean, strNum As String
Dim myPath As String, myFile As String, myExt As String
Dim myfn As String

myPath = fs.GetParentFolderName(fn)
myFile = fs.GetBasename(fn)
myExt = fs.GetExtensionName(fn)

bTwoB = False
nLeft = Len(myFile) ' In case there is no "(nn)"
strNum = " (1"
If Right(myFile, 1) = ")" Then ' Is there a ")" at the end?
n = Len(myFile) - 1
For nLeft = n To 1 Step -1
If Mid(myFile, nLeft, 1) = "(" Then ' Search for "("
bTwoB = True
Exit For
End If
Next nLeft
If bTwoB Then ' Found a "(" ?
strNum = Mid(myFile, nLeft + 1, n - nLeft)
If IsNumeric(strNum) Then
strNum = Format(Val(strNum) + 1)
End If
End If
End If
myfn = myPath & "\" & Left(myFile, nLeft) & strNum & ")." & myExt
Do While fs.FileExists(myfn)
myfn = IncrementFilename(fs, myfn)
Loop
IncrementFilename = myfn
End Function

 

[Simon]

Sorry Michael, I am not sure where to put all that code and whether to
take any of my existing code out. I basically inherited the code from
someone and am pretty clueless with Outlook coding, it seems quite
different to Excel. Can you let me know where/how I am supposed to put
it. Sorry.
Thanks!

 

[Michael Bednarek]

Sorry Michael, I am not sure where to put all that code and whether to
take any of my existing code out. I basically inherited the code from
someone and am pretty clueless with Outlook coding, it seems quite
different to Excel. Can you let me know where/how I am supposed to put
it. Sorry.

Which method do you want to use? Date/time stamping or incremental
numbering?

 

[Simon]

Incremental would be great as I would like the files to stay the same
name every day. Like OFFSHORE 09.1, OFFHSORE 09.2 etc...
I don't mind the fact that they will overwrite the files the next day
as I would have used the data in them by then.

 

[Michael Bednarek]

Incremental would be great as I would like the files to stay the same
name every day. Like OFFSHORE 09.1, OFFHSORE 09.2 etc...
I don't mind the fact that they will overwrite the files the next day
as I would have used the data in them by then.

Below is your function ExportMailToTxt with some alterations to prepare
the invokation of the function IncrementFilename, which I posted earlier:

Public Function ExportMailToTxt(oMail As Outlook.MailItem) As Boolean
' On Error Resume Next
Dim sPath As String: sPath = "K:\Fiapps\supportteam\Performance\"
Dim sName As String
Dim sFile As String
Dim fs as Object

Set fs = CreateObject("Scripting.FileSystemObject")

sName = sPath & oMail.Subject & ".txt"
If fs.FileExists(sName) Then
sName =IncrementFilename(fs, sName)
End If
oMail.SaveAs sName, olTXT
ExportMailToTxt = (Err.Number = 0)
End Function

(not tested)

 

[Simon]

That is absolutely bag on!! Thanks a lot Michael, done the business
perfectly. Thank you so much for all this, I am learning slowly!

Simon