2013-07-02 223 views
1

我已將此設置爲通過Outlook客戶端自動發送電子郵件,是否可以將此代碼直接通過SMTP服務器更改?任何人都可以幫助我做到這一點?VBScript 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

如果您想直接向SMTP服務器發送郵件,則無需首先通過Outlook。只需使用CDO。這樣的事情:

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

Set msg = CreateObject("CDO.Message") 
msg.Subject = "Test" 
msg.From  = "[email protected]" 
msg.To  = "[email protected]" 
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 
+0

感謝您的答覆,但我不知道如何實施CDO。 –

+1

我包括一個例子和一個頁面的鏈接,有更多的例子。 –

+0

謝謝!!!!!! –