Outlook XP : Exporting Attachment Text?? 2

[safaritek]

On a daily basis I receive a large number of emails for a specific purpose - the majority which have TXT attachments containing important information from our clients.

I want to export all the emails for this information to a database (Access) so it can be managed better. I can easily figure out how to export the messages themselves, including all the TO/FROM/etc fields, but there does not appear to be a way to export the actual text from the attachment file as part of the process.

Does anyone have a way to do this - or to force the text from the attachments to appear inline instead of attached - or (as a last alternative) a way to automatically save the attachments to file with a unique name? At least the latter would allow me to read the text in via another message. All the TXT attachments have the same name, so it is not just a matter of saving, it has to generate a name for it based on the email header or something.

Thanks in advance!

 

[nberryman]

This should do the latter, if you need more let me know, I have the code to inport the text files somewhere.

Declarations

Option Explicit

Private Const MAX_PATH = 255

Private Declare Function GetTempPath Lib "kernel32" _
Alias "GetTempPathA" (ByVal nBufferLength As Long, _
ByVal lpBuffer As String) As Long

Code

Public Function SaveAttachments(Optional PathName As String) _
As Boolean
'************************************************************
' USAGE: SAVES ATTACHMENTS FROM INBOX TO A DIRECTORY

' PARAMETER: PATHNAME (OPTIONAL): WHERE TO SAVE THE FILES.
' IF NOT PROVIDED, THE SYSTEM'S TEMPORARY DIRECTORY IS USED

' REQUIRES: OUTLOOK TO BE INSTALLED ON RUNNING MACHINE AND
' A REFERENCE TO THE OUTLOOK OBJECT LIBRARY

' RETURNS: TRUE IF SUCCESSFUL, FALSE OTHERWISE
'*************************************************************


Dim oOutlook As Outlook.Application
Dim oNs As Outlook.NameSpace
Dim oFldr As Outlook.MAPIFolder
Dim oMessage As Object
Dim sPathName As String
Dim oAttachment As Outlook.Attachment
Dim iCtr As Integer
Dim iAttachCnt As Integer

On Error GoTo ErrHandler

If PathName = "" Then
sPathName = GetTempDir
Else
sPathName = PathName
End If

If Right(sPathName, 1) <> &quot;\&quot; Then sPathName = sPathName & &quot;\&quot;
If Dir(sPathName, vbDirectory) = &quot;&quot; Then Exit Function

Set oOutlook = New Outlook.Application
Set oNs = oOutlook.GetNamespace(&quot;MAPI&quot
Set oFldr = oNs.GetDefaultFolder(olFolderInbox)
For Each oMessage In oFldr.Items
With oMessage.Attachments
iAttachCnt = .Count
If iAttachCnt > 0 Then
For iCtr = 1 To iAttachCnt
.Item(iCtr).SaveAsFile sPathName _
& .Item(iCtr).FileName
Next iCtr
End If
End With
DoEvents

Next oMessage
SaveAttachments = True

ErrHandler:
Set oMessage = Nothing
Set oFldr = Nothing
Set oNs = Nothing
Set oOutlook = Nothing
End Function

Public Function GetTempDir() As String

'from

http://www.freevbcode.com/ShowCode.asp?ID=1

Dim sRet As String, lngLen As Long


'create buffer
sRet = String(MAX_PATH, 0)

lngLen = GetTempPath(MAX_PATH, sRet)
If lngLen = 0 Then Err.Raise Err.LastDllError
GetTempDir = Left$(sRet, lngLen)
End Function


Neil Berryman
IT Trainer
neil_berryman@btopenworld.com