1

我已将其设置为通过 Outlook 客户端自动发送电子邮件，是否可以将此代码更改为直接通过 SMTP 服务器工作？任何人都可以帮助我做到这一点吗？

任何帮助将不胜感激，谢谢！

Set app = CreateObject("Excel.Application")
Set fso = CreateObject("Scripting.FileSystemObject")

For Each f In fso.GetFolder("Y:\Billing_Common\autoemail").Files
  If LCase(fso.GetExtensionName(f)) = "xls" Then
    Set wb = app.Workbooks.Open(f.Path)


set sh = wb.Sheets("Auto Email Script")
row = 2
name = "Customer"
email = sh.Range("A" & row)
subject = "Billing"
the = "the"
LastRow = sh.UsedRange.Rows.Count

For r = row to LastRow
    If App.WorkSheetFunction.CountA(sh.Rows(r)) <> 0 Then 
        SendMessage email, name, subject, TRUE, _
        NULL, "Y:\Billing_Common\autoemail\Script\energia-logo.gif", 143,393
        row = row + 1
        email = sh.Range("A" & row)
    End if
Next
wb.Close
End If
Next

Sub SendMessage(EmailAddress, DisplayName, Subject, DisplayMsg, AttachmentPath, ImagePath, ImageHeight, ImageWidth)

  ' Create the Outlook session.
  Set objOutlook = CreateObject("Outlook.Application")

  template = FindTemplate()

  ' Create the message.
  Set objOutlookMsg  = objOutlook.CreateItem(0)

  With objOutlookMsg
      ' Add the To recipient(s) to the message.
      Set objOutlookRecip = .Recipients.Add(EmailAddress)
      objOutlookRecip.resolve
      objOutlookRecip.Type = 1

     ' Set the Subject, Body, and Importance of the message.
     .Subject = Subject
     .bodyformat = 3
     .Importance = 2  'High importance

     body = Replace(template, "{First}", name)
     body = Replace(body, "{the}", the)

     if not isNull(ImagePath) then
       if not ImagePath = "" then
         .Attachments.add ImagePath
         image = split(ImagePath,"\")(ubound(split(ImagePath,"\")))
         body = Replace(body, "{image}", "<img src='cid:" & image & _
         "'" & " height=" & ImageHeight &" width=" & ImageWidth & ">")
       end if
     else
        body = Replace(body, "{image}", "")
     end if

     if not isNull(AttachMentPath) then
       .Attachments.add AttachmentPath
     end if

     .HTMLBody = body
         .Save
         .Send
    End With
    Set objOutlook = Nothing
End Sub

Function FindTemplate()
    Set OL = GetObject("", "Outlook.Application")
    set Drafts = OL.GetNamespace("MAPI").GetDefaultFolder(16)
    Set oItems = Drafts.Items

    For Each Draft In oItems
        If Draft.subject = "Template" Then
            FindTemplate = Draft.HTMLBody
            Exit Function
        End If
    Next
End Function
4

1 回答 1

5

如果您想直接将邮件发送到 SMTP 服务器，则无需首先通过 Outlook。只需使用CDO。像这样的东西：

schema = "http://schemas.microsoft.com/cdo/configuration/"

Set msg = CreateObject("CDO.Message")
msg.Subject  = "Test"
msg.From     = "sender@example.com"
msg.To       = "recipient@example.org"
msg.TextBody = "This is some sample message text."

With msg.Configuration.Fields
  .Item(schema & "sendusing")      = 2
  .Item(schema & "smtpserver")     = "smtp.intern.example.com"
  .Item(schema & "smtpserverport") = 25
  .Update
End With

msg.Send
于 2013-07-02T12:22:22.467 回答