使用 Excel VBA 在 Outlook 上创建新的草稿文件夹

Question

此代码根据我制作的模板和 Excel 表格中的信息（邮件的 MailtTo 和主题行）生成一封电子邮件。

它保存在 Outlook 中的草稿文件夹中，以便稍后发送。

如何在 Outlook 中创建一个名为“重新分类”的新文件夹，该文件夹仍属于这些电子邮件将转到的草稿类别？

Option Explicit
'Enumeration is by definition the action of establishing the number of something
'I Enumerated my Worksheet Columns to give them a meaningful name
'  that is easy to recognize so if the amount is ever moved

Public Enum EmailColumn
    ecEmailAdresses = 17
    ecSubject = 43
End Enum

Public Sub SaveEmails()

    Dim ReCol As Range                           'Relcass Column Range

    'For Eeach: picking up the reclass section on the OP Report as a renage
    For Each ReCol In Worksheets("Report").Range("AP1:AP1047900")

        'If:Running through Reclass column for only Y respones
        If ReCol = "Y" Then

            'The With Statement allows the user to
            ' "Perform a series of statements on a specified object without
            ' specifying the name of the object multiple times"
            '.Cells(.Row.Count, ecEmailAdresses).End(xlUp).Row actually refers to
            ' ThisWorkbook.Worksheets("Data insert").Cells(.Rows.Count, ecEmailAdresses).End(xlUp).Row

            With ThisWorkbook.Worksheets("Report")

                '.Cells(.Rows.Count, ecEmailAdresses): References the last cell in column 43 of the worsheet
                '.End(xlUp): Changes the reference from the last cell to the first used cell above the last cell in column 44
                '.Cells(.Rows.Count, ecEmailAdressess).End(xlUp).Row: returns the Row number of the last cell column 44
                getTemplate(MailTo:=.Cells(ReCol.Row, ecEmailAdresses), Subject:=.Cells(ReCol.Row, ecSubject)).Save

            End With

        End If

    Next

End Sub

Public Function getTemplate(MailTo As String, Optional CC As String, Optional BC As String, Optional Subject As String) As Object
    Const TEMPLATE_PATH As String = "C:\Users\JohnDoe\Documents\Project\Email Template.oft"

    Dim OutApp As Object
    Dim OutMail As Object

    'CreateObject("Outlook.Application"): Creates an instance of an Outlook Application.
    'Outlook.Application.CreatItemFromTemplate returns a new MailItem Based on a saved email Template
    Set OutMail = CreateObject("Outlook.Application").CreateItemFromTemplate(TEMPLATE_PATH)

    With OutMail
        .To = MailTo
        .CC = CC
        .BCC = BC
        .Subject = Subject
    End With

    'Returns the new MailItem to the caller of the function
    Set getTemplate = OutMail

End Function

Answer 1

首先，您需要检查目标文件夹是否存在。 GetDefaultFolder 方法返回一个Folder 对象，该对象代表当前配置文件所请求类型的默认文件夹；例如，获取当前登录用户的默认日历文件夹。

Sub ChangeCurrentFolder() 
  Dim myNamespace As Outlook.NameSpace 
  Set myNamespace = Application.GetNamespace("MAPI") 
  Set Application.ActiveExplorer.CurrentFolder = _ myNamespace.GetDefaultFolder(olFolderDrafts) 
End Sub

使用Folders 属性获取子文件夹的集合。 Folders.Add 方法在 Folders 集合中创建一个新文件夹。

Sub AddContactsFolder() 
  Dim myNameSpace As Outlook.NameSpace 
  Dim myFolder As Outlook.Folder 
  Dim myNewFolder As Outlook.Folder 

  Set myNameSpace = Application.GetNamespace("MAPI") 
  Set myFolder = myNameSpace.GetDefaultFolder(olFolderDrafts) 
  Set myNewFolder = myFolder.Folders.Add("My subfolder") 
End Sub

要将新邮件项保存到特定文件夹，您需要使用Move 方法，如以下示例代码所示：

Imports System.Runtime.InteropServices
' ...
Private Sub CreateItemBasedOnTemplate(Application As Outlook.Application)
  Dim ns As Outlook.NameSpace = Nothing
  Dim containerFolder As Outlook.MAPIFolder = Nothing
  Dim item As Outlook.MailItem = Nothing
  Dim movedItem As Outlook.MailItem = Nothing
  Try
    ns = Application.GetNamespace("MAPI")
    containerFolder = ns.GetDefaultFolder(Outlook.OlDefaultFolders.olFolderInbox)
    item = Application.CreateItemFromTemplate("D:\MyTemplate.oft", containerFolder)
    ' the item was created in the Drafts folder regardless
    ' that is why we move it to the Inbox folder
    movedItem = item.Move(containerFolder)
    movedItem.Save()
    movedItem.Display()
  Catch ex As COMException
    If (ex.ErrorCode = -2147287038) Then
       System.Windows.Forms.MessageBox.Show(ex.Message,
           "Can't find the template...")
    Else
       System.Windows.Forms.MessageBox.Show(ex.Message,
           "An error was occurred when creating a new item from template...")
    End If
  Finally
    If Not IsNothing(movedItem) Then Marshal.ReleaseComObject(movedItem)
    If Not IsNothing(item) Then Marshal.ReleaseComObject(item)
    If Not IsNothing(containerFolder) Then Marshal.ReleaseComObject(containerFolder)
    If Not IsNothing(ns) Then Marshal.ReleaseComObject(ns)
  End Try
End Sub

How To: Create a new Outlook message based on a template 文章可能对您有所帮助。