как запустить макрос Outlook для новых писем из общего почтового ящика

ProgramBox

как запустить макрос Outlook для новых писем из общего почтового ящика

Post author:admin
Запись опубликована:31 марта, 2023
Post category:Вопросы по программированию

#vba #outlook

Вопрос:

Этот код отлично работает для обычного почтового ящика, но как изменить код для запуска подтверждения (только для новых писем, необходимо исключить повторные и пересылать письма, которые приходят в папку входящие) из общего почтового ящика (xxx@mail.com ).папка (входящие)

как изменить этот код для запуска из определенного общего почтового ящика «Входящие»

 Public WithEvents xlItems As Outlook.Items
        Private Sub Application_Startup()
        Set xlItems = Session.GetDefaultFolder(olFolderInbox).Items
        End Sub

Полный код:

 Public WithEvents xlItems As Outlook.Items
    Private Sub Application_Startup()
    Set xlItems = Session.GetDefaultFolder(olFolderInbox).Items
    End Sub
    Private Sub xlItems_ItemAdd(ByVal objItem As Object)
    Dim xlReply As MailItem
    Dim xStr As String
    If objItem.Class <> olMail Then Exit Sub
    Set xlReply = objItem.Reply
    With xlReply
         xStr = "<p>" amp; "Hi Team, Acknowledging that we have received the Job. Thank you!" amp; "</p>"
         .HTMLBody = xStr amp; .HTMLBody
         .Send
    End With
End Sub

Я попытался изменить код, но это не сработало

 Option Explicit
Private WithEvents olInboxItems As Items
  Dim objNS As NameSpace
  Set objNS = Application.Session
  ' instantiate objects declared WithEvents
  Set olInboxItems = objNS.Folders("xxxxxxxx@gmail.com").Folders("Inbox").Items
  Set objNS = Nothing
End Sub

Private Sub olInboxItems_ItemAdd(ByVal Item As Object)
Dim xlReply As MailItem
Dim xStr As String
If objItem.Class <> olMail Then Exit Sub
Set xlReply = objItem.Reply
With xlReply
     xStr = "<p>" amp; "Hi Team, Acknowledging that we have received the Job. Thank you!" amp; "</p>"
     .HTMLBody = xStr amp; .HTMLBody
     .Send
End Sub

1. При публикации опишите любые проблемы, которые вы видите. В измененном коде у вас должна появиться ошибка, If objItem.Class <> olMail Then потому что objItem не существует. Модифицированный код отсутствует Private Sub Application_Startup() . Скопируйте код непосредственно из вашего редактора.

2. Я пытался, Но я не мог понять код Niton, Пожалуйста, не могли бы вы, пожалуйста, исправить это. Код, упомянутый в Полном коде , работает нормально. Я сталкиваюсь с проблемой, когда я включаю просмотр из общей папки в измененном

3. Также, если я включу ‘Private Sub Application_Startup ()’, он также запускает подтверждение отправки почты для ответа и пересылки почты. как ограничить их.

Ответ №1:

Это должно быть более надежным, чем проверка наличия «Re:» и «Fw:» в теме.

В этом сеансе просмотра

 Option Explicit ' Consider this mandatory
' Tools | Options | Editor tab
' Require Variable Declaration
' If desperate declare as Variant

Public WithEvents olItems As Items

Private Sub Application_Startup()
    
    Set olItems = Session.Folders("xxxx@xxx.com").Folders("Inbox").Items
    
End Sub

Private Sub olItems_ItemAdd(ByVal Item As Object)

    Dim olReply As MailItem
 
    If Item.Class = olMail Then
        
        If Len(Item.ConversationIndex) > 44 Then
            Exit Sub
        
        Else
        
            Set olReply = Item.reply
    
            With olReply
                .Body = "Reply to first email."
                .Display
            End With
        
        End If
    
    End If
    
End Sub

Ответ №2:

Наконец-то я сам разобрался с кодом. Но он отправляет почту для всех электронных писем, включая (RE и FWD)

 Public WithEvents olItems As Outlook.Items
Private Sub Application_Startup()
Dim olApp As Outlook.Application
Dim objNS As Outlook.NameSpace
Set olApp = Outlook.Application
Set objNS = olApp.GetNamespace("MAPI")
' default local Inbox
Set olItems = objNS.Folders("xxxx@xxx.com").Folders("Inbox").Items

End Sub
Private Sub olItems_ItemAdd(ByVal Item As Object)
    Dim olReply As MailItem
 
    If Item.Class = olMail Then
       Set olReply = Item.Reply
    Else
       Exit Sub
    End If
 
    With olReply
         'Type Your Own Auto Reply
         'Change "John Smith" to Your Own Name
         .Body = "This is a test auto reply." amp; vbCrLf amp; vbCrLf amp; "-------Original Message-------" amp; vbCrLf amp; "From: " amp; Item.Sender amp; "[mailto: " amp; Item.SenderEmailAddress amp; "]" amp; vbCrLf amp; "Sent: " amp; Item.ReceivedTime amp; vbCrLf amp; "To: YourName" amp; vbCrLf amp; "Subject: " amp; Item.Subject amp; vbCrLf amp; Item.Body
         .Send
    End With
End Sub

Ответ №3:

Это примитивная / интуитивно понятная версия.
Тема должна оставаться неизменной и быть на английском языке.

В этом сеансе просмотра

 Option Explicit ' Consider this mandatory
' Tools | Options | Editor tab
' Require Variable Declaration
' If desperate declare as Variant

Public WithEvents olItems As Items

Private Sub Application_Startup()

    Dim objNS As namespace
    
    Set objNS = GetNamespace("MAPI")
    Set olItems = objNS.Folders("xxxx@xxx.com").Folders("Inbox").Items
    
End Sub

Private Sub olItems_ItemAdd(ByVal Item As Object)

    Dim olReply As MailItem
 
    If Item.Class = olMail Then
        
        If Left(UCase(Item.Subject), 4) = UCase("Re: ") Or _
           Left(UCase(Item.Subject), 4) = UCase("Fw: ") Then
            Exit Sub
        
        Else
        
            Set olReply = Item.reply
    
            With olReply
                .Body = "Reply to first email."
                .Display
            End With
        
        End If
    
    End If
    
End Sub