Отправка почты с вложением файла

← →
duny (2003-10-07 18:26) [0]

Уважаемые мастера помогите начинающему отправить E-mail из моей программы с помощью Outlook Express и к тому-же вставить картинку и сделать вложение файла. Пересмотрел кучу FAQ но не нашел такого.

← →
Hazard (2003-10-08 00:43) [1]

Кусок из моего рабочего Unit"а OutLookUn, реально работает,
Прошу мастеров сильно не ругать, не хватает времени на доработку кода, после сессии обязательно завершу!!!

to Duni: Обязательно должен быть установлен OutLook (я работаю с OutLook2000), и обязательно должны быть установлены ОБЪЕКТЫ СОВМЕСТНОЙ РАБОТЫ (это ставится при установке OutLooka)

unit Outlook_UN;
Interface
uses
SysUtils, Variants, Classes,
Dialogs, Outlook8, OleServer;

type //Класс для создания почтовых сообщений
TSMail = class(TObject)

procedure ClearAttachList;
procedure ClearBodyLetter;

procedure CreateMessage;
Constructor Create;
Destructor Destroy;
private
MailToList :TStrings;
AttachList :TStrings;
BodyLetter :TStrings;
MailFrom :String;
ThemeLetter:String;
FaceBody :String;
procedure putAttachList(NewAttach:TStrings);
function getAttachList: TStrings;
procedure putBodyLetter(New_Body:TStrings);
function getBodyLetter:TStrings;
procedure Put_MailTo(E_Mail:TStrings);
function Get_MailTo:TStrings;
procedure Put_MailFrom(E_Mail:String);
function Get_MailFrom:String;

public
property SetThemeLetter: String write ThemeLetter;
property SetFaceBody : String write FaceBody;
property New_Attachment: TStrings read getAttachList write putAttachList;
property New_BodyLetter: TStrings read getBodyLetter write putBodyLetter;
property E_MailTo : TStrings read Get_MailTo write Put_MailTo;
property E_MailFrom : String read Get_MailFrom write Put_MailFrom;
end;

type //Адресная книга
TAdressBook = class (TObject)
private
AddressList:TStrings;
public
procedure Execute;
property AddressBook: TStrings read AddressList;
constructor Create;
Destructor Destroy;
end;

//--------------------------------------------------TSMail----------------------
procedure TSMail.Put_MailTo(E_Mail:TStrings);
Begin
MailToList:=E_Mail;
end;

function TSMail.Get_MailTo:TStrings;
Begin
Result:=MailToList;
end;

procedure TSMail.Put_MailFrom(E_Mail:String);
Begin
MailFrom:=E_Mail;
end;

function TSMail.Get_MailFrom:String;
Begin
Result:=MailFrom;
end;

function TSMail.getAttachList:TStrings;
Begin
Result:=AttachList;
end;

procedure TSMail.putAttachList(NewAttach:TStrings);
Begin
AttachList:=NewAttach;
end;

function TSMail.getBodyLetter:TStrings;
Begin
Result:=BodyLetter;
end;

procedure TSMail.putBodyLetter(New_Body:TStrings);
Begin
BodyLetter:=New_Body;
end;

procedure TSMail.ClearBodyLetter;
Begin
BodyLetter.Clear;
end;

procedure TSMail.ClearAttachList;
Begin
AttachList.Clear;
end;
//------------------------------------------------------------------------------
procedure TSMail.CreateMessage;
const
// константы OlItemType
olMailItem = 0;
olAppointmentItem = 1;
olContactItem = 2;
olTaskItem = 3;
olJournalItem = 4;
olNoteItem = 5;
olPostItem = 6;
// константы OlAttachmentType
olByValue = 1;
olByReference = 4;
olEmbeddedItem = 5;
olOLE = 6;
var
myOlApp, myItem, myRecipient, myAttachments: oleVariant;
i:Word;
BodyString:String;
Begin
CoInitialize(nil);
myOlApp := CreateOLEObject("Outlook.Application");
myItem := myOlApp.CreateItem(olMailItem);

myItem.Subject :=ThemeLetter;

if MailToList.Count>0 then Begin
if MailToList.Count=1 then myRecipient := myItem.Recipients.Add(MailToList.Strings[0])
else
for i:=0 to MailToList.Count-1 do Begin
myRecipient := myItem.Recipients.Add(MailToList.Strings[i]);
end;
end;{if}

myItem.Body := #13;
myItem.Body := myItem.Body + #13;
myItem.Body := myItem.Body + #13+FaceBody+ #13;

if BodyLetter.Count>0 then Begin
if BodyLetter.Count=1 then BodyString:=BodyString+BodyLetter.Strings[0]+#13
else
for i:=0 to BodyLetter.Count-1 do Begin
BodyString:=BodyString+BodyLetter.Strings[i]+#13;
end;
myItem.Body :=myItem.Body+#13+BodyString+#13;
end;{if}

myAttachments := myItem.Attachments;

if AttachList.Count>0 then Begin
for i:=0 to AttachList.Count-1 do Begin
myAttachments.Add(AttachList.Strings[i] , olByValue, i+1,ExtractFileName(AttachList.Strings[i]));
end;
end;{if}
myItem.Send;
myOlApp := VarNull;
myItem := VarNull;
myRecipient := VarNull;
myAttachments := VarNull;
CoUninitialize;
end;

Constructor TSMail.Create;
Begin
Inherited;
AttachList:=TStringList.Create;
BodyLetter:=TStringList.Create;
MailToList:=TStringList.Create;
end;

Destructor TSMail.Destroy;
Begin
AttachList.Free;
BodyLetter.Free;
MailToList.Free;
Free;
end;

//-----------------------------------------TAddressBook-------------------------

procedure TAdressBook.Execute;
var
MSOutlook, MyNameSpace, MyFolder, MyItem: Variant;
i:Integer;
begin
Try
MSOutlook := CreateOleObject("Outlook.Application");
MyNameSpace := MSOutlook.GetNameSpace("MAPI");
MyFolder := MyNamespace.GetDefaultFolder(olFolderContacts);
for i := 1 to MyFolder.Items.Count do
begin
MyItem := MyFolder.Items[i];
AddressList.Add(MyItem.Subject+#14+MyItem.Email1Address+#14);
end;
MSOutlook.Quit;
Except
ShowMessage("ошибка# - не установлен Outlook");
end;
end;

Constructor TAdressBook.Create;
Begin
Inherited;
AddressList:=TStringList.Create;
end;

Destructor TAdressBook.Destroy;
Begin
AddressList.Free;
Free;
end;
//------------------------------------------------------------------------------

и примеры вызова

Создание сообщения...

procedure ....
Var
m :TSMail;
Begin
m:=TSMail.Create;
With m do Begin
New_Attachment :=...... ; //Прикрепляемые файлы (путь до них)
E_MailTo :=...... ; //кому отправляешь
SetThemeLetter :=...... ; //тема письма
SetFaceBody :=...... ; //не обязательно (этот прибабмбас только для специфики моей программы)
New_BodyLetter :=...... ; //текст письма
CreateMessage;
m.Free;
end;
end;

Адресная книга...

procedure ...
Var
AddrBook_OBJ :TAdressBook;
MailList:TStrings;

Begin
MailList:=TStrinsList.Create;
AddrBook_OBJ:=TAdressBook.Create;
AddrBook_OBJ.Execute;
MailList.Clear;
MailList:=AddrBook_OBJ.AddressBook;//Берем адреса из OutLook"а
.....
end;

P.S.
Вроде бы как ничего не забыл :/

← →
Hazard (2003-10-08 00:54) [2]

Да, надо было еще сказать что просто OutLook Express не представляет таких сервисов доступа к своим данным и это возможно только через OutLook из пакета MSOffice

Данный код основан на примере Eddie Shipman"а

Создаётся OLE-объект - "Outlook.Application" и в него передаётся VB Script

← →
duny (2003-10-08 14:34) [3]

У меня вот такой код
procedure TfmTable.SpeedButton1Click(Sender: TObject);
var Adres, Tema, String1,String2, mailstring: string;
begin
Adres:= dm.iPersonal["E_MAIL"];
Tema := "Прайс лист маг. "Good Year" "+DateToStr(Date);
String1 := "Здравствуйте! ";
String2 := "Смотрите, выбирайте,звоните. (0562) 454005, 366674 ";
// Хотелось бы ещё сюда сделать вложение
mailstring := "mailto:" + Adres +
"?subject=" + Tema +
"&body=" + String1 +
"%0D%0A" + String2;
ShellExecute(0, "open", PChar(mailstring), "", "",SW_SHOWNORMAL)
end;

Я так понял что просто не получится.
Спасибо всем кто ответил. Буду разбираться с Outlook_ом из Офиса

← →
Lola (2003-10-08 15:34) [4]

А что ты испугался? Довольно просто всё. Только тебе Hazard много лишнего написал (видимо свои моменты не выгрызал) А так сама процедура отправки небольшая.

procedure TForm1.btSendClick(Sender: TObject);
const
// константы OlItemType
olMailItem = 0;
olAppointmentItem = 1;
olContactItem = 2;
olTaskItem = 3;
olJournalItem = 4;
olNoteItem = 5;
olPostItem = 6;
// константы OlAttachmentType
olByValue = 1;
olByReference = 4;
olEmbeddedItem = 5;
olOLE = 6;
var
myOlApp, myItem, myRecipient, myAttachments: OleVariant;
begin

// файл VBScript для создания почтового сообщения и прикрепления к нему файла
myOlApp := CreateOLEObject("Outlook.Application");
myItem := myOlApp.CreateItem(olMailItem);
myItem.Subject := "This is the Subject";
varRecipient:=Edit7.Text ;
myRecipient := myItem.Recipients.Add(varRecipient); //pcemoscow@pcelimited.com
myItem.Body := #13;
myItem.Body := myItem.Body + " "; // Hello!
{ myItem.Body := myItem.Body + "This code created this message and "+" sent it and I didn""t even have" + #13;
myItem.Body := myItem.Body + "to click the send button!!!" + #13; }

// Теперь прикрепим файлы...
myAttachments := myItem.Attachments;
myAttachments.Add(FileName1, olByValue, 1, FileName1+" Attachment"); // FileName1 - имя прикрепляемого файла с маршрутом
myItem.Send ;
myOlApp := VarNull;
myItem := VarNull;
myRecipient := VarNull;
myAttachments := VarNull;
myOlApp := Unassigned;

end;

Вот и всё.

← →
Lola (2003-10-08 15:36) [5]

Да, еще здесь в FAQ есть процедура проверки правильности e-mail адресов, её тоже полезно использовать.

Отправка почты с вложением файла Найти похожие ветки