vba从excel发送带有发件人标志的电子邮件

Question

I have a function that allows to send emails.我有一个允许发送电子邮件的功能。 Is it possible to add a flag with a reminder for the sender?是否可以为发件人添加带有提醒的标志？ [edit] I don't need the window itself, I just want to set a reminder for the sender. [编辑]我不需要窗口本身，我只想为发件人设置提醒。

Function SendHTMLEmail()
Dim olApp As Object
Dim NewMail As Object
On Error GoTo err

Set olApp = CreateObject("Outlook.Application")
Set NewMail = olApp.CreateItem(0)

With NewMail
    .subject = "subject"
    .body = "body"
    .Display

    bodyFormat = "<BODY style=font-family:Calibri>" & body & "</BODY>"
    NewMail.HTMLBody = bodyFormat & NewMail.HTMLBody

End With

err:
Set olApp = Nothing
Set NewMail = Nothing
End Function

Answer 1

If there is no way without user interaction, there is a generic command to press a button that still works for this button.如果没有用户交互就没有办法，有一个通用命令来按下仍然适用于该按钮的按钮。

Function SendHTMLEmail()

    Dim olApp As Object
    Dim NewMail As Object
    
    On Error GoTo err
    
    Set olApp = CreateObject("Outlook.Application")
    Set NewMail = olApp.CreateItem(0)
    
    With NewMail
    
        .Subject = "subject"
        .Body = "body"
        .Display
                
        ' If the AddReminder button is available in your version of Outlook.
        .GetInspector.CommandBars.ExecuteMso ("AddReminder")
        
        ' Some previously working code, where the applicable button is available, now fails.
        '
        '  https://docs.microsoft.com/en-us/office/vba/api/Office.CommandBars.ExecuteMso
        '
        '  This method is useful in cases where there is no object model for a particular command.
        '  Works on controls that are built-in buttons, toggleButtons, and splitButtons.
        '  On failure it returns E_InvalidArg for an invalid idMso,
        '   and E_Fail for controls that are not enabled or not visible.
        
    End With

err:
    Set olApp = Nothing
    Set NewMail = Nothing
    
End Function

Answer 2

You cannot review before sending but to get the same result after sending with the ItemAdd event on the Sent Items folder:您不能在发送前查看，但在使用已发送邮件文件夹上的 ItemAdd 事件发送后获得相同的结果：

In the ThisOutlookSession module在 ThisOutlookSession 模块中

Private Sub sentFolderItems_ItemAdd(ByVal obj As Object)

    Dim mail As MailItem
           
    If TypeOf obj Is MailItem Then
        
        Set mail = obj
            
        With mail
        
            Debug.Print
            Debug.Print ".Subject.......: " & .Subject
            
            '  restrict mail in an appropriate manner if needed
            'If InStr(UCase(.Subject), UCase("add follow up flag and reminder")) > 0 Then
                
                ' this sets the "Follow up" flag
                '
                ' *** Add Reminder option not required ***
                '
                ' https://docs.microsoft.com/en-ca/office/vba/api/Outlook.OlMarkInterval
                .MarkAsTask olMarkNoDate
                Debug.Print ".IsMarkedAsTask: " & .IsMarkedAsTask
                
                ' if Add Reminder is available
                '.TaskStartDate = Date + 1
                'Debug.Print ".TaskStartDate.: " & .TaskStartDate
                
                ' if Add Reminder is available
                '.TaskDueDate = Date + 2
                'Debug.Print ".TaskDueDate...: " & .TaskDueDate
                
                .ReminderSet = True
                
                ' in a MarkAsTask item, if Add Reminder is available
                '  ReminderTime is displayed
                '
                ' in a .FlagRequest = "test" item
                '  or deprecated .FlagStatus = olFlagMarked item,
                '  use .FlagDueBy
                '
                '  d = days,  h=hour, n = minute not m
                .ReminderTime = DateAdd("n", 1, Now)
                
                .Save
                
                ' ** A saved ReminderTime is not sufficient to trigger a reminder
                ' **  must have the Add Reminder option in the menu
                Debug.Print ".ReminderTime..: " & .ReminderTime

            'End If
            
        End With
            
    End If
    
End Sub

To test去测试

Private Sub sentFolderItems_ItemAdd_test()
    sentFolderItems_ItemAdd ActiveInspector.CurrentItem
End Sub

To set up sentFolderItems_ItemAdd .设置sentFolderItems_ItemAdd 。

Option Explicit
Private WithEvents sentFolderItems As Items

Sub Application_Startup()
    Dim sentFolder As folder
    Set sentFolder = Session.GetDefaultFolder(olFolderSentMail)
    Set sentFolderItems = sentFolder.Items
End Sub

Run Application_Startup manually or restart Outlook.手动运行Application_Startup或重新启动 Outlook。
Note: rerun Application_Startup if/when the event mysteriously stops triggering.注意：如果/当事件神秘地停止触发时，请重新运行Application_Startup 。
Without Private you can assign to a button or call from other code to reduce the downtime.如果没有Private您可以分配给一个按钮或从其他代码调用以减少停机时间。

vba从excel发送带有发件人标志的电子邮件

问题描述

2 个解决方案

解决方案1
0 2020-09-16 22:48:43

解决方案2
0 2020-09-20 00:18:20

vba从excel发送带有发件人标志的电子邮件

问题描述

2 个解决方案

解决方案1 0 2020-09-16 22:48:43

解决方案2 0 2020-09-20 00:18:20

解决方案1
0 2020-09-16 22:48:43

解决方案2
0 2020-09-20 00:18:20