จะบันทึกไฟล์แนบทั้งหมดจากอีเมลหลายฉบับไปยังโฟลเดอร์ใน Outlook ได้อย่างไร
ง่ายต่อการบันทึกไฟล์แนบทั้งหมดจากอีเมลด้วยฟีเจอร์บันทึกไฟล์แนบทั้งหมดใน Outlook อย่างไรก็ตามหากคุณต้องการบันทึกไฟล์แนบทั้งหมดจากอีเมลหลายฉบับพร้อมกันไม่มีคุณสมบัติโดยตรงที่สามารถช่วยได้ คุณต้องใช้คุณสมบัติบันทึกไฟล์แนบทั้งหมดซ้ำ ๆ ในอีเมลแต่ละฉบับจนกว่าไฟล์แนบทั้งหมดจะถูกบันทึกจากอีเมลเหล่านั้น ซึ่งใช้เวลานาน ในบทความนี้เราแนะนำวิธีการสองวิธีเพื่อให้คุณบันทึกไฟล์แนบทั้งหมดจำนวนมากจากอีเมลหลายฉบับไปยังโฟลเดอร์เฉพาะใน Outlook ได้อย่างง่ายดาย
บันทึกไฟล์แนบทั้งหมดจากอีเมลหลายฉบับไปยังโฟลเดอร์ด้วยรหัส VBA
คลิกหลายครั้งเพื่อบันทึกไฟล์แนบทั้งหมดจากอีเมลหลายฉบับไปยังโฟลเดอร์ด้วยเครื่องมือที่น่าทึ่ง
บันทึกไฟล์แนบทั้งหมดจากอีเมลหลายฉบับไปยังโฟลเดอร์ด้วยรหัส VBA
ส่วนนี้แสดงรหัส VBA ในคำแนะนำทีละขั้นตอนเพื่อช่วยให้คุณบันทึกไฟล์แนบทั้งหมดจากอีเมลหลายฉบับไปยังโฟลเดอร์ที่ระบุพร้อมกันได้อย่างรวดเร็ว กรุณาดำเนินการดังนี้
1. ประการแรกคุณต้องสร้างโฟลเดอร์สำหรับบันทึกไฟล์แนบในคอมพิวเตอร์ของคุณ
เข้าสู่ เอกสาร โฟลเดอร์และสร้างโฟลเดอร์ชื่อ “ ไฟล์แนบ” ดูภาพหน้าจอ:
2. เลือกอีเมลที่คุณจะบันทึกไฟล์แนบจากนั้นกด อื่น ๆ + F11 คีย์เพื่อเปิด Microsoft Visual Basic สำหรับแอปพลิเคชัน หน้าต่าง
3 คลิก สิ่งที่ใส่เข้าไป > โมดูล เพื่อเปิด โมดูล จากนั้นคัดลอกรหัส VBA ต่อไปนี้ลงในหน้าต่าง
รหัส VBA 1: บันทึกไฟล์แนบจำนวนมากจากอีเมลหลายฉบับ (บันทึกไฟล์แนบชื่อเดียวกันโดยตรง)
เคล็ดลับ: รหัสนี้จะบันทึกไฟล์แนบชื่อเดียวกันโดยเพิ่มตัวเลข 1, 2, 3 ... หลังชื่อไฟล์
Dim GCount As Integer
Dim GFilepath As String
Public Sub SaveAttachments()
'Update 20200821
Dim xMailItem As Outlook.MailItem
Dim xAttachments As Outlook.Attachments
Dim xSelection As Outlook.Selection
Dim i As Long
Dim xAttCount As Long
Dim xFilePath As String, xFolderPath As String, xSaveFiles As String
On Error Resume Next
xFolderPath = CreateObject("WScript.Shell").SpecialFolders(16)
Set xSelection = Outlook.Application.ActiveExplorer.Selection
xFolderPath = xFolderPath & "\Attachments\"
If VBA.Dir(xFolderPath, vbDirectory) = vbNullString Then
VBA.MkDir xFolderPath
End If
GFilepath = ""
For Each xMailItem In xSelection
Set xAttachments = xMailItem.Attachments
xAttCount = xAttachments.Count
xSaveFiles = ""
If xAttCount > 0 Then
For i = xAttCount To 1 Step -1
GCount = 0
xFilePath = xFolderPath & xAttachments.Item(i).FileName
GFilepath = xFilePath
xFilePath = FileRename(xFilePath)
If IsEmbeddedAttachment(xAttachments.Item(i)) = False Then
xAttachments.Item(i).SaveAsFile xFilePath
If xMailItem.BodyFormat <> olFormatHTML Then
xSaveFiles = xSaveFiles & vbCrLf & "<Error! Hyperlink reference not valid.>"
Else
xSaveFiles = xSaveFiles & "<br>" & "<a href='file://" & xFilePath & "'>" & xFilePath & "</a>"
End If
End If
Next i
End If
Next
Set xAttachments = Nothing
Set xMailItem = Nothing
Set xSelection = Nothing
End Sub
Function FileRename(FilePath As String) As String
Dim xPath As String
Dim xFso As FileSystemObject
On Error Resume Next
Set xFso = CreateObject("Scripting.FileSystemObject")
xPath = FilePath
FileRename = xPath
If xFso.FileExists(xPath) Then
GCount = GCount + 1
xPath = xFso.GetParentFolderName(GFilepath) & "\" & xFso.GetBaseName(GFilepath) & " " & GCount & "." + xFso.GetExtensionName(GFilepath)
FileRename = FileRename(xPath)
End If
xFso = Nothing
End Function
Function IsEmbeddedAttachment(Attach As Attachment)
Dim xItem As MailItem
Dim xCid As String
Dim xID As String
Dim xHtml As String
On Error Resume Next
IsEmbeddedAttachment = False
Set xItem = Attach.Parent
If xItem.BodyFormat <> olFormatHTML Then Exit Function
xCid = ""
xCid = Attach.PropertyAccessor.GetProperty("http://schemas.microsoft.com/mapi/proptag/0x3712001F")
If xCid <> "" Then
xHtml = xItem.HTMLBody
xID = "cid:" & xCid
If InStr(xHtml, xID) > 0 Then
IsEmbeddedAttachment = True
End If
End If
End Function
รหัส VBA 2: บันทึกไฟล์แนบจำนวนมากจากอีเมลหลายฉบับ (ตรวจสอบรายการที่ซ้ำกัน)
Public Sub SaveAttachments()
'Update 20200821
Dim xMailItem As Outlook.MailItem
Dim xAttachments As Outlook.Attachments
Dim xSelection As Outlook.Selection
Dim i As Long
Dim xAttCount As Long
Dim xFilePath As String, xFolderPath As String, xSaveFiles As String
Dim xYesNo As Integer
Dim xFlag As Boolean
On Error Resume Next
xFolderPath = CreateObject("WScript.Shell").SpecialFolders(16)
Set xSelection = Outlook.Application.ActiveExplorer.Selection
xFolderPath = xFolderPath & "\Attachments\"
If VBA.Dir(xFolderPath, vbDirectory) = vbNullString Then
VBA.MkDir xFolderPath
End If
For Each xMailItem In xSelection
Set xAttachments = xMailItem.Attachments
xAttCount = xAttachments.Count
xSaveFiles = ""
If xAttCount > 0 Then
For i = xAttCount To 1 Step -1
xFilePath = xFolderPath & xAttachments.Item(i).FileName
xFlag = True
If VBA.Dir(xFilePath, 16) <> Empty Then
xYesNo = MsgBox("The file is exists, do you want to replace it", vbYesNo + vbInformation, "Kutools for Outlook")
If xYesNo = vbNo Then xFlag = False
End If
If xFlag = True Then
xAttachments.Item(i).SaveAsFile xFilePath
If xMailItem.BodyFormat <> olFormatHTML Then
xSaveFiles = xSaveFiles & vbCrLf & "<Error! Hyperlink reference not valid.>"
Else
xSaveFiles = xSaveFiles & "<br>" & "<a href='file://" & xFilePath & "'>" & xFilePath & "</a>"
End If
End If
Next i
End If
Next
Set xAttachments = Nothing
Set xMailItem = Nothing
Set xSelection = Nothing
End Sub