Πώς να αποθηκεύσετε τα μηνύματα ηλεκτρονικού ταχυδρομείου Outlook με βάση το θέμα και αποστολέα το όνομα, χρησιμοποιώντας VBA;

ψήφοι
0

Θα πρέπει να αποθηκεύσετε σε ένα φάκελο στην επιφάνεια εργασίας, μηνύματα ηλεκτρονικού ταχυδρομείου που ταιριάζουν με τις εξής προϋποθέσεις:

  1. Θέμα αρχίζει με RE: ΓΙΑ ΤΗΝ ΑΝΑΘΕΩΡΗΣΗ
  2. Ονόματα Αποστολέας είναι: άλφα, βήτα ή γάμμα (παράδειγμα)

Εάν πληρούνται και οι δύο από αυτές τις συνθήκες, μια Ναι / Όχι MsgBox θα πρέπει να εμφανιστεί.

Κώδικας:

Private WithEvents InboxItems As Outlook.Items
Sub Application_Startup()
Dim xNameSpace As Outlook.NameSpace
Set xNameSpace = Outlook.Application.Session
Set InboxItems = xNameSpace.GetDefaultFolder(olFolderInbox).Items
End Sub

Private Sub InboxItems_ItemAdd(ByVal objItem As Object)
 Dim FSO
 Dim xMailItem As Outlook.MailItem
 Dim xFilePath As String
 Dim xRegEx
 Dim xFileName As String
 Dim Output As String
 Dim Item As Object
 On Error Resume Next

  If (Item.Subject Like RE:FOR REVIEW*) And ((Item.SenderName = Alpha) Or (Item.SenderName = Beta) or (Item.SenderName = Gamma) ) Then
   Output = MsgBox(Do you want to save this email?, vbYesNo + vbQuestion, Reminder)
   If Output = vbNo Then Exit Sub
    Else
     xFilePath = CreateObject(WScript.Shell).SpecialFolders(16)
     xFilePath = C:\Users\ABC\Desktop\Test
     Set FSO = CreateObject(Scripting.FileSystemObject)
     If FSO.FolderExists(xFilePath) = False Then
      FSO.CreateFolder (xFilePath)
     End If
     Set xRegEx = CreateObject(vbscript.regexp)
    xRegEx.Global = True
    xRegEx.IgnoreCase = False
    xRegEx.Pattern = \||\/|\<|\>||:|\*|\\|\?
    If objItem.Class = olMail Then
     Set xMailItem = objItem
    xFileName = xRegEx.Replace(xMailItem.Subject, )
    xMailItem.SaveAs xFilePath & \ & xFileName & .html, olHTML
    End If
   End If

Exit Sub
End Sub

Πρόβλημα:
Η pop up έρχεται για όλη την γραμμή θέματος και όλους τους χρήστες.

Προσπάθησα χρησιμοποιώντας ένθετα Αν οι άλλοι, αλλά δεν πήρε το σωστό αποτέλεσμα.

Το σύνολο κώδικας είναι σε ThisOutlookSession.

Επεξεργασία 1 , θα αφαιρεθεί το On Error Resume Next.

Η επεξεργασία κώδικας είναι:

Private WithEvents InboxItems As Outlook.Items
Sub Application_Startup()
Dim xNameSpace As Outlook.NameSpace
Set xNameSpace = Outlook.Application.Session
Set InboxItems = xNameSpace.GetDefaultFolder(olFolderInbox).Items
End Sub

Private Sub InboxItems_ItemAdd(ByVal objItem As Object)
 Dim FSO
 Dim xMailItem As Outlook.MailItem
 Dim xFilePath As String
 Dim xRegEx
 Dim xFileName As String
 Dim Output As String

  If objItem.Class = olMail Then '**
  Set xMailItem = Application.CreateItem(olMailItem) '**

  If (xMailItem.Subject Like RE:FOR REVIEW*) And ((xMailItem.SenderName = Alpha) Or (xMailItem.SenderName = Beta) or (xMailItem.SenderName = Gamma) ) Then
     Output = MsgBox(Do you want to save this email?, vbYesNo + vbQuestion, Reminder)
    If Output = vbNo Then Exit Sub
     Else
      xFilePath = CreateObject(WScript.Shell).SpecialFolders(16)
      xFilePath = C:\Users\abc\Desktop\Test
      Set FSO = CreateObject(Scripting.FileSystemObject)
      If FSO.FolderExists(xFilePath) = False Then
       FSO.CreateFolder (xFilePath)
      End If
      Set xRegEx = CreateObject(vbscript.regexp)
     xRegEx.Global = True
     xRegEx.IgnoreCase = False
     xRegEx.Pattern = \||\/|\<|\>||:|\*|\\|\?
     If objItem.Class = olMail Then
      Set xMailItem = objItem
     xFileName = xRegEx.Replace(xMailItem.Subject, )
     xMailItem.SaveAs xFilePath & \ & xFileName & .html, olHTML
     End If
    End If
  End If
Exit Sub
End Sub
Δημοσιεύθηκε 27/11/2018 στις 17:48
πηγή χρήστη
Σε άλλες γλώσσες...                            


1 απαντήσεις

ψήφοι
0

Μία προτεινόμενη Αν / Else δομή με κατάλληλη mailitem.

Option Explicit

Private Sub InboxItems_ItemAdd(ByVal objItem As Object)

    Dim FSO
    Dim xMailItem As MailItem
    Dim xFilePath As String
    Dim xRegEx
    Dim xFileName As String

    If objItem.Class = olMail Then

        'objItem could be used directly but this is sometimes beneficial
        Set xMailItem = objItem

        If (xMailItem.subject Like "RE:FOR REVIEW*") Then

            If ((xMailItem.senderName = "Alpha") Or _
                (xMailItem.senderName = "Beta") Or _
                (xMailItem.senderName = "Gamma")) Then

                If MsgBox("Do you want to save this email?", vbYesNo + vbQuestion, "Reminder") = vbYes Then

                    xFilePath = "C:\Users\abc\Desktop\Test"

                    Set FSO = CreateObject("Scripting.FileSystemObject")
                    If FSO.FolderExists(xFilePath) = False Then
                        FSO.CreateFolder (xFilePath)
                    End If

                    Set xRegEx = CreateObject("vbscript.regexp")
                    xRegEx.Global = True
                    xRegEx.IgnoreCase = False
                    xRegEx.Pattern = "\||\/|\<|\>|""|:|\*|\\|\?"

                    xFileName = xRegEx.Replace(xMailItem.subject, "")

                    xMailItem.SaveAs xFilePath & "\" & xFileName & ".html", olHTML

                End If

            End If

        End If

    End If

End Sub
Απαντήθηκε 28/11/2018 στις 17:20
πηγή χρήστη

Cookies help us deliver our services. By using our services, you agree to our use of cookies. Learn more