Сохранить вложения в папку в Outlook и переименовать их

Question

Я пытаюсь сохранить вложения в Outlook в папку и где имя файла уже существует, а новый файл под другим именем, чтобы не сохранять существующий файл .... возможно, просто укажите расширение «v2» или даже «v3», если существует «v2».

я наткнулся на этот ответ, но нахожу, что новый файл будет сохранен поверх существующего файла

Save attachments to a folder and rename them

я использовал код ниже;

Dim objAttachments As Outlook.Attachments 
Dim objSelection As Outlook.Selection 
Dim i As Long 
Dim lngCount As Long 
Dim strFile As String 
Dim strFolderpath As String 
Dim strDeletedFiles As String 



' Get the path to your My Documents folder 
strFolderpath = "C:\Users\Owner\my folder is here" 
On Error Resume Next 

' Instantiate an Outlook Application object. 
Set objOL = CreateObject("Outlook.Application") 

' Get the collection of selected objects. 
Set objSelection = objOL.ActiveExplorer.Selection 

' Set the Attachment folder. 
strFolderpath = strFolderpath & "\my subfolder is here\" 

' Check each selected item for attachments. If attachments exist, 
' save them to the strFolderPath folder and strip them from the item. 
For Each objMsg In objSelection 

' This code only strips attachments from mail items. 
' If objMsg.class=olMail Then 
' Get the Attachments collection of the item. 
Set objAttachments = objMsg.Attachments 
lngCount = objAttachments.Count 
strDeletedFiles = "" 

If lngCount > 0 Then 

    ' We need to use a count down loop for removing items 
    ' from a collection. Otherwise, the loop counter gets 
    ' confused and only every other item is removed. 

    For i = lngCount To 1 Step -1 

     ' Save attachment before deleting from item. 
     ' Get the file name. 
     strFile = objAttachments.Item(i).FileName 

     ' Combine with the path to the Temp folder. 
     strFile = strFolderpath & strFile 

     ' Save the attachment as a file. 
     objAttachments.Item(i).SaveAsFile strFile 


     ' Delete the attachment. 
     objAttachments.Item(i).Delete 

     'write the save as path to a string to add to the message 
     'check for html and use html tags in link 
     If objMsg.BodyFormat <> olFormatHTML Then 
      strDeletedFiles = strDeletedFiles & vbCrLf & "<file://" & strFile & ">" 
     Else 
      strDeletedFiles = strDeletedFiles & "<br>" & "<a href='file://" & _ 
      strFile & "'>" & strFile & "</a>" 
     End If 

     'Use the MsgBox command to troubleshoot. Remove it from the final code. 
     'MsgBox strDeletedFiles 

    Next i 

    ' Adds the filename string to the message body and save it 
    ' Check for HTML body 
    If objMsg.BodyFormat <> olFormatHTML Then 
     objMsg.Body = vbCrLf & "The file(s) were saved to " & strDeletedFiles & vbCrLf & objMsg.Body 
    Else 
     objMsg.HTMLBody = "<p>" & "The file(s) were saved to " & strDeletedFiles & "</p>" & objMsg.HTMLBody 
    End If 
    objMsg.Save 
End If 
Next 

ExitSub: 

Set objAttachments = Nothing 
Set objMsg = Nothing 
Set objSelection = Nothing 
Set objOL = Nothing 
End Sub 

Я относительно новичок в vba, поэтому, возможно, решение есть, но я не вижу его!

Answer 1

Посмотрите на мой код ниже. Он проходит через все элементы в определенной папке Outlook (которую вы назначаете), проходит через каждое вложение в каждом элементе и сохраняет вложение в указанном пути к файлу.

'Establish path of folder you want to save to 

Dim FilePath As Variant 

FilePath = "C:\Users\Owner\my folder is here\my subfolder is here\" 

    Set FSOobj = CreateObject("Scripting.FilesystemObject") 

    'If path doesn't exist, create it. If it does, either do nothing or delete its contents 
    If FSOobj.FolderExists(FilePath) = False Then 
     FSOobj.CreateFolder FilePath 
    Else 
     ' This code is if you want to delete the items in the existing folder first. 
     ' It's not necessary for your case. 
     On Error Resume Next 
     Kill FilePath & "*.*" 
     On Error GoTo 0 
    End If 

'Establish Outlook folders, attachments, and other items 

Dim msOutlook As Outlook.NameSpace 'Establish Outlook NameSpace 
Dim Folder As Outlook.MAPIFolder 'Establish Folder as a MAPIFolder 
Dim messageAttachments As Outlook.Attachments 

Set msOutlook = Application.GetNamespace("MAPI") 

'Set the folder that contains the email with the attachment 
Set Folder = msOutlook.GetDefaultFolder(olFolderInbox).Folders("FOLDER NAME HERE") 

Set folderItems = Folder.Items 

Dim folderItemsCount As Long 
folderItemsCount = folderItems.Count 

Dim number as Integer 
number = 1 

For i = 1 To folderItemsCount 
    'If you want to pull the attachments on some criteria, like the Subject of the email or 
    'the date received, you need to write an IF statement like: 
    'If InStr(Folder.Items(i).Subject, "SPECIFIC SUBJECT TEXT") Then 

    Set messageAttachments = folderItems.item(i).Attachments 
    lngCount = messageAttachments.Count 'This lets you pull more than one attachment per message 
    For thisAttachment = 1 To lngCount 
     messageAttachments.item(thisAttachment).SaveAsFile FilePath & "YOUR_CHOSEN_FILENAME" & number & ".xlsx" 
     number = number + 1 
    Next thisAttachment 
Next i 

---

EDIT

Для того, чтобы удалить элементы после соскабливания вложения, вы должны использовать один и тот же код, как описано выше, за исключением того, будет также включать folderItems.item(i).Delete. Кроме того, поскольку вы перемещаете элементы, я переключился на цикл назад в вашем цикле for, чтобы не испортить вашу итерацию. Я написал это ниже:

For i = folderItemsCount To 1 Step -1 
    'If you want to pull the attachments on some criteria, like the Subject of the email or 
    'the date received, you need to write an IF statement like: 
    'If InStr(Folder.Items(i).Subject, "SPECIFIC SUBJECT TEXT") Then 

    Set messageAttachments = folderItems.item(i).Attachments 
    lngCount = messageAttachments.Count 'This lets you pull more than one attachment per message 
    For thisAttachment = 1 To lngCount 
     messageAttachments.item(thisAttachment).SaveAsFile FilePath & "YOUR_CHOSEN_FILENAME" & number & ".xlsx" 
     number = number + 1 
    Next thisAttachment 
    folderItems.item(i).Delete 
Next i 

Надеюсь, это поможет!