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
Elx 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.

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

SA_DQ
Copilot & bài thơ chia bánh do 'Hắn' sáng tác (1 người xem)
Trả lời
2
Đọc
40
SA_DQ
SA_DQ
H
  • Question Question
Code Sổ Chi Tiết Tài Khoản (2 người xem)
Trả lời
0
Đọc
36
hieuvietmy2020
H
HeSanbi
  • Đã giải quyết
WeatherXL - Ứng dụng lấy dữ liệu Thời tiết siêu nhanh (***Nguồn cấp FreeMeteo đã dừng cấp dữ liệu lịch sử) (1 người xem)
    • Thích
    • Yêu thích
Trả lời
90
Đọc
25K
dinhhoangcd13
D
T
GẤP: TÌM GIÁ THEO TỪNG KHÁCH
Trả lời
7
Đọc
322
tulipviet
T
D
lấy thẻ kho từ sổ kho nên dùng hàm nào ah
Trả lời
3
Đọc
78
dankedun
D
L
công thứ tìm giá trị giao hàng với cột
Trả lời
13
Đọc
189
luongcongdua
L
ongke0711
  • Question Question
Tải hóa đơn điện tử (https://hoadondientu.gdt.gov.vn/) Excel Vba (1 người xem)
    • Thích
    • Yêu thích
    • Cảm ơn
4 5 6
Trả lời
552
Đọc
69K
ongke0711
ongke0711
K
Nhờ anh chị làm công thức lọc dữ kiện ngày từ bảng 1 sang rút gọn ngày ở bảng 2.
Trả lời
1
Đọc
100
thanthanhan
thanthanhan
SA_DQ
Tìm số chính phương trong 1 biểu thức cho trước (1 người xem)
    • Thích
    • Yêu thích
Trả lời
22
Đọc
323
dungpham01
D
T
TỈNH TỔNG TỪNG Ô THEO ĐIỀU KIỆN
Trả lời
3
Đọc
113
thanthanhan
thanthanhan
A
  • Question Question
Sửa code VBA nhập liệu userform (1 người xem)
Trả lời
22
Đọc
943
ptm0412
ptm0412
8
Tính tổng điểm 3 môn theo tổ hợp xét tuyển
Trả lời
3
Đọc
88
ptm0412
ptm0412
N
  • Question Question
Tool chia băng kết hợp bên ngành tôn
Trả lời
0
Đọc
93
nguyenanhtruong2409
N
S
Chỉnh công thức tính tỷ lệ hoàn thành giúp mình với.
Trả lời
8
Đọc
455
ptm0412
ptm0412
L
Tìm giải pháp trừ lùi nguyên liệu xuất nhập khẩu
Trả lời
9
Đọc
309
luongcongdua
L
2
  • Question Question
Hỏi cách in phiếu điều tra PCGD-XMC từ file dữ liệu mẫu xuất ra từ hệ thống PCGD-XMC của Bộ GD
    • Thích
Trả lời
31
Đọc
2K
Hoàng Tuấn 868
H
H
Tìm dữ liệu trùng
Trả lời
6
Đọc
422
Hoàng Tuấn 868
H
H
Không có dữ liệu ở côt A, khi ghi dữ liệu
    • Cười
Trả lời
1
Đọc
148
SA_DQ
SA_DQ
A
Cách đặt nhanh dấu nháy (') trước các công thức, bỏ nhanh dấu nháy trước công thức
Trả lời
6
Đọc
366
dungpham01
D
H
Xin nhờ chỉ giúp sửa lỗi file
Trả lời
4
Đọc
212
haptrung
H
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

Thời gian đếm ngược.

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