VBScript SMTP-сервер

Question

Я установил это для автоматической электронной почты через клиент 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 

Answer 1

Если вы хотите отправить почту непосредственно на 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