Cách tự động lưu mail Outlook vào ổ cứng máy tính.

Chào mọi người.
Xin mọi người giúp đỡ.
Đầu tiên mình tạo 1 macro khi nào mình sử dụng macro thì mail tự động lưu về ổ cứng máy tính.
Khi chọn macro thì sẽ tự tạo ra mail mới với format sẳn như hình. Và nó sẽ tự động lưu email vào folder trong máy tính theo link mình đã chọn . Với điều kiện nó sẽ lưu theo mã CODE trong phần tô vàng trong hình.số Kí tự code bằng nhau nhưng nội dung kí tự sẽ thây đổi . Vì vậy nó sẽ tự biết lưu những mail nào có cùng mã code vào chung 1 folder.mỗi code mới nó sẽ tự tạo ra folder mới để lưu.
Mong mọi người giúp em ạ. Nếu được em sẽ hậu tạ ạ. Em cảm ơn

2085

Option Explicit
Public Sub SaveMessageAsMsg()
  Dim oMail As Outlook.MailItem
  Dim objItem As Object
  Dim sPath As String
  Dim dtDate As Date
  Dim sName As String
  Dim enviro As String

enviro = CStr(Environ("USERPROFILE"))
   For Each objItem In ActiveExplorer.Selection
   If objItem.Messaghocexcel = "IPM.Note" Then
    Set oMail = objItem

sName = oMail.Subject
  ReplaceCharsForFileName sName, "-"

dtDate = oMail.ReceivedTime
  sName = Format(dtDate, "yyyymmdd", vbUseSystemDayOfWeek, _
    vbUseSystem) & Format(dtDate, "-hhnnss", _
    vbUseSystemDayOfWeek, vbUseSystem) & "-" & sName & ".msg"

'    sPath = enviro & "Documents"
  sPath = "Y:3.Financial statements19. Working folders11. PaymentE-invoice adjustment cases"
  'sPath = "C:temp"
  Debug.Print sPath & sName
  oMail.SaveAs sPath & sName, olMSG

End If
  Next

End Sub

Private Sub ReplaceCharsForFileName(sName As String, _
  sChr As String _
)
  sName = Replace(sName, "'", sChr)
  sName = Replace(sName, "*", sChr)
  sName = Replace(sName, "/", sChr)
  sName = Replace(sName, "", sChr)
  sName = Replace(sName, ":", sChr)
  sName = Replace(sName, "?", sChr)
  sName = Replace(sName, Chr(34), sChr)
  sName = Replace(sName, "<", sChr)
  sName = Replace(sName, ">", sChr)
  sName = Replace(sName, "|", sChr)
End Sub
Function BrowseForFolder(Optional OpenAt As Variant) As Variant
  Dim ShellApp As Object
  Set ShellApp = CreateObject("Shell.Application"). _
 BrowseForFolder(0, "Please choose a folder", 0, OpenAt)

On Error Resume Next
    BrowseForFolder = ShellApp.self.Path
 On Error GoTo 0

Set ShellApp = Nothing
    Select Case Mid(BrowseForFolder, 2, 1)
        Case Is = ":"
            If Left(BrowseForFolder, 1) = ":" Then GoTo Invalid
        Case Is = ""
            If Not Left(BrowseForFolder, 1) = "" Then GoTo Invalid
        Case Else
            GoTo Invalid
    End Select
 Exit Function

Invalid:
 BrowseForFolder = False
End Function

Phần Issue Code là chủ thớt tự nhập vào đúng không nhỉ. Mình không rõ chỗ này lắm, macro thì viết được đấy nhưng lấn cấn ở chỗ này.

www.giaiphapexcel.com/diendan/threads/c%C3%A1ch-t%E1%BB%B1-%C4%91%E1%BB%99ng-l%C6%B0u-mail-outlook-v%C3%A0o-%E1%BB%95-c%E1%BB%A9ng-m%C3%A1y-t%C3%ADnh.161016/#post-1077412

Khóa học SprinGO phù hợp

Xây dựng Lương 3P, KPI cho Doanh nghiệp

Làm thế nào để trả lương cho nhân viên chính xác nhất? Đây là một trong những câu hỏi khó trong quản trị nhân...

Xem khóa học