In mail outlook hàng loạt có file đính kèm (6 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

D
Nhờ các bác giúp đỡ vấn đề tìm kiếm dữ liệu (2 người xem)
Trả lời
3
Đọc
76
duongbabao90
D
D
Nhờ giúp đỡ về công thức xếp loại rèn luyện theo thông tư 22/2021/TT-BGDĐT (3 người xem)
Trả lời
8
Đọc
84
thanthanhan
T
Maika8008
Tặng file quản lý vật tư - công nợ (nhập xuất kho hàng và công nợ khách hàng) (3 người xem)
    • Thích
    • Yêu thích
    • Cảm ơn
4 5 6
Trả lời
116
Đọc
25K
Thanh Tam 07
T
D
  • Đã giải quyết
Quản lý email outlook qua VBA cần giúp đỡ (1 người xem)
2
Trả lời
25
Đọc
864
befaint
befaint
A
NHỜ ANH CHỊ GIÚP EM CÂU LỆNH NÀY VỚI Ạ
Trả lời
1
Đọc
106
ongke0711
ongke0711
P
Hỏi về cách dò tìm từ dưới lên trên, dò tìm trong 2 bảng
Trả lời
6
Đọc
154
pqdowntailieu3
P
H
Chuyển file *xml hóa đơn điện tử sang excel
    • Thích
Trả lời
4
Đọc
198
htrunga2
H
K
Lọc một mã sản phẩm có nhiều đơn giá thành một file riêng
Trả lời
2
Đọc
110
ketoansb123
K
D
Nhờ trợ giúp xác định thứ tự của các từ và cụm từ trong 1 chuỗi văn bản.
Trả lời
10
Đọc
264
Phuocam
Phuocam
P
Xin tư vấn về cách tạo bảng quản lý vải (1 người xem)
    • Cười
Trả lời
13
Đọc
214
Hai Lúa Miền Tây
Hai Lúa Miền Tây
1
Vướng mắc về hàm lấy tên đăng nhập máy tính ạ
Trả lời
19
Đọc
563
thuytrangbp28
T
Trungvt3
Công thức trả về định dạng không như mong muốn và viết phân số trong 1 ô.
Trả lời
6
Đọc
194
Trungvt3
Trungvt3
H
  • Question Question
Tô đậm tiêu đề cho cho các sheet (1 người xem)
Trả lời
4
Đọc
188
hieu998
H
GPE-Trợ Lý
[GPE] HỘI THẢO POWER QUERY – CÔNG CỤ QUẢN LÝ DỮ LIỆU HCM
    • Thích
Trả lời
1
Đọc
971
GPE-Trợ Lý
GPE-Trợ Lý
Z
TRỢ GIÚP K SORT ĐƯỢC THỨ TỰ NGÀY THÁNG NĂM TRONG EXCEL
Trả lời
2
Đọc
123
Duy Tùng 9x
Duy Tùng 9x
H
Tách file nguồn thành nhiều file dựa vào điều kiện
Trả lời
5
Đọc
178
LePhatHuy
LePhatHuy
F
  • Question Question
Tự động Merge Mail bằng VBA
Trả lời
7
Đọc
366
fujishima
F
Nguyễn Duy Tuân
Phiên bản mới Add-in A-Tools v10 (2024) (1 người xem)
    • Thích
2 3
Trả lời
49
Đọc
4K
Nguyễn Duy Tuân
Nguyễn Duy Tuân
N
tính thể tích bồn dầu hình trụ elip nằm ngang
Trả lời
10
Đọc
47K
pvkiem
P
vsitcnh
Hỗ trợ công thức tính điểm dựa theo điều kiện.
Trả lời
18
Đọc
417
tle2003
T
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

Đếm ngược thời gian

000
Ngày
00
Giờ
00
phút
00
giây
[GPE] HỘI THẢO POWER QUERY – CÔNG CỤ QUẢN LÝ DỮ LIỆU HCM
Back
Top Bottom