In mail outlook hàng loạt có file đính kèm (1 người xem)

  • Thread starter Thread starter HNT1
  • Ngày gửi Ngày gửi
Liên hệ QC

Người dùng đang xem chủ đề này

Đang trực tuyến: 1 (Thành viên: 0, Khách: 1)
H

HNT1

Thành viên mới
Tham gia
29/3/21
Bài viết
5
Được thích
0
Chào các bác.

Em cần in 250 mail outlook 2016 có file đính kèm (in cả nội dung mail và file đính kèm). Có bác nào biết cách in tự động hàng loạt không chỉ giúp em với ạ.

Em cảm ơn các bác.
 
Có nhiều cách viết code VBA trong trường hợp này, ở đây tôi xin trình bày một cách như sau (giả sử tệp đính kèm chỉ bao gồm phần mở rộng ".xls", ".xlsm", ".xlsb", ".xlsx", ".doc", ".docx", ".docm", ".pdf":
Chọn những thư cần in trong Outlook.
Mã: 
Option Explicit

#If VBA7 Then
    Private Declare PtrSafe Function DeleteFile Lib "kernel32" Alias "DeleteFileA" (ByVal lpFileName As String) As Long
    Private Declare PtrSafe Function ShellExecute Lib "shell32.dll" Alias "ShellExecuteA" (ByVal hwnd As LongPtr, ByVal lpOperation As String, ByVal lpFile As String, ByVal lpParameters As String, ByVal lpDirectory As String, ByVal nShowCmd As Long) As LongPtr
#Else
    Private Declare Function DeleteFile Lib "kernel32" Alias "DeleteFileA" (ByVal lpFileName As String) As Long
    Private Declare Function ShellExecute Lib "shell32.dll" Alias "ShellExecuteA" (ByVal hwnd As Long, ByVal lpOperation As String, ByVal lpFile As String, ByVal lpParameters As String, ByVal lpDirectory As String, ByVal nShowCmd As Long) As Long
#End If

Private Sub PrintEmailBodyAndAttachments()
    Dim objMail As Outlook.MailItem
    Dim objSel As Outlook.Selection
    Dim objAtt As Outlook.Attachment
    Dim i As LongPtr, j As LongPtr, lngNumAtt As LongPtr
    Dim strAttFilePath As String
    i = 1
    SetDefaultPrinter "Tên máy in"
    Set objSel = Application.ActiveExplorer.Selection
    For i = 1 To objSel.Count
        If TypeOf objSel.Item(i) Is Outlook.MailItem Then
            Set objMail = objSel.Item(i)
            With objMail
                .PrintOut
                If .Attachments.Count > 0 Then
                    For j = 1 To .Attachments.Count
                        Set objAtt = .Attachments.Item(j)
                        strAttFilePath = Environ$("TEMP") & "\" & objAtt.FileName
                        objAtt.SaveAsFile strAttFilePath
                        Select Case GetFileExtension(strAttFilePath)
                            Case ".xls", ".xlsm", ".xlsb", ".xlsx", ".doc", ".docx", ".docm", ".pdf"
                                ShellExecute 0, "print", strAttFilePath, vbNullString, vbNullString, 0
                        End Select
                        DeleteFile strAttFilePath
                    Next
                End If
            End With
        End If
    Next
    Set objMail = Nothing
    Set objSel = Nothing
    Set objAtt = Nothing
End Sub

Private Sub SetDefaultPrinter(PrinterName As String, Optional ComputerName As String = ".")
    Dim Printer As Object, Printers As Object, WMIService As Object
    Set WMIService = GetObject("winmgmts:{impersonationLevel=impersonate}!\\" & ComputerName & "\root\cimv2")
    Set Printers = WMIService.ExecQuery("Select * from Win32_Printer Where Name = '" & PrinterName & "'")
    For Each Printer In Printers
        Printer.SetDefaultPrinter
    Next
    Set Printer = Nothing
    Set Printers = Nothing
    Set WMIService = Nothing
End Sub

Private Function GetFileExtension(FileName As String) As String
    On Error Resume Next
    GetFileExtension = Mid(FileName, InStrRev(FileName, "."))
    If Err.Number = 5 Then
        GetFileExtension = vbNullString
    End If
End Function
 
bạn giải giùm mình bài này với. Dùng hàm gì để đếm số hành khách ở cột nơi đến ra cột số hành khách/chuyến. Như dòng đầu có 4 hành khách. Ngăn cách giữa các hành khách là dấu +
 

File đính kèm

  • C638DB59-CC1F-42B0-AA00-E09B0DD6E307.png
    C638DB59-CC1F-42B0-AA00-E09B0DD6E307.png
    202.7 KB · Đọc: 7
nguyendang95 đã viết:
Có nhiều cách viết code VBA trong trường hợp này, ở đây tôi xin trình bày một cách như sau (giả sử tệp đính kèm chỉ bao gồm phần mở rộng ".xls", ".xlsm", ".xlsb", ".xlsx", ".doc", ".docx", ".docm", ".pdf":
Chọn những thư cần in trong Outlook.
Mã: 
Option Explicit

#If VBA7 Then
    Private Declare PtrSafe Function DeleteFile Lib "kernel32" Alias "DeleteFileA" (ByVal lpFileName As String) As Long
    Private Declare PtrSafe Function ShellExecute Lib "shell32.dll" Alias "ShellExecuteA" (ByVal hwnd As LongPtr, ByVal lpOperation As String, ByVal lpFile As String, ByVal lpParameters As String, ByVal lpDirectory As String, ByVal nShowCmd As Long) As LongPtr
#Else
    Private Declare Function DeleteFile Lib "kernel32" Alias "DeleteFileA" (ByVal lpFileName As String) As Long
    Private Declare Function ShellExecute Lib "shell32.dll" Alias "ShellExecuteA" (ByVal hwnd As Long, ByVal lpOperation As String, ByVal lpFile As String, ByVal lpParameters As String, ByVal lpDirectory As String, ByVal nShowCmd As Long) As Long
#End If

Private Sub PrintEmailBodyAndAttachments()
    Dim objMail As Outlook.MailItem
    Dim objSel As Outlook.Selection
    Dim objAtt As Outlook.Attachment
    Dim i As LongPtr, j As LongPtr, lngNumAtt As LongPtr
    Dim strAttFilePath As String
    i = 1
    SetDefaultPrinter "Tên máy in"
    Set objSel = Application.ActiveExplorer.Selection
    For i = 1 To objSel.Count
        If TypeOf objSel.Item(i) Is Outlook.MailItem Then
            Set objMail = objSel.Item(i)
            With objMail
                .PrintOut
                If .Attachments.Count > 0 Then
                    For j = 1 To .Attachments.Count
                        Set objAtt = .Attachments.Item(j)
                        strAttFilePath = Environ$("TEMP") & "\" & objAtt.FileName
                        objAtt.SaveAsFile strAttFilePath
                        Select Case GetFileExtension(strAttFilePath)
                            Case ".xls", ".xlsm", ".xlsb", ".xlsx", ".doc", ".docx", ".docm", ".pdf"
                                ShellExecute 0, "print", strAttFilePath, vbNullString, vbNullString, 0
                        End Select
                        DeleteFile strAttFilePath
                    Next
                End If
            End With
        End If
    Next
    Set objMail = Nothing
    Set objSel = Nothing
    Set objAtt = Nothing
End Sub

Private Sub SetDefaultPrinter(PrinterName As String, Optional ComputerName As String = ".")
    Dim Printer As Object, Printers As Object, WMIService As Object
    Set WMIService = GetObject("winmgmts:{impersonationLevel=impersonate}!\\" & ComputerName & "\root\cimv2")
    Set Printers = WMIService.ExecQuery("Select * from Win32_Printer Where Name = '" & PrinterName & "'")
    For Each Printer In Printers
        Printer.SetDefaultPrinter
    Next
    Set Printer = Nothing
    Set Printers = Nothing
    Set WMIService = Nothing
End Sub

Private Function GetFileExtension(FileName As String) As String
    On Error Resume Next
    GetFileExtension = Mid(FileName, InStrRev(FileName, "."))
    If Err.Number = 5 Then
        GetFileExtension = vbNullString
    End If
End Function
Nhấp chuột vào đây để mở rộng...

Có cách nào lấy toàn bộ file đính kèm từ 1 địa chỉ mail gửi đến không bạn.
Nếu được nhờ bạn hướng dẫn giúp.
 
DLH96 đã viết:
Có cách nào lấy toàn bộ file đính kèm từ 1 địa chỉ mail gửi đến không bạn.
Nếu được nhờ bạn hướng dẫn giúp.
Nhấp chuột vào đây để mở rộng...
Đặt code dưới đây vào Module trong trình soạn thảo VBE của Outlook (nhớ kích hoạt tab Developer):
Lưu ý: Macro này sẽ tìm kiếm các email trong thư mục Inbox mặc định trong Outlook.
Mã: 
Option Explicit

Public Sub DownloadAttachments(SenderEmailAddress As String)
    Dim objMail As Outlook.MailItem
    Dim objAtt As Outlook.Attachment
    Dim objFSO As Object
    Dim strRCDatePath As String, strFolderPath As String, strSenderPath As String
    Dim i As Long, j As Long
    Dim strFilter As String, strSenderEmailAddress As String
    Dim colItems As Outlook.Items
    Dim objInbox As Outlook.Folder
    Set objFSO = CreateObject("Scripting.FileSystemObject")
    strFolderPath = Environ$("USERPROFILE") & "\Documents\OutlookAttachments\" 'Thu muc luu tap tin dinh kem, mac dinh: C:\<nguoidung>
    If Not objFSO.FolderExists(strFolderPath) Then objFSO.CreateFolder strFolderPath
    Const PR_SENDER_EMAIL_ADDRESS As String = "http://schemas.microsoft.com/mapi/proptag/0x0C1F001F"
    Const PR_HASATTACH As String = "http://schemas.microsoft.com/mapi/proptag/0x0E1B000B"
    strSenderEmailAddress = SenderEmailAddress 'Dia chi email nguoi gui
    strFilter = "@SQL=" & Quote(PR_SENDER_EMAIL_ADDRESS) & " = '" & strSenderEmailAddress & "' AND " & Quote(PR_HASATTACH) & "=1"
    Set objInbox = Application.Session.GetDefaultFolder(olFolderInbox)
    Set colItems = objInbox.Items.Restrict(strFilter)
    For j = 1 To colItems.Count
        Set objMail = colItems.Item(j)
        With objMail
            If Not objFSO.FolderExists(strFolderPath & GetDateFromReceivedTime(.ReceivedTime)) Then
                strRCDatePath = strFolderPath & GetDateFromReceivedTime(.ReceivedTime)
                objFSO.CreateFolder strRCDatePath
            Else: strRCDatePath = strFolderPath & GetDateFromReceivedTime(.ReceivedTime)
            End If
            If Not objFSO.FolderExists(strFolderPath & GetDateFromReceivedTime(.ReceivedTime) & "\" & .SenderName) Then
                strSenderPath = strFolderPath & GetDateFromReceivedTime(.ReceivedTime) & "\" & .SenderName
                objFSO.CreateFolder strSenderPath
            Else: strSenderPath = strFolderPath & GetDateFromReceivedTime(.ReceivedTime) & "\" & .SenderName
            End If
            For i = 1 To .Attachments.Count
                Set objAtt = .Attachments.Item(i)
                If objFSO.FileExists(strSenderPath & "\" & objAtt.filename) Then
                    objFSO.DeleteFile strSenderPath & "\" & objAtt.filename
                End If
                objAtt.SaveAsFile strSenderPath & "\" & objAtt.filename
            Next i
        End With
    Next
    Shell "explorer """ & strFolderPath & "", vbNormalFocus
End Sub

Private Function Quote(Text As String) As String
    Quote = Chr(34) & Text & Chr(34)
End Function

Private Function GetDateFromReceivedTime(ReceivedDateString As String) As String
    Dim RDString As String
    RDString = Trim(Format(Left(ReceivedDateString, InStr(ReceivedDateString, " ")), "dd-mm-yyyy"))
    GetDateFromReceivedTime = RDString
End Function

Khi chạy thủ tục, thay tham số SenderEmailAddress thành địa chỉ email thích hợp, ví dụ:
Mã: 
Private Sub Test()
    Call DownloadAttachments("abc@gmail.com")
End Sub
 
Lần chỉnh sửa cuối:
nguyendang95 đã viết:
Đặt code dưới đây vào Module trong trình soạn thảo VBE của Outlook (nhớ kích hoạt tab Developer):
Lưu ý: Macro này sẽ tìm kiếm các email trong thư mục Inbox mặc định trong Outlook.
Mã: 
Option Explicit

Public Sub DownloadAttachments(SenderEmailAddress As String)
    Dim objMail As Outlook.MailItem
    Dim objAtt As Outlook.Attachment
    Dim objFSO As Object
    Dim strRCDatePath As String, strFolderPath As String, strSenderPath As String
    Dim i As Long, j As Long
    Dim strFilter As String, strSenderEmailAddress As String
    Dim colItems As Outlook.Items
    Dim objInbox As Outlook.Folder
    Set objFSO = CreateObject("Scripting.FileSystemObject")
    strFolderPath = Environ$("USERPROFILE") & "\Documents\OutlookAttachments\" 'Thu muc luu tap tin dinh kem, mac dinh: C:\<nguoidung>
    If Not objFSO.FolderExists(strFolderPath) Then objFSO.CreateFolder strFolderPath
    Const PR_SENDER_EMAIL_ADDRESS As String = "http://schemas.microsoft.com/mapi/proptag/0x0C1F001F"
    Const PR_HASATTACH As String = "http://schemas.microsoft.com/mapi/proptag/0x0E1B000B"
    strSenderEmailAddress = SenderEmailAddress 'Dia chi email nguoi gui
    strFilter = "@SQL=" & Quote(PR_SENDER_EMAIL_ADDRESS) & " = '" & strSenderEmailAddress & "' AND " & Quote(PR_HASATTACH) & "=1"
    Set objInbox = Application.Session.GetDefaultFolder(olFolderInbox)
    Set colItems = objInbox.Items.Restrict(strFilter)
    For j = 1 To colItems.Count
        Set objMail = colItems.Item(j)
        With objMail
            If Not objFSO.FolderExists(strFolderPath & GetDateFromReceivedTime(.ReceivedTime)) Then
                strRCDatePath = strFolderPath & GetDateFromReceivedTime(.ReceivedTime)
                objFSO.CreateFolder strRCDatePath
            Else: strRCDatePath = strFolderPath & GetDateFromReceivedTime(.ReceivedTime)
            End If
            If Not objFSO.FolderExists(strFolderPath & GetDateFromReceivedTime(.ReceivedTime) & "\" & .SenderName) Then
                strSenderPath = strFolderPath & GetDateFromReceivedTime(.ReceivedTime) & "\" & .SenderName
                objFSO.CreateFolder strSenderPath
            Else: strSenderPath = strFolderPath & GetDateFromReceivedTime(.ReceivedTime) & "\" & .SenderName
            End If
            For i = 1 To .Attachments.Count
                Set objAtt = .Attachments.Item(i)
                If objFSO.FileExists(strSenderPath & "\" & objAtt.filename) Then
                    objFSO.DeleteFile strSenderPath & "\" & objAtt.filename
                End If
                objAtt.SaveAsFile strSenderPath & "\" & objAtt.filename
            Next i
        End With
    Next
    Shell "explorer """ & strFolderPath & "", vbNormalFocus
End Sub

Private Function Quote(Text As String) As String
    Quote = Chr(34) & Text & Chr(34)
End Function

Private Function GetDateFromReceivedTime(ReceivedDateString As String) As String
    Dim RDString As String
    RDString = Trim(Format(Left(ReceivedDateString, InStr(ReceivedDateString, " ")), "dd-mm-yyyy"))
    GetDateFromReceivedTime = RDString
End Function

Khi chạy thủ tục, thay tham số SenderEmailAddress thành địa chỉ email thích hợp, ví dụ:
Mã: 
Private Sub Test()
    Call DownloadAttachments("abc@gmail.com")
End Sub
Nhấp chuột vào đây để mở rộng...
Thật tuyệt vời, những dòng code của anh chạy cực nhanh và chính xác.
Nhờ anh chỉ giúp em nếu muốn thay đổi thư mục mặc định tìm kiếm là Inbox sang 1 thư mục cá nhân khác, và giới hạn thời gian tìm kiếm thì phải sửa code như thế nào ạ.
 
tieutuvodanh192 đã viết:
Thật tuyệt vời, những dòng code của anh chạy cực nhanh và chính xác.
Nhờ anh chỉ giúp em nếu muốn thay đổi thư mục mặc định tìm kiếm là Inbox sang 1 thư mục cá nhân khác, và giới hạn thời gian tìm kiếm thì phải sửa code như thế nào ạ.
Nhấp chuột vào đây để mở rộng...
Sửa lại một chút macro ở trên.
Code dưới đây hiển thị hộp thoại chọn thư mục email để tìm kiếm:
Mã: 
Option Explicit

Public Sub DownloadAttachments(SenderEmailAddress As String, StartDate As Date, EndDate As Date)
    Dim objMail As Outlook.MailItem
    Dim objAtt As Outlook.Attachment
    Dim objPA As Outlook.PropertyAccessor
    Dim objFSO As Object
    Dim strRCDatePath As String, strFolderPath As String, strSenderPath As String
    Dim dteStartDate As Date, dteEndDate As Date, dteStartDateUTC As Date, dteEndDateUTC As Date
    Dim i As Long, j As Long
    Dim strFilter As String, strSenderEmailAddress As String
    Dim colItems As Outlook.Items
    Dim objFolder As Outlook.Folder
    Const PR_SENDER_EMAIL_ADDRESS As String = "http://schemas.microsoft.com/mapi/proptag/0x0C1F001F"
    Const PR_HASATTACH As String = "http://schemas.microsoft.com/mapi/proptag/0x0E1B000B"
    dteStartDate = StartDate 'Ngay bat dau, vd: #1/1#2021#
    dteEndDate = EndDate 'Ngay ket thuc, vd: #1/1/2022#
    Set objMail = Application.CreateItem(olMailItem)
    With objMail
        Set objPA = .PropertyAccessor
        dteStartDateUTC = objPA.LocalTimeToUTC(dteStartDate)
        dteEndDateUTC = objPA.LocalTimeToUTC(dteEndDate)
        .Close olDiscard
    End With
    strSenderEmailAddress = SenderEmailAddress 'Dia chi email nguoi gui
    strFilter = "@SQL=" & Quote(PR_SENDER_EMAIL_ADDRESS) & " = '" & strSenderEmailAddress & "' AND " & Quote(PR_HASATTACH) & "=1 AND " & _
                Quote("urn:schemas:httpmail:datereceived") & " > " & Chr(39) & dteStartDateUTC & Chr(39) & " And " & Quote("urn:schemas:httpmail:datereceived") & " < " & Chr(39) & dteEndDateUTC & Chr(39)
    strFolderPath = Environ$("USERPROFILE") & "\Documents\OutlookAttachments\" 'Thu muc luu tap tin dinh kem, mac dinh: C:\<nguoidung>
    Set objFSO = CreateObject("Scripting.FileSystemObject")
    If Not objFSO.FolderExists(strFolderPath) Then objFSO.CreateFolder strFolderPath
    On Error Resume Next
    Set objFolder = Application.Session.PickFolder
    If Not objFolder Is Nothing Then
        Set colItems = objFolder.Items.Restrict(strFilter)
        For j = 1 To colItems.Count
            Set objMail = colItems.Item(j)
            With objMail
                If Not objFSO.FolderExists(strFolderPath & GetDateFromReceivedTime(.ReceivedTime)) Then
                    strRCDatePath = strFolderPath & GetDateFromReceivedTime(.ReceivedTime)
                    objFSO.CreateFolder strRCDatePath
                Else: strRCDatePath = strFolderPath & GetDateFromReceivedTime(.ReceivedTime)
                End If
                If Not objFSO.FolderExists(strFolderPath & GetDateFromReceivedTime(.ReceivedTime) & "\" & .SenderName) Then
                    strSenderPath = strFolderPath & GetDateFromReceivedTime(.ReceivedTime) & "\" & .SenderName
                    objFSO.CreateFolder strSenderPath
                Else: strSenderPath = strFolderPath & GetDateFromReceivedTime(.ReceivedTime) & "\" & .SenderName
                End If
                For i = 1 To .Attachments.Count
                    Set objAtt = .Attachments.Item(i)
                    If objFSO.FileExists(strSenderPath & "\" & objAtt.DisplayName) Then
                        objFSO.DeleteFile strSenderPath & "\" & objAtt.DisplayName
                    End If
                    objAtt.SaveAsFile strSenderPath & "\" & objAtt.DisplayName
                Next i
            End With
        Next
        Shell "explorer """ & strFolderPath & "", vbNormalFocus
    End If
End Sub

Private Function Quote(Text As String) As String
    Quote = Chr(34) & Text & Chr(34)
End Function

Private Function GetDateFromReceivedTime(ReceivedDateString As String) As String
    Dim RDString As String
    RDString = Trim(Format(Left(ReceivedDateString, InStr(ReceivedDateString, " ")), "dd-mm-yyyy"))
    GetDateFromReceivedTime = RDString
End Function

Sử dụng macro để tìm kiếm và tải xuống tập tin đính kèm từ SenderEmailAddress, trong khoảng thời gian từ ngày StartDate đến ngày EndDate:

Mã: 
Private Sub Test()
    Call DownloadAttachments("abc@gmail.com", #1/1/2021#, #1/1/2022#)
End Sub
 
Lần chỉnh sửa cuối:
nguyendang95 đã viết:
Sửa lại một chút macro ở trên.
Code dưới đây hiển thị hộp thoại chọn thư mục email để tìm kiếm:
Mã: 
Option Explicit

Public Sub DownloadAttachments(SenderEmailAddress As String, StartDate As Date, EndDate As Date)
    Dim objMail As Outlook.MailItem
    Dim objAtt As Outlook.Attachment
    Dim objPA As Outlook.PropertyAccessor
    Dim objFSO As Object
    Dim strRCDatePath As String, strFolderPath As String, strSenderPath As String
    Dim dteStartDate As Date, dteEndDate As Date, dteStartDateUTC As Date, dteEndDateUTC As Date
    Dim i As Long, j As Long
    Dim strFilter As String, strSenderEmailAddress As String
    Dim colItems As Outlook.Items
    Dim objFolder As Outlook.Folder
    Const PR_SENDER_EMAIL_ADDRESS As String = "http://schemas.microsoft.com/mapi/proptag/0x0C1F001F"
    Const PR_HASATTACH As String = "http://schemas.microsoft.com/mapi/proptag/0x0E1B000B"
    dteStartDate = StartDate 'Ngay bat dau, vd: #1/1#2021#
    dteEndDate = EndDate 'Ngay ket thuc, vd: #1/1/2022#
    Set objMail = Application.CreateItem(olMailItem)
    With objMail
        Set objPA = .PropertyAccessor
        dteStartDateUTC = objPA.LocalTimeToUTC(dteStartDate)
        dteEndDateUTC = objPA.LocalTimeToUTC(dteEndDate)
        .Close olDiscard
    End With
    strSenderEmailAddress = SenderEmailAddress 'Dia chi email nguoi gui
    strFilter = "@SQL=" & Quote(PR_SENDER_EMAIL_ADDRESS) & " = '" & strSenderEmailAddress & "' AND " & Quote(PR_HASATTACH) & "=1 AND " & _
                Quote("urn:schemas:httpmail:datereceived") & " > " & Chr(39) & dteStartDateUTC & Chr(39) & " And " & Quote("urn:schemas:httpmail:datereceived") & " < " & Chr(39) & dteEndDateUTC & Chr(39)
    strFolderPath = Environ$("USERPROFILE") & "\Documents\OutlookAttachments\" 'Thu muc luu tap tin dinh kem, mac dinh: C:\<nguoidung>
    Set objFSO = CreateObject("Scripting.FileSystemObject")
    If Not objFSO.FolderExists(strFolderPath) Then objFSO.CreateFolder strFolderPath
    On Error Resume Next
    Set objFolder = Application.Session.PickFolder
    If Not objFolder Is Nothing Then
        Set colItems = objFolder.Items.Restrict(strFilter)
        For j = 1 To colItems.Count
            Set objMail = colItems.Item(j)
            With objMail
                If Not objFSO.FolderExists(strFolderPath & GetDateFromReceivedTime(.ReceivedTime)) Then
                    strRCDatePath = strFolderPath & GetDateFromReceivedTime(.ReceivedTime)
                    objFSO.CreateFolder strRCDatePath
                Else: strRCDatePath = strFolderPath & GetDateFromReceivedTime(.ReceivedTime)
                End If
                If Not objFSO.FolderExists(strFolderPath & GetDateFromReceivedTime(.ReceivedTime) & "\" & .SenderName) Then
                    strSenderPath = strFolderPath & GetDateFromReceivedTime(.ReceivedTime) & "\" & .SenderName
                    objFSO.CreateFolder strSenderPath
                Else: strSenderPath = strFolderPath & GetDateFromReceivedTime(.ReceivedTime) & "\" & .SenderName
                End If
                For i = 1 To .Attachments.Count
                    Set objAtt = .Attachments.Item(i)
                    If objFSO.FileExists(strSenderPath & "\" & objAtt.DisplayName) Then
                        objFSO.DeleteFile strSenderPath & "\" & objAtt.DisplayName
                    End If
                    objAtt.SaveAsFile strSenderPath & "\" & objAtt.DisplayName
                Next i
            End With
        Next
        Shell "explorer """ & strFolderPath & "", vbNormalFocus
    End If
End Sub

Private Function Quote(Text As String) As String
    Quote = Chr(34) & Text & Chr(34)
End Function

Private Function GetDateFromReceivedTime(ReceivedDateString As String) As String
    Dim RDString As String
    RDString = Trim(Format(Left(ReceivedDateString, InStr(ReceivedDateString, " ")), "dd-mm-yyyy"))
    GetDateFromReceivedTime = RDString
End Function

Sử dụng macro để tìm kiếm và tải xuống tập tin đính kèm từ SenderEmailAddress, trong khoảng thời gian từ ngày StartDate đến ngày EndDate:

Mã: 
Private Sub Test()
    Call DownloadAttachments("abc@gmail.com", #1/1/2021#, #1/1/2022#)
End Sub
Nhấp chuột vào đây để mở rộng...
Cảm ơn anh rất nhiều, code chạy rất chính xác ạ. :D
 
nguyendang95 đã viết:
Sửa lại một chút macro ở trên.
Code dưới đây hiển thị hộp thoại chọn thư mục email để tìm kiếm:
Mã: 
Option Explicit

Public Sub DownloadAttachments(SenderEmailAddress As String, StartDate As Date, EndDate As Date)
    Dim objMail As Outlook.MailItem
    Dim objAtt As Outlook.Attachment
    Dim objPA As Outlook.PropertyAccessor
    Dim objFSO As Object
    Dim strRCDatePath As String, strFolderPath As String, strSenderPath As String
    Dim dteStartDate As Date, dteEndDate As Date, dteStartDateUTC As Date, dteEndDateUTC As Date
    Dim i As Long, j As Long
    Dim strFilter As String, strSenderEmailAddress As String
    Dim colItems As Outlook.Items
    Dim objFolder As Outlook.Folder
    Const PR_SENDER_EMAIL_ADDRESS As String = "http://schemas.microsoft.com/mapi/proptag/0x0C1F001F"
    Const PR_HASATTACH As String = "http://schemas.microsoft.com/mapi/proptag/0x0E1B000B"
    dteStartDate = StartDate 'Ngay bat dau, vd: #1/1#2021#
    dteEndDate = EndDate 'Ngay ket thuc, vd: #1/1/2022#
    Set objMail = Application.CreateItem(olMailItem)
    With objMail
        Set objPA = .PropertyAccessor
        dteStartDateUTC = objPA.LocalTimeToUTC(dteStartDate)
        dteEndDateUTC = objPA.LocalTimeToUTC(dteEndDate)
        .Close olDiscard
    End With
    strSenderEmailAddress = SenderEmailAddress 'Dia chi email nguoi gui
    strFilter = "@SQL=" & Quote(PR_SENDER_EMAIL_ADDRESS) & " = '" & strSenderEmailAddress & "' AND " & Quote(PR_HASATTACH) & "=1 AND " & _
                Quote("urn:schemas:httpmail:datereceived") & " > " & Chr(39) & dteStartDateUTC & Chr(39) & " And " & Quote("urn:schemas:httpmail:datereceived") & " < " & Chr(39) & dteEndDateUTC & Chr(39)
    strFolderPath = Environ$("USERPROFILE") & "\Documents\OutlookAttachments\" 'Thu muc luu tap tin dinh kem, mac dinh: C:\<nguoidung>
    Set objFSO = CreateObject("Scripting.FileSystemObject")
    If Not objFSO.FolderExists(strFolderPath) Then objFSO.CreateFolder strFolderPath
    On Error Resume Next
    Set objFolder = Application.Session.PickFolder
    If Not objFolder Is Nothing Then
        Set colItems = objFolder.Items.Restrict(strFilter)
        For j = 1 To colItems.Count
            Set objMail = colItems.Item(j)
            With objMail
                If Not objFSO.FolderExists(strFolderPath & GetDateFromReceivedTime(.ReceivedTime)) Then
                    strRCDatePath = strFolderPath & GetDateFromReceivedTime(.ReceivedTime)
                    objFSO.CreateFolder strRCDatePath
                Else: strRCDatePath = strFolderPath & GetDateFromReceivedTime(.ReceivedTime)
                End If
                If Not objFSO.FolderExists(strFolderPath & GetDateFromReceivedTime(.ReceivedTime) & "\" & .SenderName) Then
                    strSenderPath = strFolderPath & GetDateFromReceivedTime(.ReceivedTime) & "\" & .SenderName
                    objFSO.CreateFolder strSenderPath
                Else: strSenderPath = strFolderPath & GetDateFromReceivedTime(.ReceivedTime) & "\" & .SenderName
                End If
                For i = 1 To .Attachments.Count
                    Set objAtt = .Attachments.Item(i)
                    If objFSO.FileExists(strSenderPath & "\" & objAtt.DisplayName) Then
                        objFSO.DeleteFile strSenderPath & "\" & objAtt.DisplayName
                    End If
                    objAtt.SaveAsFile strSenderPath & "\" & objAtt.DisplayName
                Next i
            End With
        Next
        Shell "explorer """ & strFolderPath & "", vbNormalFocus
    End If
End Sub

Private Function Quote(Text As String) As String
    Quote = Chr(34) & Text & Chr(34)
End Function

Private Function GetDateFromReceivedTime(ReceivedDateString As String) As String
    Dim RDString As String
    RDString = Trim(Format(Left(ReceivedDateString, InStr(ReceivedDateString, " ")), "dd-mm-yyyy"))
    GetDateFromReceivedTime = RDString
End Function

Sử dụng macro để tìm kiếm và tải xuống tập tin đính kèm từ SenderEmailAddress, trong khoảng thời gian từ ngày StartDate đến ngày EndDate:

Mã: 
Private Sub Test()
    Call DownloadAttachments("abc@gmail.com", #1/1/2021#, #1/1/2022#)
End Sub
Nhấp chuột vào đây để mở rộng...
Cho mình hỏi chút.
Khi mình chạy code thì chỉ tạo ra foder ngày có mail đến thôi. Còn file đính kèm thì không có.
Mình chỉ coppy dán code và thay đổi địa chỉ mail. Không rõ là có cần chỉnh sửa gì nữa không.
Nhờ bạn chỉ giúp.

1669717958419.png
 
DLH96 đã viết:
Cho mình hỏi chút.
Khi mình chạy code thì chỉ tạo ra foder ngày có mail đến thôi. Còn file đính kèm thì không có.
Mình chỉ coppy dán code và thay đổi địa chỉ mail. Không rõ là có cần chỉnh sửa gì nữa không.
Nhờ bạn chỉ giúp.

View attachment 284038
Nhấp chuột vào đây để mở rộng...
Lạ nhỉ, thông thường những thư mục đó chỉ được tạo khi tìm được những email thỏa mãn tiêu chí tìm kiếm. Bạn thử chạy lại xem sao nhé.
 
nguyendang95 đã viết:
Sửa lại một chút macro ở trên.
Code dưới đây hiển thị hộp thoại chọn thư mục email để tìm kiếm:
Mã: 
Option Explicit

Public Sub DownloadAttachments(SenderEmailAddress As String, StartDate As Date, EndDate As Date)
    Dim objMail As Outlook.MailItem
    Dim objAtt As Outlook.Attachment
    Dim objPA As Outlook.PropertyAccessor
    Dim objFSO As Object
    Dim strRCDatePath As String, strFolderPath As String, strSenderPath As String
    Dim dteStartDate As Date, dteEndDate As Date, dteStartDateUTC As Date, dteEndDateUTC As Date
    Dim i As Long, j As Long
    Dim strFilter As String, strSenderEmailAddress As String
    Dim colItems As Outlook.Items
    Dim objFolder As Outlook.Folder
    Const PR_SENDER_EMAIL_ADDRESS As String = "http://schemas.microsoft.com/mapi/proptag/0x0C1F001F"
    Const PR_HASATTACH As String = "http://schemas.microsoft.com/mapi/proptag/0x0E1B000B"
    dteStartDate = StartDate 'Ngay bat dau, vd: #1/1#2021#
    dteEndDate = EndDate 'Ngay ket thuc, vd: #1/1/2022#
    Set objMail = Application.CreateItem(olMailItem)
    With objMail
        Set objPA = .PropertyAccessor
        dteStartDateUTC = objPA.LocalTimeToUTC(dteStartDate)
        dteEndDateUTC = objPA.LocalTimeToUTC(dteEndDate)
        .Close olDiscard
    End With
    strSenderEmailAddress = SenderEmailAddress 'Dia chi email nguoi gui
    strFilter = "@SQL=" & Quote(PR_SENDER_EMAIL_ADDRESS) & " = '" & strSenderEmailAddress & "' AND " & Quote(PR_HASATTACH) & "=1 AND " & _
                Quote("urn:schemas:httpmail:datereceived") & " > " & Chr(39) & dteStartDateUTC & Chr(39) & " And " & Quote("urn:schemas:httpmail:datereceived") & " < " & Chr(39) & dteEndDateUTC & Chr(39)
    strFolderPath = Environ$("USERPROFILE") & "\Documents\OutlookAttachments\" 'Thu muc luu tap tin dinh kem, mac dinh: C:\<nguoidung>
    Set objFSO = CreateObject("Scripting.FileSystemObject")
    If Not objFSO.FolderExists(strFolderPath) Then objFSO.CreateFolder strFolderPath
    On Error Resume Next
    Set objFolder = Application.Session.PickFolder
    If Not objFolder Is Nothing Then
        Set colItems = objFolder.Items.Restrict(strFilter)
        For j = 1 To colItems.Count
            Set objMail = colItems.Item(j)
            With objMail
                If Not objFSO.FolderExists(strFolderPath & GetDateFromReceivedTime(.ReceivedTime)) Then
                    strRCDatePath = strFolderPath & GetDateFromReceivedTime(.ReceivedTime)
                    objFSO.CreateFolder strRCDatePath
                Else: strRCDatePath = strFolderPath & GetDateFromReceivedTime(.ReceivedTime)
                End If
                If Not objFSO.FolderExists(strFolderPath & GetDateFromReceivedTime(.ReceivedTime) & "\" & .SenderName) Then
                    strSenderPath = strFolderPath & GetDateFromReceivedTime(.ReceivedTime) & "\" & .SenderName
                    objFSO.CreateFolder strSenderPath
                Else: strSenderPath = strFolderPath & GetDateFromReceivedTime(.ReceivedTime) & "\" & .SenderName
                End If
                For i = 1 To .Attachments.Count
                    Set objAtt = .Attachments.Item(i)
                    If objFSO.FileExists(strSenderPath & "\" & objAtt.DisplayName) Then
                        objFSO.DeleteFile strSenderPath & "\" & objAtt.DisplayName
                    End If
                    objAtt.SaveAsFile strSenderPath & "\" & objAtt.DisplayName
                Next i
            End With
        Next
        Shell "explorer """ & strFolderPath & "", vbNormalFocus
    End If
End Sub

Private Function Quote(Text As String) As String
    Quote = Chr(34) & Text & Chr(34)
End Function

Private Function GetDateFromReceivedTime(ReceivedDateString As String) As String
    Dim RDString As String
    RDString = Trim(Format(Left(ReceivedDateString, InStr(ReceivedDateString, " ")), "dd-mm-yyyy"))
    GetDateFromReceivedTime = RDString
End Function

Sử dụng macro để tìm kiếm và tải xuống tập tin đính kèm từ SenderEmailAddress, trong khoảng thời gian từ ngày StartDate đến ngày EndDate:

Mã: 
Private Sub Test()
    Call DownloadAttachments("abc@gmail.com", #1/1/2021#, #1/1/2022#)
End Sub
Nhấp chuột vào đây để mở rộng...
Em chào Anh,
Giống như code này nếu chỉ muốn lấy những file đính kèm dạng excel và pdf (Hoặc tìm và lọc theo dạng tên file) trong nguyên 1 thư mục luôn thì có được không ạ, vì như bên em sử dụng những địa chỉ email chuyên để nhận file từ nhiều khách hàng, hàng ngày em phải trích lưu những file đính kèm của nhiều bên gửi tới hộp mail chung đó nên việc chỉ định lấy theo từng Sender sẽ không hiệu quả. Mong anh hướng dẫn giúp.
 
huevantran đã viết:
Em chào Anh,
Giống như code này nếu chỉ muốn lấy những file đính kèm dạng excel và pdf (Hoặc tìm và lọc theo dạng tên file) trong nguyên 1 thư mục luôn thì có được không ạ, vì như bên em sử dụng những địa chỉ email chuyên để nhận file từ nhiều khách hàng, hàng ngày em phải trích lưu những file đính kèm của nhiều bên gửi tới hộp mail chung đó nên việc chỉ định lấy theo từng Sender sẽ không hiệu quả. Mong anh hướng dẫn giúp.
Nhấp chuột vào đây để mở rộng...
Thử code này xem sao nhé, bởi vì bạn sử dụng tài khoản email chuyên dùng để nhận tệp đính kèm nên mình bỏ điều kiện lọc địa chỉ email, chỉ giữ lại điều kiện khoảng ngày, và tất cả những tệp đính kèm thỏa mãn yêu cầu là tệp Excel và tệp pdf đều sẽ được lưu vào chung một thư mục.
(Lưu ý: Nếu khách hàng hoặc nhiều khách hàng khác nhau gửi email gửi email chứa tệp đính kèm trùng tên thì tệp đính kèm trùng tên sẽ bị ghi đè).

Mã: 
Option Explicit

Public Sub DownloadAttachments(StartDate As Date, EndDate As Date)
    Dim objMail As Outlook.MailItem
    Dim objAtt As Outlook.Attachment
    Dim objPA As Outlook.PropertyAccessor
    Dim objFSO As Object
    Dim strFolderPath As String, strDateTimeFolder As String
    Dim dteStartDate As Date, dteEndDate As Date, dteStartDateUTC As Date, dteEndDateUTC As Date
    Dim i As Long, j As Long
    Dim strFilter As String
    Dim colItems As Outlook.Items
    Dim objFolder As Outlook.Folder
    Const PR_HASATTACH As String = "http://schemas.microsoft.com/mapi/proptag/0x0E1B000B"
    dteStartDate = StartDate 'Ngay bat dau, vd: #1/1#2021#
    dteEndDate = EndDate 'Ngay ket thuc, vd: #1/1/2022#
    Set objMail = Application.CreateItem(olMailItem)
    With objMail
        Set objPA = .PropertyAccessor
        dteStartDateUTC = objPA.LocalTimeToUTC(dteStartDate)
        dteEndDateUTC = objPA.LocalTimeToUTC(dteEndDate)
        .Close olDiscard
    End With
    strFilter = "@SQL=" & Quote(PR_HASATTACH) & "=1 AND " & _
                Quote("urn:schemas:httpmail:datereceived") & " > " & Chr(39) & dteStartDateUTC & Chr(39) & " And " & Quote("urn:schemas:httpmail:datereceived") & " < " & Chr(39) & dteEndDateUTC & Chr(39)
    strFolderPath = Environ$("USERPROFILE") & "\Documents\OutlookAttachments\" 'Thu muc luu tap tin dinh kem, mac dinh: C:\<nguoidung>
    Set objFSO = CreateObject("Scripting.FileSystemObject")
    If Not objFSO.FolderExists(strFolderPath) Then objFSO.CreateFolder strFolderPath
    If Not objFSO.FolderExists(strFolderPath & Format$(Now, "dd-mm-yyyy hh.nn.ss")) Then
        strDateTimeFolder = strFolderPath & Format$(Now, "dd-mm-yyyy hh.nn.ss")
        objFSO.CreateFolder strDateTimeFolder
    Else: strDateTimeFolder = strFolderPath & Format$(Now, "dd-mm-yyyy hh.nn.ss")
    End If
    On Error Resume Next
    Set objFolder = Application.Session.PickFolder
    If Not objFolder Is Nothing Then
        Set colItems = objFolder.Items.Restrict(strFilter)
        For j = 1 To colItems.Count
            Set objMail = colItems.Item(j)
            With objMail
                For i = 1 To .Attachments.Count
                    Set objAtt = .Attachments.Item(i)
                    Select Case objFSO.GetExtensionName(objAtt.filename)
                        Case "xlsx", "xls", "xlsm", "pdf"
                            If objFSO.FileExists(strDateTimeFolder & "\" & objAtt.filename) Then
                                objFSO.DeleteFile strDateTimeFolder & "\" & objAtt.filename
                            End If
                            objAtt.SaveAsFile strDateTimeFolder & "\" & objAtt.filename
                    End Select
                Next i
            End With
        Next
        Shell "explorer """ & strFolderPath & "", vbNormalFocus
    End If
End Sub

Private Function Quote(Text As String) As String
    Quote = Chr(34) & Text & Chr(34)
End Function

huevantran đã viết:
hàng ngày em phải trích lưu những file đính kèm của nhiều bên gửi tới hộp mail chung đó nên việc chỉ định lấy theo từng Sender sẽ không hiệu quả.
Nhấp chuột vào đây để mở rộng...
Nếu hàng ngày phải trích lưu những tệp đính kèm như thế này thì bạn nên viết macro để Outlook tự động tải xuống tệp đính kèm mỗi khi nhận được email là được.
 
Lần chỉnh sửa cuối:
nguyendang95 đã viết:
Nếu hàng ngày phải trích lưu những tệp đính kèm như thế này thì bạn nên viết macro để Outlook tự động tải xuống tệp đính kèm mỗi khi nhận được email là được.
Nhấp chuột vào đây để mở rộng...
Em cảm ơn anh, em đã chạy thử và thấy mã code của anh đã lấy được các file đính kèm gom chung vào 1 thư mục, kết quả đã đúng ạ. Chỉ lưu ý là muốn lấy dữ liệu tới ngày nào thì phải gõ EndDate sau hôm đó 1 ngày.
Hiện tại em cũng mới học VBA căn bản, giáo trình và video hướng dẫn của Excel rất nhiều, tuy nhiên về phần Outlook thì lại ít tài liệu hướng dẫn hơn. Cảm ơn anh đã chỉ dẫn, em sẽ cố gắng thêm.
 
huevantran đã viết:
Em cảm ơn anh, em đã chạy thử và thấy mã code của anh đã lấy được các file đính kèm gom chung vào 1 thư mục, kết quả đã đúng ạ. Chỉ lưu ý là muốn lấy dữ liệu tới ngày nào thì phải gõ EndDate sau hôm đó 1 ngày.
Hiện tại em cũng mới học VBA căn bản, giáo trình và video hướng dẫn của Excel rất nhiều, tuy nhiên về phần Outlook thì lại ít tài liệu hướng dẫn hơn. Cảm ơn anh đã chỉ dẫn, em sẽ cố gắng thêm.
Nhấp chuột vào đây để mở rộng...
Nếu bạn có thắc mắc gì về Outlook VBA, bạn có thể liên hệ với mình để được giải quyết.
 
huevantran đã viết:
Em cảm ơn anh, em đã chạy thử và thấy mã code của anh đã lấy được các file đính kèm gom chung vào 1 thư mục, kết quả đã đúng ạ. Chỉ lưu ý là muốn lấy dữ liệu tới ngày nào thì phải gõ EndDate sau hôm đó 1 ngày.
Hiện tại em cũng mới học VBA căn bản, giáo trình và video hướng dẫn của Excel rất nhiều, tuy nhiên về phần Outlook thì lại ít tài liệu hướng dẫn hơn. Cảm ơn anh đã chỉ dẫn, em sẽ cố gắng thêm.
Nhấp chuột vào đây để mở rộng...
À quên nữa, bổ sung thêm cái này.
Khi dùng truy vấn DASL để lọc item, Outlook cung cấp cho chúng ta một số macro thời gian được định nghĩa sẵn, ví dụ:

1669805726673.png

Như vậy, mình chỉ cần sửa macro một chút là có thể tận dụng được những macro thời gian này.

Mã: 
Option Explicit

Public Enum DateTimeMacro
    Today
    Tomorrow
    Yesterday
    Next7days
    Last7days
    NextWeek
    ThisWeek
    LastWeek
    NextMonth
    ThisMonth
    LastMonth
End Enum

Public Sub DownloadAttachments(Optional UseDateTimeMacro As Boolean = False, Optional DateTimeMacro As DateTimeMacro, Optional StartDate As Date, Optional EndDate As Date)
    Dim objMail As Outlook.MailItem
    Dim objAtt As Outlook.Attachment
    Dim objPA As Outlook.PropertyAccessor
    Dim objFSO As Object
    Dim strFolderPath As String, strDateTimeFolder As String
    Dim dteStartDate As Date, dteEndDate As Date, dteStartDateUTC As Date, dteEndDateUTC As Date
    Dim i As Long, j As Long
    Dim strFilter As String
    Dim colItems As Outlook.Items
    Dim objFolder As Outlook.Folder
    Dim strDateTimeMacro As String
    Const PR_HASATTACH As String = "http://schemas.microsoft.com/mapi/proptag/0x0E1B000B"
    If UseDateTimeMacro = False Then
        dteStartDate = StartDate 'Ngay bat dau, vd: #1/1#2021#
        dteEndDate = EndDate 'Ngay ket thuc, vd: #1/1/2022#
        Set objMail = Application.CreateItem(olMailItem)
        With objMail
            Set objPA = .PropertyAccessor
            dteStartDateUTC = objPA.LocalTimeToUTC(dteStartDate)
            dteEndDateUTC = objPA.LocalTimeToUTC(dteEndDate)
            .Close olDiscard
        End With
        strFilter = "@SQL=" & Quote(PR_HASATTACH) & "=1 AND " & _
                Quote("urn:schemas:httpmail:datereceived") & " > " & Chr(39) & dteStartDateUTC & Chr(39) & " And " & Quote("urn:schemas:httpmail:datereceived") & " < " & Chr(39) & dteEndDateUTC & Chr(39)
    Else
        Select Case DateTimeMacro
            Case Today
                strDateTimeMacro = "%today(" & Quote("urn:schemas:httpmail:datereceived") & ")%"
            Case Tomorrow
                strDateTimeMacro = "%tomorrow(" & Quote("urn:schemas:httpmail:datereceived") & ")%"
            Case Yesterday
                strDateTimeMacro = "%yesterday(" & Quote("urn:schemas:httpmail:datereceived") & ")%"
            Case Next7days
                strDateTimeMacro = "%next7days(" & Quote("urn:schemas:httpmail:datereceived") & ")%"
            Case Last7days
                strDateTimeMacro = "%last7days(" & Quote("urn:schemas:httpmail:datereceived") & ")%"
            Case NextWeek
                strDateTimeMacro = "%nextweek(" & Quote("urn:schemas:httpmail:datereceived") & ")%"
            Case ThisWeek
                strDateTimeMacro = "%thisweek(" & Quote("urn:schemas:httpmail:datereceived") & ")%"
            Case LastWeek
                strDateTimeMacro = "%lastweek(" & Quote("urn:schemas:httpmail:datereceived") & ")%"
            Case NextMonth
                strDateTimeMacro = "%nextmonth(" & Quote("urn:schemas:httpmail:datereceived") & ")%"
            Case ThisMonth
                strDateTimeMacro = "%thismonth(" & Quote("urn:schemas:httpmail:datereceived") & ")%"
            Case LastMonth
                strDateTimeMacro = "%lastmonth(" & Quote("urn:schemas:httpmail:datereceived") & ")%"
        End Select
        strFilter = "@SQL=" & strDateTimeMacro & " AND " & Quote(PR_HASATTACH) & "=1 "
    End If
    strFolderPath = Environ$("USERPROFILE") & "\Documents\OutlookAttachments\" 'Thu muc luu tap tin dinh kem, mac dinh: C:\<nguoidung>
    Set objFSO = CreateObject("Scripting.FileSystemObject")
    If Not objFSO.FolderExists(strFolderPath) Then objFSO.CreateFolder strFolderPath
    If Not objFSO.FolderExists(strFolderPath & Format$(Now, "dd-mm-yyyy hh.nn.ss")) Then
        strDateTimeFolder = strFolderPath & Format$(Now, "dd-mm-yyyy hh.nn.ss")
        objFSO.CreateFolder strDateTimeFolder
    Else: strDateTimeFolder = strFolderPath & Format$(Now, "dd-mm-yyyy hh.nn.ss")
    End If
    On Error Resume Next
    Set objFolder = Application.Session.PickFolder
    If Not objFolder Is Nothing And objFolder.DefaultItemType = olMailItem Then
        Set colItems = objFolder.Items.Restrict(strFilter)
        For j = 1 To colItems.Count
            Set objMail = colItems.Item(j)
            With objMail
                For i = 1 To .Attachments.Count
                    Set objAtt = .Attachments.Item(i)
                    Select Case objFSO.GetExtensionName(objAtt.filename)
                        Case "xlsx", "xls", "xlsm", "pdf"
                            If objFSO.FileExists(strDateTimeFolder & "\" & objAtt.filename) Then
                                objFSO.DeleteFile strDateTimeFolder & "\" & objAtt.filename
                            End If
                            objAtt.SaveAsFile strDateTimeFolder & "\" & objAtt.filename
                    End Select
                Next i
            End With
        Next
        Shell "explorer """ & strFolderPath & "", vbNormalFocus
    Else: MsgBox "You must select a folder that contains email items only.", vbExclamation, "Error: Invalid Folder"
    End If
End Sub

Private Function Quote(Text As String) As String
    Quote = Chr(34) & Text & Chr(34)
End Function

Giả sử bạn muốn tải xuống đính kèm từ những email nhận được trong ngày hôm nay:

Mã: 
Private Sub SaveEmailAttachments()
    Call DownloadAttachments(UseDateTimeMacro:=True, DateTimeMacro:=Today)
End Sub

Tham khảo thêm:

Filtering Items Using a Date-time Comparison​

 
Lần chỉnh sửa cuối:
Bạn phải đăng nhập hoặc đăng ký để trả lời bài viết tại đây.
Web KT

Bài viết mới nhất

L
xin anh chị giúp em công thức tính tổng năm theo điều kiện ạ (1 người xem)
    • Chấp nhận
Trả lời
16
Đọc
391
Lan Ny
L
Momominh
Tìm kiếm dữ liệu từ các sheet (2 người xem)
Trả lời
6
Đọc
305
Momominh
Momominh
Nguyễn Duy Tuân
  • Dán lên cao
Sử dụng AI trong Excel với Add-in A-Tools AI v10 (1 người xem)
    • Thích
    • Cảm ơn
Trả lời
10
Đọc
992
Nguyễn Duy Tuân
Nguyễn Duy Tuân
N
  • Question Question
Chia sẻ COM DLL giúp tra cứu mã số thuế từ trang web masothue.com (2 người xem)
    • Thích
Trả lời
0
Đọc
71
nguyendang95
N
K
Tạo mã thiết bị (1 người xem)
Trả lời
11
Đọc
331
SA_DQ
SA_DQ
GPE-Trợ Lý
[HCM] ĐĂNG KÝ THAM DỰ SINH NHẬT GIAIPHAPEXCEL LẦN THỨ 19 NGÀY 06/07/2025
    • Thích
Trả lời
4
Đọc
620
PhanTuHuong
PhanTuHuong
Tungnk
VBA Nhận được thông báo: Run-time error "70" Permission denied (1 người xem)
Trả lời
5
Đọc
2K
ptm0412
ptm0412
T
Tô màu ảnh bác Hồ bằng Conditional Formatting (1 người xem)
Trả lời
6
Đọc
154
thuctien
T
HeSanbi
  • Đã giải quyết
ZaloExcel v2.94: Gửi tin nhắn, hình ảnh, bảng, biểu đồ, tập tin, tạo nhóm, thu thập tin nhắn (2 người xem)
    • Thích
    • Cảm ơn
    • Yêu thích
2 3
Trả lời
58
Đọc
18K
HeSanbi
HeSanbi
K
lấy dữ liệu từ excel sang worrd (1 người xem)
Trả lời
3
Đọc
117
VetMini
V
M
File excel ứng dụng trong nhập xuất kho, thu chi, bán hàng và công nợ (3 người xem)
    • Thích
    • Yêu thích
    • Cảm ơn
7 8 9
Trả lời
166
Đọc
32K
giangsimso
G
chickenexcel
xin hướng dẫn code chọn hình ảnh trong file
Trả lời
4
Đọc
190
thuytrangbp28
T
T
Cách cộng tổng chính xác nhất
Trả lời
7
Đọc
281
THANH657
T
GPE-Trợ Lý
ĐĂNG KÝ THAM DỰ SINH NHẬT GPE TẠI HN - SỰ KIỆN TALKSHOW ĐẶC BIỆT
    • Thích
2
Trả lời
26
Đọc
2K
GPE-Trợ Lý
GPE-Trợ Lý
Y
Lấy dữ liệu từ nhiều sheet khác nhau.
2
Trả lời
20
Đọc
666
lib.enigma
L
T
In lặp lại nhiều dòng ở cuối các trang
Trả lời
13
Đọc
468
Hoàng Tuấn 868
H
C
Xin file lên thực đơn và định lượng món ăn cho suất ăn công nghiệp
Trả lời
0
Đọc
97
Chihuong_vp90
C
T
Lỗi Khi Mở File Excel
Trả lời
3
Đọc
129
Hoàng Tuấn 868
H
H
Em chào anh chị ạ.Em cần xếp lịch nghỉ randum cho 1 số nhóm làm việc trong 1 công ty.
Trả lời
4
Đọc
182
Duy Tùng 9x
Duy Tùng 9x
1
Em hỏi chút về hàm điều kiện với liệt kê
Trả lời
2
Đọc
159
123456it
1
Xem thêm…

Thành viên có số lượng bài viết cao nhất tháng

Thành viên có điểm tương tác cao nhất tháng

Sinh nhật lần 19 GPE

000
Ngày
00
Giờ
00
phút
00
giây
Thân mời tham dự sự kiện sinh nhật GPE 2025
Back
Top Bottom