FreeBasic

Обновлено 01.07.2015: Пример ниже от Inutilis уже не работает из-за того, что почти все почтовые сервисы перестали принимать и отправлять письма по протоколу без шифрования. Однако есть способ отправлять письма при помощи библиотек CURL+OPENSSL. В данном архиве лежит пример + необходимые библиотеки dll. Протестировано на версии компилятора 1.02.1  

Пример использует библиотеку DispHelper для отправки письма с вложением. В качестве почтового сервера для примера взят smtp.yandex.ru. 

Автор: Inutilis
Платформа: Windows

#DEFINE unicode
#INCLUDE "disphelper/disphelper.bi"
#undef  unicode

#INCLUDE "file.bi"

Type TEMail
   Private:
      objCDOMessage   As IDispatch Ptr
      strSMTPServer   As String
      strSMTPUsername As String
      strSMTPPassword As String
      strMailFrom     As String
      strMailTo       As String
      strMailSubject  As String
      strMailTextBody As String
   Public:
      Declare Constructor
      Declare Destructor
      Declare Function AddAttachment(FileName As String) As Integer
      Declare Sub Initialize
      Declare Sub Send
      Declare Property SMTPServer(Value As String)
      Declare Property SMTPUsername(Value As String)
      Declare Property SMTPPassword(Value As String)
      Declare Property MailFrom(Value As String)
      Declare Property MailTo(Value As String)
      Declare Property MailSubject(Value As String)
      Declare Property MailTextBody(Value As String)
End Type

Constructor TEMail
   dhInitialize(TRUE)
   dhToggleExceptions(TRUE)
   dhCreateObject("CDO.Message", NULL, @This.objCDOMessage)
End Constructor

Destructor TEMail
   SAFE_RELEASE(This.objCDOMessage)
   dhUninitialize(TRUE)
End Destructor

Sub TEMail.Initialize
   Dim As String Schema, Configuration
   Configuration = ".Configuration.Fields.Item(%s) = "
   Schema        = "http://schemas.microsoft.com/cdo/configuration/"
   dhPutValue(This.objCDOMessage, ".From = %s",  This.strMailFrom)
   dhPutValue(This.objCDOMessage, ".To = %s",  This.strMailTo)
   dhPutValue(This.objCDOMessage, ".Subject = %s",  This.strMailSubject)
   dhPutValue(This.objCDOMessage, ".Textbody = %s",  This.strMailTextBody)
   dhPutValue(This.objCDOMessage, Configuration & "%d", Schema & "sendusing", 2)
   dhPutValue(This.objCDOMessage, Configuration & "%s", Schema & "smtpserver", This.strSMTPServer)
   dhPutValue(This.objCDOMessage, Configuration & "%d", Schema & "smtpserverport", 587)
   dhPutValue(This.objCDOMessage, Configuration & "%d", Schema & "smtpauthenticate", 1)
   dhPutValue(This.objCDOMessage, Configuration & "%s", Schema & "sendusername", This.strSMTPUsername)
   dhPutValue(This.objCDOMessage, Configuration & "%s", Schema & "sendpassword", This.strSMTPPassword)
   dhCallMethod(This.objCDOMessage, ".Configuration.Fields.Update")
End Sub

Function TEMail.AddAttachment(FileName As String) As Integer
   If FileExists(FileName) Then
      dhCallMethod(This.objCDOMessage, ".AddAttachment(%s)", FileName)
      Return 0
   Else
      Return 1
   End If
End Function

Sub TEMail.Send
   dhCallMethod(This.objCDOMessage, ".Send")
End Sub

Property TEMail.SMTPServer(Value As String)
   This.strSMTPServer = Value
End Property

Property TEMail.SMTPUsername(Value As String)
   This.strSMTPUsername = Value
End Property

Property TEMail.SMTPPassword(Value As String)
   This.strSMTPPassword = Value
End Property

Property TEMail.MailFrom(Value As String)
   This.strMailFrom = Value
End Property

Property TEMail.MailTo(Value As String)
   This.strMailTo = Value
End Property

Property TEMail.MailSubject(Value As String)
   This.strMailSubject = Value
End Property

Property TEMail.MailTextBody(Value As String)
   This.strMailTextBody = Value
End Property



Dim As TEMail MyTestMail
Dim As String MyAttachment = "C:\1.txt"

' # Set fields of TEMail
MyTestMail.SMTPServer   = "smtp.yandex.ru"
MyTestMail.SMTPUsername = "Ваш логин на яндексе"
MyTestMail.SMTPPassword = "Ваш пароль на яндексе"
MyTestMail.MailFrom     = "Адрес откуда , например xxxx@yandex.ru" 
MyTestMail.MailTo       = "Адрес куда , например xxxxxx@mail.ru"
MyTestMail.MailSubject  = "Test"
MyTestMail.MailTextBody = "This is a simple testmail."
MyTestMail.Initialize

' # Add Attachment to Mail
If MyTestMail.AddAttachment(MyAttachment) = 0 Then
   Print "Attachment '" & MyAttachment & "' added."
Else
   Print "ERROR: File '" & MyAttachment & "' not found."
End If

' # Send Mail
MyTestMail.Send

' # Destructor
MyTestMail.Destructor