Outlookのフォルダに添付ファイルを保存して名前を変更します

Question

フォルダにOutlookの添付ファイルを保存しようとしていますが、ファイル名が既に存在する場合は、新しいファイルを別の名前で保存して既存のファイルを保存しないようにします。 「v2」が存在する場合は、拡張子「v2」または「v3」を指定するだけです。

私は以下のコードを使用している

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 

私はこれが助けて欲しい！