Thanks for looking into this:
Set objNS = Application.GetNamespace("MAPI")
Set olInboxItems = objNS.GetDefaultFolder(olFolderInbox).Items
For Each objMess In olInboxItems
If objMess.Class = olMail Then
Set objStoreFolder = objNS.Folders(strStoreFolder)
' Detect sender
Select Case Left(objMess.SenderName, 20)
'***********************************************************************************************
' IBDX files for production
Case Is = "GE_Enterprise;System"
strTimeStamp = fncFormatDateTimeStamp(objMess.ReceivedTime)
' Check if message header contains search string
If Left(objMess.Subject, Len(strFindSubject)) = strFindSubject Then
' Suppose only 1 attachment per mail
Set objAtt = objMess.Attachments.Item(1)
If objAtt.FileName = "ibdx.asc" Then
' Find folder name in mail subject
If Mid(objMess.Subject, 18, 6) = "Sender" Then
strOrgCode = Mid(objMess.Subject, 25, 4)
Else
strOrgCode = Mid(objMess.Subject, 18, 4)
End If
' Find codes in Tycodata based on org code
' This is different when EG00 (Germany) is sender - i.e. for
satelite companies
' If strOrgCode = "EG00" Or strOrgCode = "A500" Then
objAtt.SaveAsFile strSateliteFile
strOrgCode = fncDetermineSatelite(strSateliteFile)
' End If
strFolder = _
fncGetTycoData(strOrgCode, "[OrganisationCode]",
"[CompanyCode]") & " - " & _
fncGetTycoData(strOrgCode, "[OrganisationCode]",
"[SystemRoutingID]") & " - " & _
strOrgCode & " - " & _
fncGetTycoData(strOrgCode, "[OrganisationCode]",
"[SapMachineDestination]")
' Format filename with datestamp based in mail time
strFile = "ibdx-" & strTimeStamp
' Create folder if not exists
If Dir(strPath & strFolder, vbDirectory) = "" Then
MkDir strPath & strFolder
blnFoldersCreated = True
strNewFolders = strNewFolders & vbLf & " - " & strFolder
If Left(strFolder, 4) = "0000" Then
strNewFolders = strNewFolders & " - no SRID found in
TycoData"
End If
End If
' Save attachment in specified folder
objAtt.SaveAsFile strPath & strFolder & "\" & strFile & strExt
' Move item to personal folders
On Error Resume Next
Set objStoreFolder = objStoreFolder.Folders(strMoveFolderProd)
Set objMoveFolder = objStoreFolder.Folders(strFolder)
' Create folder if needed
If objMoveFolder Is Nothing Then _
Set objMoveFolder = objStoreFolder.Folders.Add(strFolder)
On Error GoTo ErrorLine
objMess.Move objMoveFolder
Else
MsgBox "Different file name/extension"
End If
End If
'***********************************************************************************************
' IBDX files for testing
Case Is = "Enterprise_System;DE", "Enterprise System DE" 'DE =
development
' Suppose only 1 attachment per mail
Set objAtt = objMess.Attachments.Item(1)
If objAtt.FileName = "ibdx.asc" Then
strTimeStamp = fncFormatDateTimeStamp(objMess.ReceivedTime)
' Find folder name in mail subject
If Mid(objMess.Subject, 18, 6) = "Sender" Then
strOrgCode = Mid(objMess.Subject, 25, 4)
Else
strOrgCode = Mid(objMess.Subject, 18, 4)
End If
objAtt.SaveAsFile strTestPath & strOrgCode & strTimeStamp & strExt
' Read attachment when saved
Open strTestPath & strOrgCode & strTimeStamp & strExt For Input As
#1
intTnxs = 0
Do Until EOF(1)
Line Input #1, strText
Select Case Left(strText, 1)
Case Is = "0"
strMessage = strMessage & vbLf & _
"Company " & Mid(strText, 2, 4) & " (" & Mid(strText,
10, 5) & ") - " & _
"Batch " & Val(Mid(strText, 20, 6)) & " - "
Case Is = "1"
intTnxs = intTnxs + 1
End Select
Loop
strMessage = strMessage & "Transactions " & intTnxs
Close #1
Else
MsgBox "Different test file name/extension"
End If
' Move mail to TEST folder
Set objMoveFolder = objStoreFolder.Folders(strMoveFolderTest)
objMess.Move objMoveFolder
intTest = intTest + 1
End Select
End If
Set objMoveFolder = Nothing
DoEvents
Next objMess
'Prompts
If blnFoldersCreated = True Then _
MsgBox strNewFolders, vbOKOnly + vbInformation, strTitle
Select Case intTest
Case Is = 1
strMessage = "1 test file arrived:" & vbLf & strMessage
Case Is > 1
strMessage = intTest & " test files arrived:" & vbLf & strMessage
End Select
If Not intTest = 0 Then MsgBox strMessage, vbOKOnly + vbInformation,
strTitle
'--------------------------------------------------------------------------------------
FinalLine:
Set objStoreFolder = Nothing
Set objMoveFolder = Nothing
Set olInboxItems = Nothing
Set objNS = Nothing
Exit Sub
'--------------------------------------------------------------------------------------
ErrorLine:
MsgBox "An error occured: " & vbLf & "Error description: " & Error
Resume FinalLine
End Sub
Sue Mosher said:
Show a code snippet.
--
Sue Mosher, Outlook MVP
Author of
Microsoft Outlook Programming - Jumpstart for
Administrators, Power Users, and Developers
I have a macro looping through my inbox (For Each obj In olInboxItems
...)
to
detect items with a specific subject. Each of these items contains an
attachment which is save on our local network.
For one reason or another, the loop often skips messages to go on with
the
next item. This causes me to run the macro a few times before all the
attachments are saved.
Anyone has a reason why this is happening? Is it a timing issue? Does
it
have to do with sorting the items?
