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.check fileexist("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.Applica tion
Dim ns As Outlook.NameSpa ce
Dim Inbox As Outlook.MAPIFol der
Dim Item As Object
Dim Atmt As Outlook.Attachm ent
Dim FileName As String
Dim i As Integer
Set ns = appOl.GetNamesp ace("MAPI")
Set Inbox = ns.GetDefaultFo lder(olFolderIn box)
i = 0
' Check Inbox for messages and exit of none found
If Inbox.Items.Cou nt = 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.Attachment s
' 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 SaveAttachments ToFolder()
On Error GoTo SaveAttachments ToFolder_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.Applica tion
Dim ns As Outlook.NameSpa ce
Dim Inbox As Outlook.MAPIFol der
Dim SubFolder As Outlook.MAPIFol der
Dim Item As Object
Dim Atmt As Outlook.Attachm ent
Dim FileName As String
Dim FileName2 As String
Dim i As Integer
Dim strText5 As String
Dim varResponse As Variant
Set ns = appOl.GetNamesp ace("MAPI")
Set Inbox = ns.GetDefaultFo lder(olFolderIn box)
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("Pleas e Enter the date for the files")
For Each Item In SubFolder.Items
For Each Atmt In Item.Attachment s
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:\E mail 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\ARL D\" & strText2 & DateCode & ".TXT"
FileName2 = strText2 & DateCode
'MsgBox ("the file name" & DateCode)
'If LenB(Dir$("C:\E mail 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\ARU P\" & strText2 & DateCode & ".TXT"
FileName2 = strText2 & DateCode
'MsgBox ("the file name" & DateCode)
'If LenB(Dir$("C:\E mail 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:\E mail 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:\E mail 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\DDT L\" & strText2 & DateCode & ".TXT"
FileName2 = strText2 & DateCode
'MsgBox ("the file name" & DateCode)
'If LenB(Dir$("C:\E mail 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\DEP T57\" & strText2 & DateCode & ".TXT"
FileName2 = strText2 & DateCode
'MsgBox ("the file name" & DateCode)
'If LenB(Dir$("C:\E mail 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\DEP T57\" & strText2 & DateCode & ".TXT"
FileName2 = strText2 & DateCode
'MsgBox ("the file name" & DateCode)
'If LenB(Dir$("C:\E mail 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\Dis t Trn\" & strText2 & DateCode & ".TXT"
FileName2 = strText2 & DateCode
'MsgBox ("the file name" & DateCode)
'If LenB(Dir$("C:\E mail 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:\E mail 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\DRO P\" & strText2 & DateCode & ".TXT"
FileName2 = strText2 & DateCode
'MsgBox ("the file name" & DateCode)
'If LenB(Dir$("C:\E mail 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\DTR N\" & strText2 & DateCode & ".TXT"
FileName2 = strText2 & DateCode
'MsgBox ("the file name" & DateCode)
'If LenB(Dir$("C:\E mail 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\GRN I\" & strText2 & DateCode & ".TXT"
FileName2 = strText2 & DateCode
'MsgBox ("the file name" & DateCode)
'If LenB(Dir$("C:\E mail 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.e xe /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
SaveAttachments ToFolder_exit:
Set Atmt = Nothing
Set Item = Nothing
Set ns = Nothing
Set appOl = Nothing
Exit Sub
' Handle Errors
SaveAttachments ToFolder_err:
MsgBox "An unexpected error has occurred." _
& vbCrLf & "Please note and report the following information." _
& vbCrLf & "Macro Name: SaveAttachments ToFolder" _
& vbCrLf & "Error Number: " & Err.Number _
& vbCrLf & "Error Description: " & Err.Description _
, vbCritical, "Error!"
Resume SaveAttachments ToFolder_exit
End Sub
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.check fileexist("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.Applica tion
Dim ns As Outlook.NameSpa ce
Dim Inbox As Outlook.MAPIFol der
Dim Item As Object
Dim Atmt As Outlook.Attachm ent
Dim FileName As String
Dim i As Integer
Set ns = appOl.GetNamesp ace("MAPI")
Set Inbox = ns.GetDefaultFo lder(olFolderIn box)
i = 0
' Check Inbox for messages and exit of none found
If Inbox.Items.Cou nt = 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.Attachment s
' 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 SaveAttachments ToFolder()
On Error GoTo SaveAttachments ToFolder_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.Applica tion
Dim ns As Outlook.NameSpa ce
Dim Inbox As Outlook.MAPIFol der
Dim SubFolder As Outlook.MAPIFol der
Dim Item As Object
Dim Atmt As Outlook.Attachm ent
Dim FileName As String
Dim FileName2 As String
Dim i As Integer
Dim strText5 As String
Dim varResponse As Variant
Set ns = appOl.GetNamesp ace("MAPI")
Set Inbox = ns.GetDefaultFo lder(olFolderIn box)
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("Pleas e Enter the date for the files")
For Each Item In SubFolder.Items
For Each Atmt In Item.Attachment s
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:\E mail 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\ARL D\" & strText2 & DateCode & ".TXT"
FileName2 = strText2 & DateCode
'MsgBox ("the file name" & DateCode)
'If LenB(Dir$("C:\E mail 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\ARU P\" & strText2 & DateCode & ".TXT"
FileName2 = strText2 & DateCode
'MsgBox ("the file name" & DateCode)
'If LenB(Dir$("C:\E mail 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:\E mail 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:\E mail 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\DDT L\" & strText2 & DateCode & ".TXT"
FileName2 = strText2 & DateCode
'MsgBox ("the file name" & DateCode)
'If LenB(Dir$("C:\E mail 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\DEP T57\" & strText2 & DateCode & ".TXT"
FileName2 = strText2 & DateCode
'MsgBox ("the file name" & DateCode)
'If LenB(Dir$("C:\E mail 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\DEP T57\" & strText2 & DateCode & ".TXT"
FileName2 = strText2 & DateCode
'MsgBox ("the file name" & DateCode)
'If LenB(Dir$("C:\E mail 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\Dis t Trn\" & strText2 & DateCode & ".TXT"
FileName2 = strText2 & DateCode
'MsgBox ("the file name" & DateCode)
'If LenB(Dir$("C:\E mail 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:\E mail 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\DRO P\" & strText2 & DateCode & ".TXT"
FileName2 = strText2 & DateCode
'MsgBox ("the file name" & DateCode)
'If LenB(Dir$("C:\E mail 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\DTR N\" & strText2 & DateCode & ".TXT"
FileName2 = strText2 & DateCode
'MsgBox ("the file name" & DateCode)
'If LenB(Dir$("C:\E mail 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\GRN I\" & strText2 & DateCode & ".TXT"
FileName2 = strText2 & DateCode
'MsgBox ("the file name" & DateCode)
'If LenB(Dir$("C:\E mail 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.e xe /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
SaveAttachments ToFolder_exit:
Set Atmt = Nothing
Set Item = Nothing
Set ns = Nothing
Set appOl = Nothing
Exit Sub
' Handle Errors
SaveAttachments ToFolder_err:
MsgBox "An unexpected error has occurred." _
& vbCrLf & "Please note and report the following information." _
& vbCrLf & "Macro Name: SaveAttachments ToFolder" _
& vbCrLf & "Error Number: " & Err.Number _
& vbCrLf & "Error Description: " & Err.Description _
, vbCritical, "Error!"
Resume SaveAttachments ToFolder_exit
End Sub