[转摘]Indy10,采用线程，发送电子邮件

uses
IdComponent,IdTCPConnection, IdTCPClient, IdMessageClient, IdSMTP,IdBaseComponent,IdMessage,IdExplicitTLSClientServerBase,
IdSMTPBase, IdAttachmentFile,IdText;//引用的与Indy10有关的单元

type                     //省去了窗体的定义部分
TSmtpThread = class(TThread)   //定义的线程，用于发邮件
  private
    FHost: String;
    FUserName: String;
    FPassword:String;
  //  FPriority:TThreadPriority;
  protected
    procedure Execute; override;
  public
    constructor Create(Host:String;UserName:String;Password:String);
    destructor Destroy;override;
    function URLGet(s:String):String;
    function CIDGet(url:String):String;
    function UrlToCid(s:String;s1:String;s2:String):String;
    function InlineParse(s:String):String;
  end;

var
  ComposeForm: TComposeForm;  //窗体
  not_relatedAttachmentList:TStrings;//用于记录附件信息
  relatedAttachmentList:TStrings; //用于记录嵌式附件信息
//以下是具体执行部分
procedure TComposeForm.FormCreate(Sender: TObject);
begin
not_relatedAttachmentList:=Tstringlist.Create;
  relatedAttachmentList:=TStringList.Create;
end;
procedure TComposeForm.ComposeAttachmentExecute(Sender: TObject);
begin
if OpenDialog1.Execute then
not_relatedAttachmentList.Add(OpenDialog1.FileName);//添加附件时加入文件名
end;

//there we define some method in SmtpThread to send the message
//writen in HTMLEdit1 and some transfrom ensure the success of sent of message.

constructor TSmtpThread.Create(Host:String;UserName:String;Password:String);
begin
  inherited Create(False);
  Priority :=tpNormal;
  FreeOnTerminate := True;
  FHost:=Host;
  FUserName:=UserName;
  FPassword:=Password;
  end;

destructor TSmtpThread.Destroy;
begin
  inherited Destroy;
end;

procedure TSmtpThread.Execute;
var
  Smtp:TIdSMTP;
  Msg:TIdMessage;
  tempstr1,tempstr2:string;
  i:integer;
begin
  tempstr1:=ComposeForm.HTMLEdit1.InnerHTML;//一个HTMLEdit控件,
                                              // 此语句产生 html格式的字符串
//各位也可用下面语句替换帮忙测试
//tempstr1:='<html><body><p>This message has an inline
// image<img src="c:\temp\image1.gif" /></p></body></html>'

  tempstr2:=InlineParse(tempstr1);//执行内嵌式附件信的转化
  Msg:=TIdMessage.Create(nil);//动态创建
//以下部分完成格式的匹配
//*************************************************
   if (relatedAttachmentList.Count>0) and (not_relatedAttachmentList.Count>0) then
  begin
    with TIdText.Create(Msg.MessageParts, nil) do begin
      ContentType := 'multipart/alternative';
      ParentPart :=-1;
    end;
    with TIdText.Create(Msg.MessageParts, nil) do begin
      Body.Text :=tempstr2;
      ContentType := 'text/html';
      ParentPart := 0;
    end;
    for i:=0 to  relatedAttachmentList.Count-1 do
    with TIdAttachmentFile.Create(Msg.MessageParts, relatedAttachmentList.Strings[i]) do begin
      ContentID := CIDGet(relatedAttachmentList.Strings[i]);
      ContentType := 'image/*';
      ContentDisposition := 'inline';
      ParentPart := 0;
    end;
    for i:=0 to  not_relatedAttachmentList.Count-1 do
    with TIdAttachmentFile.Create(Msg.MessageParts,not_relatedAttachmentList.Strings[i]) do begin
      ContentID := CIDGet(not_relatedAttachmentList.Strings[i]);
      ContentType := 'whatever';
      ParentPart :=-1;
    end;
  Msg.ContentType:='multipart/mixed';
  end;
  if (relatedAttachmentList.Count>0) and (not_relatedAttachmentList.Count<=0) then
  begin
  with TIdText.Create(Msg.MessageParts, nil) do begin
      Body.Text :=tempstr2;
      ContentType := 'text/html';
      ParentPart := -1;
    end;
    for i:=0 to  relatedAttachmentList.Count-1 do
    with TIdAttachmentFile.Create(Msg.MessageParts, relatedAttachmentList.Strings[i]) do begin
      ContentID := CIDGet(relatedAttachmentList.Strings[i]);
      ContentType := 'image/*';
      ContentDisposition := 'inline';
      ParentPart := -1;
    end;
  Msg.ContentType:='multipart/related; type="text/html"';
  end;
  if (relatedAttachmentList.Count<=0) and (not_relatedAttachmentList.Count>0) then
  begin
    with TIdText.Create(Msg.MessageParts, nil) do begin
      Body.Text :=tempstr2;
      ContentType := 'text/html';
      ParentPart := -1;
    end;
    for i:=0 to  not_relatedAttachmentList.Count-1 do
    with TIdAttachmentFile.Create(Msg.MessageParts,not_relatedAttachmentList.Strings[i]) do begin
      ContentID := CIDGet(not_relatedAttachmentList.Strings[i]);
      ContentType := 'whatever';
      ParentPart :=-1;
    end;
  Msg.ContentType:='multipart/mixed';
  end;
  if (relatedAttachmentList.Count<=0) and (not_relatedAttachmentList.Count<=0) then
  begin
   with TIdText.Create(Msg.MessageParts, nil) do begin
      Body.Text :=tempstr2;
      ContentType := 'text/html';
      ParentPart := -1;
    end;
  Msg.ContentType:='text/html';
  end;
//**************************************************

      with Msg do
      begin
      Clear;
   From.Address:='linxiao8302@163.com';//直接输入，方便测试
//大家可以直接往我的这些邮箱中发，也方便我比较分析
   ReplyTo.EMailAddresses:='scandinavian0330@yahoo.com';
   CCList.EMailAddresses:='scandinavian0330@yahoo.com';
   Subject:='ThanksForYourHelp';
   Priority := TIdMessagePriority(mpHighest);
   end;
  Smtp:=TIdSMTP.Create(nil);
      with Smtp do
      begin
      Host:=FHost;
      Port:= 25;
      Username:=FUserName;
      Password:=FPassword;
      AuthType := atDefault;
      Connect;
      try
        Send(Msg);
        showmessage('success');//测试时加的
      finally
        Disconnect;
      end;
      end;
  Msg.Free;
  Smtp.Free;

end;

function TSmtpThread.URLGet(s:String):String;//取得html中插入的图片等
//信息的物理地址,不知各位是怎么做的
var
  p:integer;
begin
    result:='';
    p:=Pos('src="cid',s);
    if p>0 then exit;
    p:=Pos('src="',s);
    if p>0 then begin
      s:=Copy(s,p+5,Length(s)-p-10);
      p:=Pos('"',s);
      result:=copy(s,1,p-1);
    end;
end;

function TSmtpThread.CIDGet(url:String):String;//直接将文件名作为CID
begin                                      //写成函数是方便以后改成其他处理方式
  result:=ExtractFileName(url);
end;

function TSmtpThread.UrlToCid(s:String;s1:String;s2:String):String;
var                  //转化HTML中的物理地址为CID
  p:Integer;
begin
  p:=pos(s1,s);
  Delete(s,p,Length(s1));
  Insert('cid:'+s2,s,p);
  result:=s;
end;

function TSmtpThread.InlineParse(s:string):String;
var                     //对全文进行CID替换
  htmlText:String;
  cid,url:String;
begin
  htmlText:=s;
  url:=URLGet(htmlText);
  while url<>'' do begin
    relatedAttachmentList.Add(url);
    cid:=CIDGet(url);
    htmlText:=UrlToCid(htmlText,url,cid);
    url:=URLGet(htmlText);
  end;
  result:=htmlText;
end;
procedure TComposeForm.SendMailClick(Sender: TObject);//发信
begin  //各位用自己邮箱帮忙测试哟，不甚感激
  TSmtpThread.Create('smtp.163.com','linxiao8302','******');
end;

unit Unit1;

interface

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

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

var
Form1: TForm1;

imple****tion

{$R *.dfm}

function Base64ToString(const Value : string): string;
var
x, y, n, l: Integer;
d: array[0..3] of Byte;
Table : string;
begin
Table :=
   #$40 +#$40 +#$40 +#$40 +#$40 +#$40 +#$40 +#$40 +#$40 +#$40 +#$3E +#$40
   +#$40 +#$40 +#$3F +#$34 +#$35 +#$36 +#$37 +#$38 +#$39 +#$3A +#$3B +#$3C
   +#$3D +#$40 +#$40 +#$40 +#$40 +#$40 +#$40 +#$40 +#$00 +#$01 +#$02 +#$03
   +#$04 +#$05 +#$06 +#$07 +#$08 +#$09 +#$0A +#$0B +#$0C +#$0D +#$0E +#$0F
   +#$10 +#$11 +#$12 +#$13 +#$14 +#$15 +#$16 +#$17 +#$18 +#$19 +#$40 +#$40
   +#$40 +#$40 +#$40 +#$40 +#$1A +#$1B +#$1C +#$1D +#$1E +#$1F +#$20 +#$21
   +#$22 +#$23 +#$24 +#$25 +#$26 +#$27 +#$28 +#$29 +#$2A +#$2B +#$2C +#$2D
   +#$2E +#$2F +#$30 +#$31 +#$32 +#$33 +#$40 +#$40 +#$40 +#$40 +#$40 +#$40;

SetLength(Result, Length(Value));
x := 1;
l := 1;
while x < Length(Value) do
begin
   for n := 0 to 3 do
   begin
     if x > Length(Value) then
       d[n] := 64
     else
     begin
       y := Ord(Value[x]);
       if (y < 33) or (y > 127) then
         d[n] := 64
       else
         d[n] := Ord(Table[y - 32]);
     end;
     Inc(x);
   end;
   Result[l] := Char((D[0] and $3F) shl 2 + (D[1] and $30) shr 4);
   Inc(l);
   if d[2] <> 64 then
   begin
     Result[l] := Char((D[1] and $0F) shl 4 + (D[2] and $3C) shr 2);
     Inc(l);
     if d[3] <> 64 then
     begin
       Result[l] := Char((D[2] and $03) shl 6 + (D[3] and $3F));
       Inc(l);
     end;
   end;
end;
Dec(l);
SetLength(Result, l);
end;

function StringToBase64(const Value: string): string;
var
c: Byte;
n, l: Integer;
Count: Integer;
DOut: array[0..3] of Byte;
Table : string;
begin
Table :=
   'ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz0123456789+/=';

setlength(Result, ((Length(Value) + 2) div 3) * 4);
l := 1;
Count := 1;
while Count <= Length(Value) do
begin
   c := Ord(Value[Count]);
   Inc(Count);
   DOut[0] := (c and $FC) shr 2;
   DOut[1] := (c and $03) shl 4;
   if Count <= Length(Value) then
   begin
     c := Ord(Value[Count]);
     Inc(Count);
     DOut[1] := DOut[1] + (c and $F0) shr 4;
     DOut[2] := (c and $0F) shl 2;
     if Count <= Length(Value) then
     begin
       c := Ord(Value[Count]);
       Inc(Count);
       DOut[2] := DOut[2] + (c and $C0) shr 6;
       DOut[3] := (c and $3F);
     end
     else
     begin
       DOut[3] := $40;
     end;
   end
   else
   begin
     DOut[2] := $40;
     DOut[3] := $40;
   end;
   for n := 0 to 3 do
   begin
     Result[l] := Table[DOut[n] + 1];
     Inc(l);
   end;
end;
end;

function GetTitle(const Value: string): string;
var
iPos: integer;
begin
Result := Value;
if Copy(Value, 1, 2) <> '=?' then exit;
//'?B?'前面的都要去掉
iPos := Pos('?B?', Value);
Inc(iPos, 3);
//最后的'?='也要去掉
Result := Copy(Value, iPos, Length(Value) - iPos - 1);
Result := Base64ToString(Result);
end;

procedure TForm1.Button1Click(Sender: TObject);
begin
ShowMessage(GetTitle('=?gb2312?B?YXNkZnNhZGZkc2Fm1tC5+g==?='));
end;

end.

To 小神通
     StringToBase64()具体要用在什么地方呢，对哪部分进行编码啊？
    能说明的详细点吗？
    IdMessage好像自动会将有关信息在发送前统一转化为Base64型吧，看看IdMessage.pas中的定义中好像是这样的
      要帮忙看下格式定义那块是否正确，我有点怀疑那上面出了问题
      结合问题具体指明哟

怎么没人回呀

用在读取出来是乱码的地方试试

在得到正文、标题等地方都要转换一下显示，好像是indy的一个bug。

应该是base64没解码的问题
这个是faststring 单元里面的base64解码程序，速度快
注意，不要用来解码空的字符串
function Base64Decode(const Source: string): string;
var
  NewLength: Integer;
begin
{
  NB: On invalid input this routine will simply skip the bad data, a
better solution would probably report the error

  ESI -> Source String
  EDI -> Result String

  ECX -> length of Source (number of DWords)
  EAX -> 32 Bits from Source
  EDX -> 24 Bits Decoded

  BL -> Current number of bytes decoded
}

  SetLength( Result, (Length(Source) div 4) * 3);
  NewLength := 0;
  asm
    Push  ESI
    Push  EDI
    Push  EBX

    Mov   ESI, Source

    Mov   EDI, Result //Result address
    Mov   EDI, [EDI]

    Or    ESI,ESI   // Nil Strings
    Jz    @Done

    Mov   ECX, [ESI-4]
    Shr   ECX,2       // DWord Count

    JeCxZ @Error      // Empty String

    Cld

    jmp   @Read4

  @Next:
    Dec   ECX
    Jz   @Done

  @Read4:
    lodsd

    Xor   BL, BL
    Xor   EDX, EDX

    Call  @DecodeTo6Bits
    Shl   EDX, 6
    Shr   EAX,8
    Call  @DecodeTo6Bits
    Shl   EDX, 6
    Shr   EAX,8
    Call  @DecodeTo6Bits
    Shl   EDX, 6
    Shr   EAX,8
    Call  @DecodeTo6Bits

  // Write Word

    Or    BL, BL
    JZ    @Next  // No Data

    Dec   BL
    Or    BL, BL
    JZ    @Next  // Minimum of 2 decode values to translate to 1 byte

    Mov   EAX, EDX

    Cmp   BL, 2
    JL    @WriteByte

    Rol   EAX, 8

    BSWAP EAX

    StoSW

    Add NewLength, 2

  @WriteByte:
    Cmp BL, 2
    JE  @Next
    SHR EAX, 16
    StoSB

    Inc NewLength
    jmp   @Next

  @Error:
    jmp @Done

  @DecodeTo6Bits:

  @TestLower:
    Cmp AL, 'a'
    Jl @TestCaps
    Cmp AL, 'z'
    Jg @Skip
    Sub AL, 71
    Jmp @Finish

  @TestCaps:
    Cmp AL, 'A'
    Jl  @TestEqual
    Cmp AL, 'Z'
    Jg  @Skip
    Sub AL, 65
    Jmp @Finish

  @TestEqual:
    Cmp AL, '='
    Jne @TestNum
    // Skip byte
    ret

  @TestNum:
    Cmp AL, '9'
    Jg @Skip
    Cmp AL, '0'
    JL  @TestSlash
    Add AL, 4
    Jmp @Finish

  @TestSlash:
    Cmp AL, '/'
    Jne @TestPlus
    Mov AL, 63
    Jmp @Finish

  @TestPlus:
    Cmp AL, '+'
    Jne @Skip
    Mov AL, 62

  @Finish:
    Or  DL, AL
    Inc BL

  @Skip:
    Ret

  @Done:
    Pop   EBX
    Pop   EDI
    Pop   ESI

  end;

  SetLength( Result, NewLength); // Trim off the excess
end;

现在问题是没有乱码了，没用编码(IdMessage支持自动编码成base64，我从它的单元文件中看到好像是的)
现在是内嵌式图片(inline )为什么会当作附件显示，邮件却没有附件标志
而且添加个附件的话,邮件中就会有附件标志，也能显示
说明两者还是有不同
用的是smtp.163.com
收用的是yahoo的邮箱

posted @ 2008-11-13 12:50 小洋房阅读(2322) 评论(0) 收藏举报

刷新页面返回顶部

小洋房

小洋房房产中介管理系统

[转摘]Indy10,采用线程，发送电子邮件

公告