Question

我的VBA体验非常有限。我已经为excel创建了基本的宏，主要是通过frankensteining我在网上找到的多个宏。

这就是我要做的事情。每天早上我都会向200个客户的列表发送一封电子邮件，我从列表中打开新邮件并自动填充邮件（因为它是签名）。目前我会查看所有这些电子邮件并添加我的主题和BCC。我可以创建一个宏来打开所有这些电子邮件，添加我的BCC，添加我的主题，然后发送电子邮件。

非常感谢任何和所有帮助。

Answer 1

以下代码定义Outlook.Application的实例，并设置准备发送的MailItem。它使用一个名为EmailData的Dictionary对象来保存各种信息以填充To，BCC等，但是这些可以用你自己的字符串等替换。我从我写的一个函数中提取了它并使它变得有点更通用：

Public Function OL_SendMail()
Dim bOpenedOutlook, sComputer, iLoop, iAccount, sAttachArray, sAttachment
        bOpenedOutlook = False
        sComputer = "."
        Dim oWMIService : Set oWMIService = GetObject("winmgmts:\\" & sComputer & "\root\cimv2")
        Dim colItems : Set colItems = oWMIService.ExecQuery ("Select * from Win32_Process Where Name = 'outlook.exe'")
        Dim oOutlook : Set oOutlook = CreateObject("Outlook.Application")
        Dim oNamespace : Set oNamespace = oOutlook.GetNamespace("MAPI")
        If colItems.Count = 0 Then
            ' Outlook isn't open, logging onto it...
            oNamespace.Logon "Outlook",,False,True
            bOpenedOutlook = True
        End If
        Dim oFolder : Set oFolder = oNamespace.GetDefaultFolder(olFolderInbox)

    If EmailData("SendFrom") = "" Then
        ' default to first email account the user has access to
        iAccount = 1
    Else
        ' Checking to see if the account to send from is accessible by this user...
        iAccount = 0
        For iLoop = 1 To oOutlook.Session.Accounts.Count
            If UCase(Trim(oOutlook.Session.Accounts.Item(iLoop))) = UCase(Trim(EmailData("SendFrom"))) Then
                iAccount = iLoop
                Exit For
            End If
        Next
        If iAccount = 0 Then
            sErrorMsg = "Cannot send email from specified account: " & EmailData("SendFrom") & " as this user doesn't appear to have access to it in Outlook!"
            OL_SendMail = False
            Exit Function
        End If
    End If

    Dim oMailItem : Set oMailItem = oOutlook.CreateItem(olMailItem)
    With oMailItem
        Set .SendUsingAccount = oOutlook.Session.Accounts.Item(iAccount)
        .To = EmailData("To")
        .CC = EmailData("CC")
        .BCC = EmailData("BCC")
        .Subject = EmailData("Subject")
        .Body = EmailData("Body")
        sAttachArray = Split(EmailData("AttachmentPaths"), ";")
        For Each sAttachment In sAttachArray
            .Attachments.Add(sAttachment)
        Next
        .Recipients.ResolveAll
        .Display    ' debug mode - uncomment this to see email before it's sent out
    End With


'Mail Item created and ready to send
    'oMailItem.Send   ' this is commented out so the mail doesn't auto send, allows checking of it!!
    Set oMailItem = Nothing
    Set oNamespace = Nothing
    If bOpenedOutlook Then
        'oOutlook.Quit
    End If
    Set oOutlook = Nothing
    Set colItems = Nothing
    Set oWMIService = Nothing

    OL_SendMail = True
End Function

打开草稿（或选定的电子邮件）添加BCC，主题和发送

1 个答案: