Необходимо поправить код, чтобы сохранялись все файлы от определенных пользователей из писем, в определенные папки. Не в архиве.
Не в одну папку, как ниже, а от каждого пользователя в определенную папку.
Public Sub saveAttachtoDisk(itm As Outlook.MailItem)
Dim objAtt As Outlook.Attachment
Dim fdObj As Object
Dim saveFolder As String
'dateOfMailItem = Format(itm.CreationTime, "yyyy.mm.dd.hhnnss")
Set fdObj = CreateObject("Scripting.FileSystemObject")
If itm.SenderEmailType = "EX" Then
NameOfMailItem = itm.Sender.GetExchangeUser.PrimarySmtpAddress
Else
NameOfMailItem = itm.SenderEmailAddress
End If
If NameOfMailItem = "[email protected]" Then '"[email protected]" Then
NameOfMailItem = "Maxlevel"
ElseIf NameOfMailItem = "[email protected]" Then
NameOfMailItem = "Santex"
ElseIf NameOfMailItem = "c" Then
NameOfMailItem = "C1"
ElseIf NameOfMailItem = "d" Then
NameOfMailItem = "D1"
ElseIf NameOfMailItem = "e" Then
NameOfMailItem = "E1"
End If
saveFolder = "C:\Temp" & "\" & NameOfMailItem
If PathExists3(saveFolder) Then
Else
'MsgBox CreateObject("Scripting.FileSystemObject").FolderExists(saveFolder)
fdObj.CreateFolder (saveFolder)
'MsgBox CreateObject("Scripting.FileSystemObject").FolderExists(saveFolder)
End If
For Each objAtt In itm.Attachments
objAtt.SaveAsFile saveFolder & "\" & objAtt.FileName
Set objAtt = Nothing
Next
End Sub
Function PathExists3(path) As Boolean
Dim FSO As Object, FolderObj As Object
Set FSO = CreateObject("Scripting.FileSystemObject")
On Error Resume Next
Set FolderObj = FSO.getfolder(path)
PathExists3 = (Err = 0)
End Function
