VPF::Полноценный почтовый клиент? - Форум программистов

WaReZMEN

Дата 6.3.2009, 15:51 (ссылка)

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

Загрузка ...

Опытный

Профиль
Группа: Участник
Сообщений: 683
Регистрация: 9.6.2006
Где: Россия, Санкт-Пет ербург

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

Может есть у кого полноценный почтовый клиент? Разумеется исходник. Сам когда то писал но сталкивался с кучей проблем касающихся отправки сообщение на русском языке и с вложенными файлами. Буду рад любой помощи...

Bose

Дата 6.3.2009, 18:41 (ссылка)

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

Загрузка ...

Эксперт

Профиль
Группа: Участник Клуба
Сообщений: 1458
Регистрация: 5.3.2005
Где: Riga, Latvia

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

WaReZMEN, посмотри на SourceForge.net "Phoenix Mail"
http://sourceforge.net/projects/phxmail/

Лицензия - GPL. Что означает, что ты обязан открыть весь свой код использующий хотя бы одну строку из этого редактора. =)

Это сообщение отредактировал(а) Bose - 6.3.2009, 18:45

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

Лучшее о Delphi за 2013 год. Подборка ссылок.

mr_smit

Дата 8.3.2009, 01:34 (ссылка)

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

Загрузка ...

Опытный

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

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

Держи.

Присоединённый файл ( Кол-во скачиваний: 80 )

StudMailer.zip 391,25 Kb

WaReZMEN

Дата 10.3.2009, 09:05 (ссылка)

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

Загрузка ...

Опытный

Профиль
Группа: Участник
Сообщений: 683
Регистрация: 9.6.2006
Где: Россия, Санкт-Пет ербург

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

Bose,
mr_smit, Спасибо вам!
Вот вопрос возник какои индеец там заюзан у меня вот эти компоненты не видет:
TIdAttachment, TIdText

а на IdTCPClient.WriteLn ругается на WriteLn но это я поправил на IdTCPClient.IOHandler.WriteLn.
Я так понял это все под Indy 9 а под 10 нет ничего????

Это сообщение отредактировал(а) WaReZMEN - 10.3.2009, 13:04

WaReZMEN

Дата 10.3.2009, 13:14 (ссылка)

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

Загрузка ...

Опытный

Профиль
Группа: Участник
Сообщений: 683
Регистрация: 9.6.2006
Где: Россия, Санкт-Пет ербург

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

Сам все поправил вот unit для Indy 10

Код


unit uMain;

interface

uses
  Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,
  Dialogs, ComCtrls, ImgList, IdBaseComponent, IdComponent,
  IdTCPConnection, IdTCPClient, StdCtrls, Spin, Buttons, ExtCtrls,
  IdMessage, idAttachmentFile, IdText;

type
  TfmMain = class(TForm)
    pcMain: TPageControl;
    tsSend: TTabSheet;
    tsGet: TTabSheet;
    IdTCPClient: TIdTCPClient;
    laServer: TLabel;
    edServer: TEdit;
    laPort: TLabel;
    sedPort: TSpinEdit;
    cbAuthetication: TCheckBox;
    laLogin: TLabel;
    edLogin: TEdit;
    edPassword: TEdit;
    laPassword: TLabel;
    edRetAddress: TEdit;
    laRetAddress: TLabel;
    laTo: TLabel;
    edTo: TEdit;
    laSubj: TLabel;
    edSubj: TEdit;
    laText: TLabel;
    memText: TMemo;
    laAttachments: TLabel;
    lvAttachments: TListView;
    sbtAdd: TSpeedButton;
    sbtDelete: TSpeedButton;
    odMain: TOpenDialog;
    sbtSend: TSpeedButton;
    sbtShowLog: TSpeedButton;
    laDeveloper: TLabel;
    laName: TLabel;
    laMadeInRussia: TLabel;
    imgFlag: TImage;
    laWebSiteAddress: TLabel;
    sbtGet: TSpeedButton;
    laPOPServer: TLabel;
    edPOPServer: TEdit;
    sedPOPPort: TSpinEdit;
    laPOPPort: TLabel;
    laPOPLogin: TLabel;
    edPOPLogin: TEdit;
    edPOPPassword: TEdit;
    laPOPPassword: TLabel;
    laMailAttachments: TLabel;
    lvMailAttachments: TListView;
    laMailText: TLabel;
    memMailText: TMemo;
    lvMails: TListView;
    laMails: TLabel;
    sbtSaveAttach: TSpeedButton;
    IdMessage1: TIdMessage;
    sdMain: TSaveDialog;
    procedure cbAutheticationClick(Sender: TObject);
    procedure sbtAddClick(Sender: TObject);
    procedure sbtDeleteClick(Sender: TObject);
    procedure sbtShowLogClick(Sender: TObject);
    procedure sbtSendClick(Sender: TObject);
    procedure FormCreate(Sender: TObject);
    procedure lvAttachmentsSelectItem(Sender: TObject; Item: TListItem;
      Selected: Boolean);
    procedure laWebSiteAddressMouseEnter(Sender: TObject);
    procedure laWebSiteAddressMouseLeave(Sender: TObject);
    procedure laWebSiteAddressClick(Sender: TObject);
    procedure lvMailAttachmentsSelectItem(Sender: TObject; Item: TListItem;
      Selected: Boolean);
    procedure sbtGetClick(Sender: TObject);
    procedure lvMailsSelectItem(Sender: TObject; Item: TListItem;
      Selected: Boolean);
    procedure sbtSaveAttachClick(Sender: TObject);
  private
    procedure AddLineToLog(const sIn: String);
    procedure EnableControls(bEnable: boolean);
    procedure LogAllIncoming;
    procedure LogOutcoming(const s: String);
    function CheckPOPResponse: boolean;
    procedure ParseMail(const s: String);
    procedure EnablePOPControls(bEnable: boolean);
  public
  end;

var
  fmMain: TfmMain;

implementation

uses
  ShellAPI, uLog, DIMime;

{$R *.dfm}

procedure TfmMain.AddLineToLog(const sIn: String);
begin
  fmLog.memMain.Lines.Add(sIn);
end;

procedure TfmMain.EnableControls(bEnable: boolean);
begin
  laServer.Enabled:=bEnable;
  edServer.Enabled:=bEnable;
  if bEnable then
    edServer.Color:=clWindow
  else
    edServer.Color:=clBtnFace;

  laPort.Enabled:=bEnable;
  sedPort.Enabled:=bEnable;
  if bEnable then
    sedPort.Color:=clWindow
  else
    sedPort.Color:=clBtnFace;

  laTo.Enabled:=bEnable;
  edTo.Enabled:=bEnable;
  if bEnable then
    edTo.Color:=clWindow
  else
    edTo.Color:=clBtnFace;

  laRetAddress.Enabled:=bEnable;
  edRetAddress.Enabled:=bEnable;
  if bEnable then
    edRetAddress.Color:=clWindow
  else
    edRetAddress.Color:=clBtnFace;

  cbAuthetication.Enabled:=bEnable;

  if bEnable then
    cbAutheticationClick(Self)
  else
    begin
      laLogin.Enabled:=false;
      edLogin.Enabled:=false;
      edLogin.Color:=clBtnFace;

      laPassword.Enabled:=false;
      edPassword.Enabled:=false;
      edPassword.Color:=clBtnFace;
    end;

  laSubj.Enabled:=bEnable;
  edSubj.Enabled:=bEnable;
  if bEnable then
    edSubj.Color:=clWindow
  else
    edSubj.Color:=clBtnFace;

  laText.Enabled:=bEnable;
  memText.Enabled:=bEnable;

  laAttachments.Enabled:=bEnable;
  lvAttachments.Enabled:=bEnable;

  sbtAdd.Enabled:=bEnable;
  if bEnable then
    sbtDelete.Enabled:=lvAttachments.SelCount > 0
  else
    sbtDelete.Enabled:=false;
  sbtSend.Enabled:=bEnable;
end;

procedure TfmMain.cbAutheticationClick(Sender: TObject);
var
  bEnable: boolean;
begin
  bEnable:=cbAuthetication.Checked;

  laLogin.Enabled:=bEnable;
  edLogin.Enabled:=bEnable;
  if bEnable then
    edLogin.Color:=clWindow
  else
    edLogin.Color:=clBtnFace;

  laPassword.Enabled:=bEnable;
  edPassword.Enabled:=bEnable;
  if bEnable then
    edPassword.Color:=clWindow
  else
    edPassword.Color:=clBtnFace;
end;

procedure TfmMain.sbtAddClick(Sender: TObject);
var
  i: Integer;
begin
  if odMain.Execute then
    for i:=0 to odMain.Files.Count-1 do
      with lvAttachments.Items.Add do
        begin
          Caption:=ExtractFileName(odMain.Files[i]);
          SubItems.Add(odMain.Files[i]);
        end;
end;

procedure TfmMain.sbtDeleteClick(Sender: TObject);
begin
  lvAttachments.DeleteSelected;
end;

procedure TfmMain.sbtShowLogClick(Sender: TObject);
begin
  if fmLog.Visible then
    fmLog.SetFocus
  else
    fmLog.Visible:=true;
end;

function ReadFileIntoString(const sFilePath: String): String;
var
  FileSize: Integer;
  DataFile: Integer;
begin
  DataFile:=FileOpen(sFilePath, fmOpenRead);
  if DataFile = -1 then
    Exit;
  FileSize:=FileSeek(DataFile, 0, 2);
  FileSeek(DataFile, 0, 0);
  try
    SetLength(Result, FileSize);
    FileRead(DataFile, Pointer(Result)^, FileSize);
  finally
    FileClose(DataFile);
  end;
end;

procedure TfmMain.LogAllIncoming;
var
  i: Integer;
begin
  for i:=0 to IdTCPClient.LastCmdResult.Text.Count-1 do
    AddLineToLog('< '+IdTCPClient.LastCmdResult.Text[i]);
end;

procedure TfmMain.LogOutcoming(const s: String);
var
  SL: TStringList;
  i: Integer;
begin
  SL:=TStringList.Create;
  try
    SL.Text:=s;
    for i:=0 to SL.Count-1 do
      AddLineToLog('> '+SL[i]);
  finally
    SL.Free;
  end;
end;

procedure TfmMain.sbtSendClick(Sender: TObject);
var
  ts: String;
  i: Integer;

  sBoundary: String;
begin
  EnableControls(false);
  try
    sbtShowLog.Click;
    
    IdTCPClient.Host:=edServer.Text;
    IdTCPClient.Port:=sedPort.Value;
    IdTCPClient.Connect;
    IdTCPClient.GetResponse([220]);
    LogAllIncoming;

    LogOutcoming('HELO StudForum.ru');
    IdTCPClient.SendCmd('HELO StudForum.ru', 250);
    LogAllIncoming;

    if cbAuthetication.Checked then
      begin
        LogOutcoming('AUTH LOGIN');
        IdTCPClient.SendCmd('AUTH LOGIN', 334);
        LogAllIncoming;

        ts:=MimeEncodeString(edLogin.Text);
        LogOutcoming(ts);
        IdTCPClient.SendCmd(ts, 334);
        LogAllIncoming;

        ts:=MimeEncodeString(edPassword.Text);
        LogOutcoming(ts);
        IdTCPClient.SendCmd(ts, 235);
        LogAllIncoming;
      end;

    LogOutcoming('MAIL FROM:<'+edRetAddress.Text+'>');
    IdTCPClient.SendCmd('MAIL FROM:<'+edRetAddress.Text+'>', 250);
    LogAllIncoming;

    LogOutcoming('RCPT TO:<'+edTo.Text+'>');
    IdTCPClient.SendCmd('RCPT TO:<'+edTo.Text+'>', [250, 251]);
    LogAllIncoming;

    LogOutcoming('DATA');
    IdTCPClient.SendCmd('DATA', 354);
    LogAllIncoming;

    LogOutcoming('X-Mailer: StudMailer');
    IdTCPClient.IOHandler.WriteLn('X-Mailer: StudMailer');

    LogOutcoming('From: '+edRetAddress.Text);
    IdTCPClient.IOHandler.WriteLn('From: '+edRetAddress.Text);

    LogOutcoming('To: '+edTo.Text);
    IdTCPClient.IOHandler.WriteLn('To: '+edTo.Text);

    if lvAttachments.Items.Count > 0 then
      begin
        sBoundary:='StudMailer_by_StudForum.RU';
        LogOutcoming('MIME-Version: 1.0'#13#10'Content-Type: multipart/mixed; boundary="'+sBoundary+'"');
        IdTCPClient.IOHandler.WriteLn('MIME-Version: 1.0'#13#10'Content-Type: multipart/mixed; boundary="'+sBoundary+'"');
      end
    else
      begin
        LogOutcoming('MIME-Version: 1.0'#13#10'Content-Type: text/plain; charset=windows-1251');
        IdTCPClient.IOHandler.WriteLn('MIME-Version: 1.0'#13#10'Content-Type: text/plain; charset=windows-1251');
      end;


    LogOutcoming('Subject: '+edSubj.Text+#13#10#13#10);
    IdTCPClient.IOHandler.WriteLn('Subject: '+edSubj.Text+#13#10);

    if lvAttachments.Items.Count > 0 then
      begin
        LogOutcoming('--'+sBoundary+#13#10#13#10);
        IdTCPClient.IOHandler.WriteLn('--'+sBoundary+#13#10);
      end;

    LogOutcoming(memText.Lines.Text);
    IdTCPClient.IOHandler.WriteLn(memText.Lines.Text);

    for i:=0 to lvAttachments.Items.Count-1 do
      begin
        LogOutcoming('--'+sBoundary);
        IdTCPClient.IOHandler.WriteLn('--'+sBoundary);


        LogOutcoming('Content-Type: application/octet-stream; name="'+lvAttachments.Items[i].Caption+'"'#13#10+
'Content-Disposition: attachment; filename="'+lvAttachments.Items[i].Caption+'"'#13#10+
'Content-Transfer-Encoding: base64'#13#10#13#10);
        IdTCPClient.IOHandler.WriteLn('Content-Type: application/octet-stream; name="'+lvAttachments.Items[i].Caption+'"'#13#10+
'Content-Disposition: attachment; filename="'+lvAttachments.Items[i].Caption+'"'#13#10+
'Content-Transfer-Encoding: base64'#13#10);

        ts:=MimeEncodeString(ReadFileIntoString(lvAttachments.Items[i].SubItems[0]));
        LogOutcoming(ts);
        IdTCPClient.IOHandler.WriteLn(ts);
      end;                  

    LogOutcoming('.');
    IdTCPClient.SendCmd('.', 250);
    LogAllIncoming;

    LogOutcoming('QUIT');
    IdTCPClient.IOHandler.WriteLn('QUIT');
  finally
    IdTCPClient.Disconnect;
    EnableControls(true);
  end;
end;         

procedure AddDisabledBMP(SB: array of TObject);
var
  BM, SBM: TBitmap;
  w, x, y, NewColor, i: Integer;
  PixelColor: TColor;
begin
  BM:=TBitmap.Create;
  SBM:=TBitmap.Create;

  try
    for i:=0 to High(SB) do
      begin
        if (SB[i] is TSpeedButton) then
          BM.Assign((SB[i] as TSpeedButton).Glyph)
        else
          if (SB[i] is TBitBtn) then
            BM.Assign((SB[i] as TBitBtn).Glyph)
          else
            Exit;

        if not Assigned(BM) or (BM.Width <> BM.Height) then Exit;

        w:=BM.Width;
        SBM.Width:=w*2;
        SBM.Height:=w;
        SBM.Canvas.Draw(0, 0, BM);

          for x:=0 to w - 1 do
            for y:=0 to w - 1 do begin
              PixelColor:=ColorToRGB(BM.Canvas.Pixels[x, y]);
              NewColor:=Round((((PixelColor shr 16) + ((PixelColor shr 8) and $00FF) +
                         (PixelColor and $0000FF)) div 3)) div 2 + 96;
              BM.Canvas.Pixels[x, y]:=RGB(NewColor, NewColor, NewColor);
            end;

        SBM.Canvas.Draw(w, 0, BM);

        if (SB[i] is TSpeedButton) then
          with (SB[i] as TSpeedButton) do
            begin
              Glyph.Assign(SBM);
              NumGlyphs:=2;
            end
        else
          with (SB[i] as TBitBtn) do
            begin
              Glyph.Assign(SBM);
              NumGlyphs:=2;
            end;

        BM:=TBitmap.Create;
        SBM:=TBitmap.Create;
      end;
  finally
    BM.Free;
    SBM.Free;
  end;
end;

procedure TfmMain.FormCreate(Sender: TObject);
begin
  AddDisabledBMP([sbtAdd, sbtDelete, sbtSend, sbtSaveAttach, sbtGet])
end;

procedure TfmMain.lvAttachmentsSelectItem(Sender: TObject; Item: TListItem;
  Selected: Boolean);
begin
  sbtDelete.Enabled:=lvAttachments.SelCount > 0;
end;

procedure TfmMain.laWebSiteAddressMouseEnter(Sender: TObject);
begin
  (Sender as TLabel).Font.Color:=clRed;
end;

procedure TfmMain.laWebSiteAddressMouseLeave(Sender: TObject);
begin
  (Sender as TLabel).Font.Color:=clBlue;
end;

procedure TfmMain.laWebSiteAddressClick(Sender: TObject);
begin
  ShellExecute(Application.Handle, PChar('open'), PChar('http://www.studforum.ru'), nil, nil, SW_NORMAL);
end;

procedure TfmMain.lvMailAttachmentsSelectItem(Sender: TObject; Item: TListItem;
  Selected: Boolean);
begin
  sbtSaveAttach.Enabled:=lvMailAttachments.SelCount > 0;
end;

function TfmMain.CheckPOPResponse: boolean;
begin
  IdTCPClient.GetInternalResponse;
  if AnsiSameText(IdTCPClient.LastCmdResult.Code, '+OK') then
    Result:=true
  else
    Result:=false;
end;

procedure TfmMain.ParseMail(const s: String);
var
  i: Integer;
  Stream: TMemoryStream;
begin
  memMailText.Clear;
  lvMailAttachments.Clear;

  Stream:=TMemoryStream.Create;
  try
    Stream.Write(s[1], Length(s));
    Stream.Seek(0, soFromBeginning);
    IdMessage1.LoadFromStream(Stream);

    if IdMessage1.MessageParts.Count = 0 then
      memMailText.Lines.AddStrings(IdMessage1.Body)
    else
      for i:=0 to IdMessage1.MessageParts.Count-1 do
        if IdMessage1.MessageParts[i] is TIdAttachmentFile then
          with lvMailAttachments.Items.Add do
            Caption:=(IdMessage1.MessageParts[i] as TIdAttachmentFile).FileName
        else
          if IdMessage1.MessageParts[i] is TIdText then
            memMailText.Lines.AddStrings((IdMessage1.MessageParts[i] as TIdText).Body);
  finally
    Stream.Free;
  end;
end;

procedure TfmMain.EnablePOPControls(bEnable: boolean);
begin
  laPOPServer.Enabled:=bEnable;
  edPOPServer.Enabled:=bEnable;
  if bEnable then
    edPOPServer.Color:=clWindow
  else
    edPOPServer.Color:=clBtnFace;

  laPOPPort.Enabled:=bEnable;
  sedPOPPort.Enabled:=bEnable;
  if bEnable then
    sedPOPPort.Color:=clWindow
  else
    sedPOPPort.Color:=clBtnFace;

  laPOPLogin.Enabled:=bEnable;
  edPOPLogin.Enabled:=bEnable;
  if bEnable then
    edPOPLogin.Color:=clWindow
  else
    edPOPLogin.Color:=clBtnFace;

  laPOPPassword.Enabled:=bEnable;
  edPOPPassword.Enabled:=bEnable;
  if bEnable then
    edPOPPassword.Color:=clWindow
  else
    edPOPPassword.Color:=clBtnFace;

  sbtGet.Enabled:=bEnable;
end;

procedure TfmMain.sbtGetClick(Sender: TObject);
var
  iMesCount, i: Integer;
  ts, sFrom, sTo, sSubj: String;
  slTemp: TStringList;
begin
  EnablePOPControls(false);
  try
    lvMails.Clear;
    memMailText.Clear;
    lvMailAttachments.Clear;

    sbtShowLog.Click;

    IdTCPClient.Host:=edPOPServer.Text;
    IdTCPClient.Port:=sedPOPPort.Value;
    IdTCPClient.Connect;
    if not CheckPOPResponse then
      Exit;
    LogAllIncoming;

    LogOutcoming('USER '+edPOPLogin.Text);
    IdTCPClient.IOHandler.WriteLn('USER '+edPOPLogin.Text);
    if not CheckPOPResponse then
      Exit;
    LogAllIncoming;

    LogOutcoming('PASS '+edPOPPassword.Text);
    IdTCPClient.IOHandler.WriteLn('PASS '+edPOPPassword.Text);
    if not CheckPOPResponse then
      Exit;
    LogAllIncoming;

    LogOutcoming('STAT');
    IdTCPClient.IOHandler.WriteLn('STAT');
    if not CheckPOPResponse then
      Exit;
    LogAllIncoming;

    iMesCount:=0;
    ts:=IdTCPClient.LastCmdResult.Text[0];
    Delete(ts, 1, 4);
    if Length(ts) > 0 then
      iMesCount:=StrToInt(Copy(ts, 1, Pos(' ', ts)-1));

    slTemp:=TStringList.Create;
    try
      for i:=1 to iMesCount do
        begin
          LogOutcoming('RETR '+IntToStr(i));
          IdTCPClient.IOHandler.WriteLn('RETR '+IntToStr(i));
          if not CheckPOPResponse then
            Exit;
          LogAllIncoming;

          slTemp.Clear;
          ts:='';
          sFrom:='';
          sTo:='';
          sSubj:='';

          while ts <> '.' do
            begin
              ts:=IdTCPClient.IOHandler.ReadLn;
              if Copy(UpperCase(ts), 1, 5)='FROM:' then
                 sFrom:=Trim(Copy(ts, 6, MaxInt));
              if Copy(UpperCase(ts), 1, 3)='TO:' then
                 sTo:=Trim(Copy(ts, 4, MaxInt));
              if Copy(UpperCase(ts), 1, 8)='SUBJECT:' then
                 sSubj:=Trim(Copy(ts, 9, MaxInt));
              slTemp.Add(ts);
            end;

          with lvMails.Items.Add do
            begin
              Caption:=sFrom;
              SubItems.Add(sTo);
              SubItems.Add(sSubj);
              SubItems.Add(slTemp.Text);
            end;
        end;
    finally
      slTemp.Free;
    end;

  finally
    IdTCPClient.Disconnect;
    EnablePOPControls(true);
  end;
end;

procedure TfmMain.lvMailsSelectItem(Sender: TObject; Item: TListItem;
  Selected: Boolean);
begin
  if lvMails.Selected <> nil then
    ParseMail(lvMails.Selected.SubItems[2]);
end;

procedure TfmMain.sbtSaveAttachClick(Sender: TObject);
var
  i, Cnt, Idx: Integer;
begin
  Idx:=lvMailAttachments.Selected.Index;
  Cnt:=0;
  i:=0;

  while (i < IdMessage1.MessageParts.Count) do
    begin
      if IdMessage1.MessageParts[i] is TIdAttachmentFile then
        if Cnt = Idx then
          begin
            sdMain.FileName:=(IdMessage1.MessageParts[i] as TIdAttachmentFile).FileName;
            sdMain.InitialDir:=ExtractFilePath(Application.ExeName);

            if sdMain.Execute then
              (IdMessage1.MessageParts[i] as TIdAttachmentFile).SaveToFile(sdMain.FileName);

            Exit;
          end
        else
          Inc(Cnt);

      Inc(i);
    end;
end;

end.

WaReZMEN

Дата 10.3.2009, 14:33 (ссылка)

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

Загрузка ...

Опытный

Профиль
Группа: Участник
Сообщений: 683
Регистрация: 9.6.2006
Где: Россия, Санкт-Пет ербург

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

Остался вопрос как научить его работать с прокси????????????

SneG0K

Дата 10.3.2009, 14:36 (ссылка)

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

Загрузка ...

Max Mara

Профиль
Группа: Завсегдатай
Сообщений: 1887
Регистрация: 1.12.2007
Где: Wis Dells

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

Устанавливай вместо порта и урла сервера, порт и урл прокси...

WaReZMEN

Дата 10.3.2009, 14:40 (ссылка)

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

Загрузка ...

Опытный

Профиль
Группа: Участник
Сообщений: 683
Регистрация: 9.6.2006
Где: Россия, Санкт-Пет ербург

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

SneG0K а где ж я тогда Ност укажу???

denizkin

Дата 22.1.2011, 19:22 (ссылка)

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

Загрузка ...

Новичок

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

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

Всем привет!
Дорогие форумчане будьте любезны пожалуйста распишите мне в кратце файл dimime

Просто хотя бы какая функция,что делает!

Код


unit DIMime;

interface

{$I DI.inc}

function MimeEncodeString(const s: AnsiString): AnsiString;

function MimeEncodeStringNoCRLF(const s: AnsiString): AnsiString;

function MimeDecodeString(const s: AnsiString): AnsiString;

function MimeEncodedSize(const InputSize: Cardinal): Cardinal;

function MimeEncodedSizeNoCRLF(const InputSize: Cardinal): Cardinal;

function MimeDecodedSize(const InputSize: Cardinal): Cardinal;

procedure DecodeHttpBasicAuthentication(const BasicCredentials: AnsiString; out UserId, Password: AnsiString);

procedure MimeEncode(const InputBuffer; const InputByteCount: Cardinal; out OutputBuffer);

procedure MimeEncodeNoCRLF(const InputBuffer; const InputByteCount: Cardinal; out OutputBuffer);

procedure MimeEncodeFullLines(const InputBuffer; const InputByteCount: Cardinal; out OutputBuffer);

function MimeDecode(const InputBuffer; const InputBytesCount: Cardinal; out OutputBuffer): Cardinal;

function MimeDecodePartial(const InputBuffer; const InputBytesCount: Cardinal; out OutputBuffer; var ByteBuffer: Cardinal; var ByteBufferSpace: Cardinal): Cardinal;

function MimeDecodePartialEnd(out OutputBuffer; const ByteBuffer: Cardinal; const ByteBufferSpace: Cardinal): Cardinal;

const

  MIME_ENCODED_LINE_BREAK = 76;

  MIME_DECODED_LINE_BREAK = MIME_ENCODED_LINE_BREAK div 4 * 3;

implementation

const

  MIME_ENCODE_TABLE: array[0..63] of Byte = (
    065, 066, 067, 068, 069, 070, 071, 072,
    073, 074, 075, 076, 077, 078, 079, 080,
    081, 082, 083, 084, 085, 086, 087, 088,
    089, 090, 097, 098, 099, 100, 101, 102,
    103, 104, 105, 106, 107, 108, 109, 110,
    111, 112, 113, 114, 115, 116, 117, 118,
    119, 120, 121, 122, 048, 049, 050, 051,
    052, 053, 054, 055, 056, 057, 043, 047);

  MIME_PAD_CHAR = Byte('=');

  MIME_DECODE_TABLE: array[Byte] of Cardinal = (
    255, 255, 255, 255, 255, 255, 255, 255,
    255, 255, 255, 255, 255, 255, 255, 255,
    255, 255, 255, 255, 255, 255, 255, 255,
    255, 255, 255, 255, 255, 255, 255, 255,
    255, 255, 255, 255, 255, 255, 255, 255,
    255, 255, 255, 062, 255, 255, 255, 063,
    052, 053, 054, 055, 056, 057, 058, 059,
    060, 061, 255, 255, 255, 255, 255, 255,
    255, 000, 001, 002, 003, 004, 005, 006,
    007, 008, 009, 010, 011, 012, 013, 014,
    015, 016, 017, 018, 019, 020, 021, 022,
    023, 024, 025, 255, 255, 255, 255, 255,
    255, 026, 027, 028, 029, 030, 031, 032,
    033, 034, 035, 036, 037, 038, 039, 040,
    041, 042, 043, 044, 045, 046, 047, 048,
    049, 050, 051, 255, 255, 255, 255, 255,
    255, 255, 255, 255, 255, 255, 255, 255,
    255, 255, 255, 255, 255, 255, 255, 255,
    255, 255, 255, 255, 255, 255, 255, 255,
    255, 255, 255, 255, 255, 255, 255, 255,
    255, 255, 255, 255, 255, 255, 255, 255,
    255, 255, 255, 255, 255, 255, 255, 255,
    255, 255, 255, 255, 255, 255, 255, 255,
    255, 255, 255, 255, 255, 255, 255, 255,
    255, 255, 255, 255, 255, 255, 255, 255,
    255, 255, 255, 255, 255, 255, 255, 255,
    255, 255, 255, 255, 255, 255, 255, 255,
    255, 255, 255, 255, 255, 255, 255, 255,
    255, 255, 255, 255, 255, 255, 255, 255,
    255, 255, 255, 255, 255, 255, 255, 255,
    255, 255, 255, 255, 255, 255, 255, 255,
    255, 255, 255, 255, 255, 255, 255, 255);

type
  PByte4 = ^TByte4;
  TByte4 = packed record
    b1, b2, b3, b4: Byte;
  end;

  PByte3 = ^TByte3;
  TByte3 = packed record
    b1, b2, b3: Byte;
  end;

  PCardinal = ^Cardinal;

function MimeEncodeString(const s: AnsiString): AnsiString;
var
  l: Cardinal;
begin
  if Pointer(s) <> nil then
    begin
      l := PCardinal(Cardinal(s) - 4)^;
      SetString(Result, nil, MimeEncodedSize(l));
      MimeEncode(Pointer(s)^, l, Pointer(Result)^);
    end
  else
    Result := '';
end;

function MimeEncodeStringNoCRLF(const s: AnsiString): AnsiString;
var
  l: Cardinal;
begin
  if Pointer(s) <> nil then
    begin
      l := PCardinal(Cardinal(s) - 4)^;
      SetString(Result, nil, MimeEncodedSizeNoCRLF(l));
      MimeEncodeNoCRLF(Pointer(s)^, l, Pointer(Result)^);
    end
  else
    Result := '';
end;

function MimeDecodeString(const s: AnsiString): AnsiString;
var
  ByteBuffer, ByteBufferSpace: Cardinal;
  l: Cardinal;
begin
  if Pointer(s) <> nil then
    begin
      l := PCardinal(Cardinal(s) - 4)^;
      SetString(Result, nil, MimeDecodedSize(l));
      ByteBuffer := 0;
      ByteBufferSpace := 4;
      l := MimeDecodePartial(Pointer(s)^, l, Pointer(Result)^, ByteBuffer, ByteBufferSpace);
      Inc(l, MimeDecodePartialEnd(Pointer(Cardinal(Result) + l)^, ByteBuffer, ByteBufferSpace));
      SetLength(Result, l);
    end
  else
    Result := '';
end;

procedure DecodeHttpBasicAuthentication(const BasicCredentials: AnsiString; out UserId, Password: AnsiString);
label
  Fail;
const
  LBasic = 6;
var
  DecodedPtr, p: PAnsiChar;
  i, l: Cardinal;
begin
  p := Pointer(BasicCredentials);
  if p = nil then goto Fail;

  l := Cardinal(Pointer(p - 4)^);
  if l <= LBasic then goto Fail;

  Dec(l, LBasic);
  Inc(p, LBasic);

  GetMem(DecodedPtr, MimeDecodedSize(l));
  l := MimeDecode(p^, l, DecodedPtr^);

  i := 0;
  p := DecodedPtr;
  while (l > 0) and (p[i] <> ':') do
    begin
      Inc(i);
      Dec(l);
    end;

  SetString(UserId, DecodedPtr, i);
  if l > 1 then
    SetString(Password, DecodedPtr + i + 1, l - 1)
  else
    Password := '';

  FreeMem(DecodedPtr);
  Exit;

  Fail:
  UserId := '';
  Password := '';
end;

function MimeEncodedSize(const InputSize: Cardinal): Cardinal;
begin
  if InputSize > 0 then
    Result := (InputSize + 2) div 3 * 4 + (InputSize - 1) div MIME_DECODED_LINE_BREAK * 2
  else
    Result := InputSize;
end;

function MimeEncodedSizeNoCRLF(const InputSize: Cardinal): Cardinal;
begin
  Result := (InputSize + 2) div 3 * 4;
end;

function MimeDecodedSize(const InputSize: Cardinal): Cardinal;
begin
  Result := (InputSize + 3) div 4 * 3;
end;

procedure MimeEncode(const InputBuffer; const InputByteCount: Cardinal; out OutputBuffer);
var
  iDelta, ODelta: Cardinal;
begin
  MimeEncodeFullLines(InputBuffer, InputByteCount, OutputBuffer);
  iDelta := InputByteCount div MIME_DECODED_LINE_BREAK;
  ODelta := iDelta * (MIME_ENCODED_LINE_BREAK + 2);
  iDelta := iDelta * MIME_DECODED_LINE_BREAK;
  MimeEncodeNoCRLF(Pointer(Cardinal(@InputBuffer) + iDelta)^, InputByteCount - iDelta, Pointer(Cardinal(@OutputBuffer) + ODelta)^);
end;

procedure MimeEncodeFullLines(const InputBuffer; const InputByteCount: Cardinal; out OutputBuffer);
var
  b, InnerLimit, OuterLimit: Cardinal;
  InPtr: PByte3;
  OutPtr: PByte4;
begin

  if InputByteCount < MIME_DECODED_LINE_BREAK then Exit;

  InPtr := @InputBuffer;
  OutPtr := @OutputBuffer;

  InnerLimit := Cardinal(InPtr);
  Inc(InnerLimit, MIME_DECODED_LINE_BREAK);

  OuterLimit := Cardinal(InPtr);
  Inc(OuterLimit, InputByteCount);

  repeat

    repeat

      b := InPtr^.b1;
      b := b shl 8;
      b := b or InPtr^.b2;
      b := b shl 8;
      b := b or InPtr^.b3;
      Inc(InPtr);

      OutPtr^.b4 := MIME_ENCODE_TABLE[b and $3F];
      b := b shr 6;
      OutPtr^.b3 := MIME_ENCODE_TABLE[b and $3F];
      b := b shr 6;
      OutPtr^.b2 := MIME_ENCODE_TABLE[b and $3F];
      b := b shr 6;
      OutPtr^.b1 := MIME_ENCODE_TABLE[b];
      Inc(OutPtr);
    until Cardinal(InPtr) >= InnerLimit;

    OutPtr^.b1 := 13;
    OutPtr^.b2 := 10;
    Inc(Cardinal(OutPtr), 2);

    Inc(InnerLimit, MIME_DECODED_LINE_BREAK);
  until InnerLimit > OuterLimit;
end;

procedure MimeEncodeNoCRLF(const InputBuffer; const InputByteCount: Cardinal; out OutputBuffer);
var
  b, InnerLimit, OuterLimit: Cardinal;
  InPtr: PByte3;
  OutPtr: PByte4;
begin
  if InputByteCount = 0 then Exit;

  InPtr := @InputBuffer;
  OutPtr := @OutputBuffer;

  OuterLimit := InputByteCount div 3 * 3;

  InnerLimit := Cardinal(InPtr);
  Inc(InnerLimit, OuterLimit);

  while Cardinal(InPtr) < InnerLimit do
    begin

      b := InPtr^.b1;
      b := b shl 8;
      b := b or InPtr^.b2;
      b := b shl 8;
      b := b or InPtr^.b3;
      Inc(InPtr);

      OutPtr^.b4 := MIME_ENCODE_TABLE[b and $3F];
      b := b shr 6;
      OutPtr^.b3 := MIME_ENCODE_TABLE[b and $3F];
      b := b shr 6;
      OutPtr^.b2 := MIME_ENCODE_TABLE[b and $3F];
      b := b shr 6;
      OutPtr^.b1 := MIME_ENCODE_TABLE[b];
      Inc(OutPtr);
    end;

  case InputByteCount - OuterLimit of
    1:
      begin
        b := InPtr^.b1;
        b := b shl 4;
        OutPtr.b2 := MIME_ENCODE_TABLE[b and $3F];
        b := b shr 6;
        OutPtr.b1 := MIME_ENCODE_TABLE[b];
        OutPtr.b3 := MIME_PAD_CHAR;
        OutPtr.b4 := MIME_PAD_CHAR;
      end;
    2:
      begin
        b := InPtr^.b1;
        b := b shl 8;
        b := b or InPtr^.b2;
        b := b shl 2;
        OutPtr.b3 := MIME_ENCODE_TABLE[b and $3F];
        b := b shr 6;
        OutPtr.b2 := MIME_ENCODE_TABLE[b and $3F];
        b := b shr 6;
        OutPtr.b1 := MIME_ENCODE_TABLE[b];
        OutPtr.b4 := MIME_PAD_CHAR;
      end;
  end;
end;

function MimeDecode(const InputBuffer; const InputBytesCount: Cardinal; out OutputBuffer): Cardinal;
var
  ByteBuffer, ByteBufferSpace: Cardinal;
begin
  ByteBuffer := 0;
  ByteBufferSpace := 4;
  Result := MimeDecodePartial(InputBuffer, InputBytesCount, OutputBuffer, ByteBuffer, ByteBufferSpace);
  Inc(Result, MimeDecodePartialEnd(Pointer(Cardinal(@OutputBuffer) + Result)^, ByteBuffer, ByteBufferSpace));
end;

function MimeDecodePartial(const InputBuffer; const InputBytesCount: Cardinal; out OutputBuffer; var ByteBuffer: Cardinal; var ByteBufferSpace: Cardinal): Cardinal;
var
  lByteBuffer, lByteBufferSpace, c: Cardinal;
  InPtr, OuterLimit: ^Byte;
  OutPtr: PByte3;
begin
  if InputBytesCount > 0 then
    begin
      InPtr := @InputBuffer;
      Cardinal(OuterLimit) := Cardinal(InPtr) + InputBytesCount;
      OutPtr := @OutputBuffer;
      lByteBuffer := ByteBuffer;
      lByteBufferSpace := ByteBufferSpace;
      while InPtr <> OuterLimit do
        begin

          c := MIME_DECODE_TABLE[InPtr^];
          Inc(InPtr);
          if c = $FF then Continue;
          lByteBuffer := lByteBuffer shl 6;
          lByteBuffer := lByteBuffer or c;
          Dec(lByteBufferSpace);

          if lByteBufferSpace <> 0 then Continue;

          OutPtr^.b3 := Byte(lByteBuffer);
          lByteBuffer := lByteBuffer shr 8;
          OutPtr^.b2 := Byte(lByteBuffer);
          lByteBuffer := lByteBuffer shr 8;
          OutPtr^.b1 := Byte(lByteBuffer);
          lByteBuffer := 0;
          Inc(OutPtr);
          lByteBufferSpace := 4;
        end;
      ByteBuffer := lByteBuffer;
      ByteBufferSpace := lByteBufferSpace;
      Result := Cardinal(OutPtr) - Cardinal(@OutputBuffer);
    end
  else
    Result := 0;
end;

function MimeDecodePartialEnd(out OutputBuffer; const ByteBuffer: Cardinal; const ByteBufferSpace: Cardinal): Cardinal;
var
  lByteBuffer: Cardinal;
begin
  case ByteBufferSpace of
    1:
      begin
        lByteBuffer := ByteBuffer shr 2;
        PByte3(@OutputBuffer)^.b2 := Byte(lByteBuffer);
        lByteBuffer := lByteBuffer shr 8;
        PByte3(@OutputBuffer)^.b1 := Byte(lByteBuffer);
        Result := 2;
      end;
    2:
      begin
        lByteBuffer := ByteBuffer shr 4;
        PByte3(@OutputBuffer)^.b1 := Byte(lByteBuffer);
        Result := 1;
      end;
  else
    Result := 0;
  end;
end;

end.

Ymnuk

Дата 28.1.2011, 19:08 (ссылка)

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

Загрузка ...

Новичок

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

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

Товарищ denizkin...
Mime - это кодирование бинарного содержимого по определенному алгоритму...
Encode/Decode - кодирование/декодирование...
smile

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