Outlook件名を使用して複数の添付ファイルを保存し、その名前を増やす

Question

私はVBAで2週間プレイしましたが、これについての専門家ではありません。

私が探しているのはこのコードを修正したものです。

Public Sub SaveAttachments() 
Dim objOL As Outlook.Application 
Dim objMsg As Outlook.MailItem 'Object 
Dim objAttachments As Outlook.Attachments 
Dim objSelection As Outlook.Selection 
Dim i As Integer 
Dim lngCount As Integer 
Dim strFile As String 
Dim strFolderpath As String 
Dim strFileName As String 
Dim objSubject As String 
Dim strDeletedFiles As String 
' Get the path to your My Documents folder 
'strFolderpath = CreateObject("WScript.Shell").SpecialFolders(16) 
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 
' The attachment folder needs to exist 
' You can change this to another folder name of your choice 
' Set the Attachment folder. 
strFolderpath = "C:\Users\demkep\Documents\" 
' Check each selected item for attachments. 
For Each objMsg In objSelection 
'Set FileName to Subject 
objSubject = objMsg.Subject 
Set objAttachments = objMsg.Attachments 
lngCount = objAttachments.Count 
If lngCount > 0 Then 
' 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 
' Get the file name. 
strFileName = objSubject & ".pdf" 
' Combine with the path to the Temp folder. 
strFile = strFolderpath & strFileName 
Debug.Print strFile 
' Save the attachment as a file. 
objAttachments.Item(i).SaveAsFile strFile 
Next i 
End If 
Next 
ExitSub: 
Set objAttachments = Nothing 
Set objMsg = Nothing 
Set objSelection = Nothing 
Set objOL = Nothing 
End Sub 

これは私が達成しようとしているものに最も近いものです。

複数の添付ファイルがあるメールを受け取った場合、最後のファイルが上書きされます。可能なら。私はそれを"emailsubject, emailsubject(1), emailsubject(2), emailsubject(3)"などと保存することがあります（時には最大30の.pdfファイル）。

助けていただければ幸いです。

Answer 1

ループ内でファイル名を変更していません。何かのように

strFileName = objSubject & "(" & i & ").pdf" 

のようにしてください。

名前を設定する前にlngCountを確認するかIIf

If lngCount > 1 Then 
    strFileName = objSubject & "(" & i & ").pdf" 
Else 
    strFileName = objSubject & ".pdf" 
End If 

それとも

あなたは使用しないでください

strFileName = objSubject & IIf(lngCount>1, "(" & i & ")", "") & ".pdf" 

---

を使用することができ、複数の添付ファイルがある場合は、数字だけをしたい場合On Error Resume Next全体のサブbtwにここで

Answer 2

あなたは

Function UniqueName(FilePath As String) As String 

    Dim FSO As Object 
    Set FSO = CreateObject("Scripting.FilesystemObject") 

    Dim FileName As String 
     FileName = FilePath 

    Dim Ext As String 
     Ext = Chr(46) & FSO.GetExtensionName(FilePath) 

    Dim i As Long 
     i = 1 

    Do While FSO.FileExists(FileName) 
     FileName = Left(FilePath, Len(FilePath) - Len(Ext)) & " (" & i & ")" & Ext 
     i = i + 1 
    Loop 

    UniqueName = FileName 

End Function 

必要まさにんし、strFile = UniqueName(strFolderpath & strFileName)