保存和重命名具有特定文件类型的附件，而不进行覆盖

Question

我只需要将.docx文件发送到指定的文件夹。

如果文件名存在，则可能不会覆盖该文件名。

请参阅下面的模板。

Public Sub saveAttachtoDisk(itm As Outlook.MailItem)
Dim objAtt As Outlook.Attachment
Dim saveFolder As String
saveFolder = "C:Path"
Dim dateFormat As String
dateFormat = Format(itm.ReceivedTime, "yyyy-mm-dd Hmm ")
For Each objAtt In itm.Attachments
If FileType = ".docx" Then
objAtt.SaveAsFile saveFolder & "" & dateFormat & objAtt.DisplayName
End If
Next
End Sub

Answer 1

尝试将IF语句替换为：

If Right(objAtt.Filename, 5) = ".docx" Then

FileType用于Access表的附件，但即使您可以使用它，也需要限定引用(即，告诉VBA您想要哪个对象的FileType)，如：

If objAtt.FileType = "docx" Then

有关带有Outlook附件的VBA的详细信息，请点击此处。

---

更新：

如果文件已存在，则添加数字。还删除了额外的"\"，这可能会导致保存位置出现意外结果。

Public Sub saveAttachtoDisk(itm As Outlook.MailItem)
Dim objAtt As Outlook.Attachment
Dim saveFolder As String, dateFormat As String, fName As String
saveFolder = "C:Path"
dateFormat = Format(itm.ReceivedTime, "yyyy-mm-dd Hmm ")
For Each objAtt In itm.Attachments
If objAtt.FileType = "docx" Then
fName = saveFolder & dateFormat & objAtt.DisplayName
If Dir(fName) <> "" Then 'file already exists
fName = fName & Int(Timer) 'add a number
End If
objAtt.SaveAsFile fName & ".docx"
End If
Next
End Sub

---

编辑#2：

将下面的代码粘贴到Outlook、Excel或Access中的模块中，并在常量中为"已处理"编号的文件指定文件夹和名称"前缀"(如果不存在，请手动创建目标文件夹。)然后，函数getNextFileName将返回以myFile0001.docx开头的"下一个可用名称"。。。使用该函数设置objAtt.SaveAsFile文件名，或者将文件另存为任意文件，然后立即使用子renameSequentially(_in_Filepath&name_)对其进行重命名(并可能重新定位)。

Option Explicit
Function getNextFileName() As String
'returns a string with the next available filename matching the criteria in the Constants below.
Const folder = "C:savepathhere"
Const filenameStart = "myFile"
Const filenameEnd = ".docx" 'this will become "C:savepathheremyFile0001.docx" etc
Dim r As String, fileNum As Long, maxFileNum As Long
Dim numStartPos As Integer, numStopPos As Integer, NextFileName As String
'start listing existing files
r = Dir(folder & filenameStart & "*" & filenameEnd)
If r = "" Then
maxFileNum = 0 'this will be the file #1
Else
Do While r <> ""
'existing file found. Get the number from it's name
numStartPos = Len(filenameStart) + 1
numStopPos = InStr(numStartPos, r, filenameEnd, vbTextCompare)
fileNum = Val(Mid(r, numStartPos, numStopPos - numStartPos))
If fileNum > maxFileNum Then maxFileNum = fileNum
'get next filename
r = Dir
Loop
End If
'get the new filename
NextFileName = folder & "" & filenameStart & Format(maxFileNum + 1, "0000") & filenameEnd
Debug.Print "Next unusued filename: " & NextFileName
'double-check that it's available
If Dir(NextFileName) <> "" Then
MsgBox "Error! Filename taken: " & NextFileName
Exit Function
End If
getNextFileName = NextFileName
End Function
Function renameSequentially(in_File As String)
'specify path+filename that should be renamed requentiallyto should be renamed sequentially
Dim newName As String
newName = getNextFileName
Name in_File As newName
If Dir(newName) <> "" Then
MsgBox in_File & vbLf & " was renamed to:" & vbLf & newName
Else
Call MsgBox("Something went wrong trying to rename" & vbLf & in_File & vbLf & " to " & vbLf & newName, vbExclamation, vbOKOnly)
End If
End Function
Sub test()
renameSequentially ("C:mysourcepathabcwxyz.docx") 'renames the file to myfile####.docx
End Sub