Ekleri görünümde bir klasöre kaydedin ve yeniden adlandırın

Question

Eklenti eklerini bir klasöre kaydetmeye çalışıyorum ve dosya adı zaten varolan dosyanın üzerine kaydetmemek için yeni bir dosyayı farklı bir adla kaydetmeye çalışıyorum .... belki de "v2" varsa, "v2" veya "v3" olsa bile.

Bu cevap geldi ama daha yeni dosya ı aşağıdaki kodu kullanmış

Save attachments to a folder and rename them

varolan dosyanın üzerine kaydedilir olduğunu bulma yaşıyorum;

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 için nispeten yeniyim, belki de çözüm var ama göremiyorum!

Answer 1

Aşağıdaki koduma bir bakın. Belirli bir Outlook klasöründeki (belirttiğiniz) tüm öğelerden geçer, her öğedeki her bir eki gider ve eki belirtilen bir dosya yoluna kaydeder. Ayrıca folderItems.item(i).Delete yer alacağını dışında ekleri kazıma sonra öğeleri silmek için

'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 

---

DÜZENLEME

, siz yukarıdaki aynı kodu kullanırsınız. Ayrıca, öğeleri taşıdığınız için, yinelemenizi bozmamak için for döngüsünde geriye doğru dönmeye başladım. Yazdım:

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 

Umarım bu yardımcı olur!