1
Hi I have a program that download files from the email and puts it into the corresponding folder.
What i would like to know is how to sort and then appned if the file already exists i.e i get strString = "9301ARUP" . I'm checking for arup
if strString.instr("ARUP")> 0
if strString.checkfileexist("true") then
add a letter to the end
then save the file to a folder
else
then save the file to a folder
However This is for one type of file I would like to have this through a case statement
Select Case (strString)
Case "ARUP"
Case "BDR"
Case "DDTL" .........
Approximately 30 different files
and saves it to their perspective folders
******************************** HERE IS THE CODE **********************************
Option Explicit
Sub GetAttachments()
On Error GoTo GetAttachments_err
' Declare variables
Dim appOl As New Outlook.Application
Dim ns As Outlook.NameSpace
Dim Inbox As Outlook.MAPIFolder
Dim Item As Object
Dim Atmt As Outlook.Attachment
Dim FileName As String
Dim i As Integer
Set ns = appOl.GetNamespace("MAPI")
Set Inbox = ns.GetDefaultFolder(olFolderInbox)
i = 0
' Check Inbox for messages and exit of none found
If Inbox.Items.Count = 0 Then
MsgBox "There are no messages in the Inbox.", vbInformation, _
"Nothing Found"
Exit Sub
End If
' Check each message for attachments
For Each Item In Inbox.Items
' Save any attachments found
For Each Atmt In Item.Attachments
' This path must exist! Change folder name as necessary.
FileName = "C:\Email Attachments\" & Atmt.FileName
Atmt.SaveAsFile FileName
i = i + 1
Next Atmt
Next Item
' Show summary message
If i > 0 Then
MsgBox "I found " & i & " attached files." _
& vbCrLf & "I have saved them into the C:\Email Attachments folder." _
& vbCrLf & vbCrLf & "Have a nice day.", vbInformation, "Finished!"
Else
MsgBox "I didn't find any attached files in your mail.", vbInformation, "Finished!"
End If
' Clear memory
GetAttachments_exit:
Set Atmt = Nothing
Set Item = Nothing
Set ns = Nothing
Set appOl = Nothing
Exit Sub
' Handle errors
GetAttachments_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 GetAttachments_exit
End Sub
Sub SaveAttachmentsToFolder()
On Error GoTo SaveAttachmentsToFolder_err
' Declare variables
Dim DateCode As String 'Input from user the current date
Dim strText2 As String
Dim strText1 As String 'For Trimming the file name for case statements
Dim strText As String ' For getting the file name
Dim appOl As New Outlook.Application
Dim ns As Outlook.NameSpace
Dim Inbox As Outlook.MAPIFolder
Dim SubFolder As Outlook.MAPIFolder
Dim Item As Object
Dim Atmt As Outlook.Attachment
Dim FileName As String
Dim FileName2 As String
Dim i As Integer
Dim strText5 As String
Dim varResponse As Variant
Set ns = appOl.GetNamespace("MAPI")
Set Inbox = ns.GetDefaultFolder(olFolderInbox)
Set SubFolder = Inbox.Folders("ADMINLC") ' Enter correct subfolder name.
i = 0
' Check subfolder for messages and exit of none found
If SubFolder.Items.Count = 0 Then
MsgBox "There are no messages in the ADMINLC folder.", vbInformation, _
"Nothing Found"
Exit Sub
End If
' Check each message for attachments
DateCode = InputBox("Please Enter the date for the files")
For Each Item In SubFolder.Items
For Each Atmt In Item.Attachments
strText = Atmt.FileName
strText1 = Left(strText, 3) 'Right(strText, Len(strText) - 3)
strText5 = Right(strText1, 3)
'If strText1 = "AGE" Or strText1 = "API" Or strText1 = "APR" Or strText1 = "ARE" Or strText1 = "ARL" or strText = Case "ARE"
'or strText1= "BDR" or strText1 = "COA" or strText1 = "DDT" OR strText1 = "DEP" OR strText1 = "RDE" OR strText1 = "DIV"
'OR strText1 = "DOC" OR strText1 = "DTR" OR strText1 = "DRO" OR strText1 =
'Case "ARL"
'Case "ARU"
'Case "BDR"
'Case "COA"
'Case "DDT"
'Case "DEP"
'Case "RDE"
'Case "DIV"
'Case "DOC"
'Case "DRO"
'Case "DTR"
'Case "GRN"
'Then
Select Case strText1
Case "AGE"
strText2 = Left(strText, Len(strText) - 4)
FileName = "C:\Email Attachments\AGE\" & strText2 & DateCode & ".TXT"
FileName2 = strText2 & DateCode
'MsgBox ("the file name" & DateCode)
'If LenB(Dir$("C:\Email Attachments\AGE\Filename"))
' FileName = "C:\Email Attachments\AGE\" & strText2 & DateCode & "A" & ".TXT"
Atmt.SaveAsFile FileName
' End If
Case "ARL"
strText2 = Left(strText, Len(strText) - 4)
FileName = "C:\Email Attachments\ARLD\" & strText2 & DateCode & ".TXT"
FileName2 = strText2 & DateCode
'MsgBox ("the file name" & DateCode)
'If LenB(Dir$("C:\Email Attachments\AGE\Filename"))
' FileName = "C:\Email Attachments\AGE\" & strText2 & DateCode & "A" & ".TXT"
Atmt.SaveAsFile FileName
' End If
Case "ARU"
strText2 = Left(strText, Len(strText) - 4)
FileName = "C:\Email Attachments\ARUP\" & strText2 & DateCode & ".TXT"
FileName2 = strText2 & DateCode
'MsgBox ("the file name" & DateCode)
'If LenB(Dir$("C:\Email Attachments\AGE\Filename"))
' FileName = "C:\Email Attachments\AGE\" & strText2 &
DateCode & "A" & ".TXT"
Atmt.SaveAsFile FileName
' End If
Case "BDR"
strText2 = Left(strText, Len(strText) - 4)
FileName = "C:\Email Attachments\BDR\" & strText2 &
DateCode & ".TXT"
FileName2 = strText2 & DateCode
'MsgBox ("the file name" & DateCode)
'If LenB(Dir$("C:\Email Attachments\AGE\Filename"))
' FileName = "C:\Email Attachments\AGE\" & strText2 &
DateCode & "A" & ".TXT"
Atmt.SaveAsFile FileName
' End If
Case "COA"
strText2 = Left(strText, Len(strText) - 4)
FileName = "C:\Email Attachments\COA\" & strText2 & DateCode & ".TXT"
FileName2 = strText2 & DateCode
'MsgBox ("the file name" & DateCode)
'If LenB(Dir$("C:\Email Attachments\AGE\Filename"))
' FileName = "C:\Email Attachments\AGE\" & strText2 & DateCode & "A" & ".TXT"
Atmt.SaveAsFile FileName
' End If
Case "DDT"
strText2 = Left(strText, Len(strText) - 4)
FileName = "C:\Email Attachments\DDTL\" & strText2 & DateCode & ".TXT"
FileName2 = strText2 & DateCode
'MsgBox ("the file name" & DateCode)
'If LenB(Dir$("C:\Email Attachments\AGE\Filename"))
' FileName = "C:\Email Attachments\AGE\" & strText2 & DateCode & "A" & ".TXT"
Atmt.SaveAsFile FileName
' End If
Case "DEP"
strText2 = Left(strText, Len(strText) - 4)
FileName = "C:\Email Attachments\DEPT57\" & strText2 & DateCode & ".TXT"
FileName2 = strText2 & DateCode
'MsgBox ("the file name" & DateCode)
'If LenB(Dir$("C:\Email Attachments\AGE\Filename"))
' FileName = "C:\Email Attachments\AGE\" & strText2 & DateCode & "A" & ".TXT"
Atmt.SaveAsFile FileName
' End If
Case "RDE"
strText2 = Left(strText, Len(strText) - 4)
FileName = "C:\Email Attachments\DEPT57\" & strText2 & DateCode & ".TXT"
FileName2 = strText2 & DateCode
'MsgBox ("the file name" & DateCode)
'If LenB(Dir$("C:\Email Attachments\AGE\Filename"))
' FileName = "C:\Email Attachments\AGE\" & strText2 & DateCode & "A" & ".TXT"
Atmt.SaveAsFile FileName
' End If
Case "DIV"
strText2 = Left(strText, Len(strText) - 4)
FileName = "C:\Email Attachments\Dist Trn\" & strText2 & DateCode & ".TXT"
FileName2 = strText2 & DateCode
'MsgBox ("the file name" & DateCode)
'If LenB(Dir$("C:\Email Attachments\AGE\Filename"))
' FileName = "C:\Email Attachments\AGE\" & strText2 & DateCode & "A" & ".TXT"
Atmt.SaveAsFile FileName
' End If
Case "DOC"
strText2 = Left(strText, Len(strText) - 4)
FileName = "C:\Email Attachments\DOC\" & strText2 & DateCode & ".TXT"
FileName2 = strText2 & DateCode
'MsgBox ("the file name" & DateCode)
'If LenB(Dir$("C:\Email Attachments\AGE\Filename"))
' FileName = "C:\Email Attachments\AGE\" & strText2 & DateCode & "A" & ".TXT"
Atmt.SaveAsFile FileName
' End If
Case "DRO"
strText2 = Left(strText, Len(strText) - 4)
FileName = "C:\Email Attachments\DROP\" & strText2 & DateCode & ".TXT"
FileName2 = strText2 & DateCode
'MsgBox ("the file name" & DateCode)
'If LenB(Dir$("C:\Email Attachments\AGE\Filename"))
' FileName = "C:\Email Attachments\AGE\" & strText2 & DateCode & "A" & ".TXT"
Atmt.SaveAsFile FileName
' End If
Case "DTR"
strText2 = Left(strText, Len(strText) - 4)
FileName = "C:\Email Attachments\DTRN\" & strText2 & DateCode & ".TXT"
FileName2 = strText2 & DateCode
'MsgBox ("the file name" & DateCode)
'If LenB(Dir$("C:\Email Attachments\AGE\Filename"))
' FileName = "C:\Email Attachments\AGE\" & strText2 & DateCode & "A" & ".TXT"
Atmt.SaveAsFile FileName
' End If
Case "GRN"
strText2 = Left(strText, Len(strText) - 4)
FileName = "C:\Email Attachments\GRNI\" & strText2 & DateCode & ".TXT"
FileName2 = strText2 & DateCode
'MsgBox ("the file name" & DateCode)
'If LenB(Dir$("C:\Email Attachments\AGE\Filename"))
' FileName = "C:\Email Attachments\AGE\" & strText2 & DateCode & "A" & ".TXT"
Atmt.SaveAsFile FileName
' End If
End Select
'Select Case strText5
' Case "-REJ"
' Case "ERO"
'Case "END"
'Case "GL"
'Case ""
' End Select
' This path must exist! Change folder name as necessary.
FileName = "C:\Email Attachments\" & Atmt.FileName
Atmt.SaveAsFile FileName
i = i + 1
Next Atmt
Next Item
' Show summary message
If i > 0 Then
varResponse = MsgBox("I found " & i & " attached files." _
& vbCrLf & "I have saved them into the C:\Email Attachments folder." _
& vbCrLf & vbCrLf & "Would you like to view the files now?" _
, vbQuestion + vbYesNo, "Finished!")
' Open Windows Explorer to display saved files if user chooses
If varResponse = vbYes Then
Shell "Explorer.exe /e,C:\Email Attachments", vbNormalFocus
End If
Else
MsgBox "I didn't find any attached files in your mail.", vbInformation, "Finished!"
End If
' Clear memory
SaveAttachmentsToFolder_exit:
Set Atmt = Nothing
Set Item = Nothing
Set ns = Nothing
Set appOl = Nothing
Exit Sub
' Handle Errors
SaveAttachmentsToFolder_err:
MsgBox "An unexpected error has occurred." _
& vbCrLf & "Please note and report the following information." _
& vbCrLf & "Macro Name: SaveAttachmentsToFolder" _
& vbCrLf & "Error Number: " & Err.Number _
& vbCrLf & "Error Description: " & Err.Description _
, vbCritical, "Error!"
Resume SaveAttachmentsToFolder_exit
End Sub
