nmpop3.pas

DELPHI里面一些常用的控件

        FFirstPart := 2;
        if assigned(OnPacketRecvd) then
          begin
            ReplyMess := Transaction(Cons_Cmd_List + IntToStr(MailNumber));
            FBytesTotal := StrToInt(Trim(NthWord(ReplyMess, ' ', 3)));
          end;
        ReplyMess := Transaction(Cons_Cmd_Retr + IntToStr(MailNumber));
        if Pos(Cons_OK_Resp, NthWord(ReplyMess, ' ', 1)) = 0 then raise Exception.create(ReplyMess);
        Readindex := 0;
        FMailMessage.FHead.clear;
        FMailMessage.FBody.clear;
        FMailMessage.FRawBody.clear;
        FMailMessage.FAttachments.clear;
        FMailMessage.Fcontenttypes.clear;
        FMailMessage.FSubject := '';
        FMailMessage.FContenttype := '';
        FBytesRecvd := 0;
        if not FAbort then ReadHeader(false, FMailMessage);
        ReplyMess := Readln;
        FBytesRecvd := FBytesRecvd + length(ReplyMess);
        if assigned(OnPacketRecvd) then OnPacketRecvd(Self);
        while ReplyMess <> '.' + #13#10 do
          begin
            ReplyMess := Copy(ReplyMess, 0, Length(ReplyMess) - 2);
            FMailMessage.FRawBody.add(ReplyMess);
            ReplyMess := Readln;
            FBytesRecvd := FBytesRecvd + length(ReplyMess);
            if assigned(OnPacketRecvd) then OnPacketRecvd(Self);
          end;
        if not FAbort then
          if pos(Lowercase(Cons_Head_Mult), LowerCase(FMailMessage.FContentType)) > 0 then ReadMailParts
          else if not FParse then FMailMessage.FBody.Assign(FMailMessage.FRawBody)
          else
            if (pos('BASE64', Uppercase(FContent_type)) > 0) then
              begin
                FFirstPart := 0;
                ReadBody(FMailMessage);
                FMailMessage.FBody.loadfromfile(FAttachFilePath + FMailMessage.FAttachments[0]);
              end
            else {_ NOT if pos(Cons_Head_Mult, FContentType) > 0 then ReadMailParts _}  ReadBody(FMailMessage);
        if FDeleteOnRead and not FAbort then
          begin
            ReplyMess := Transaction(Cons_Cmd_Dele + IntToStr(MailNumber));
            if NthWord(ReplyMess, ' ', 1) = Cons_Err_Resp then raise Exception.create(ReplyMess);
          end; {_ if FDeleteOnRead and not FAbort then _}
        if FAbort then Transaction(Cons_Cmd_Rset)
        else {_ NOT if FAbort then Transaction(Cons_Cmd_Rset) _}  StatusMessage(Status_Informational, sPOP_Cons_Msg_Retr);
      finally
        if assigned(FOnRetrieveEnd) then FOnRetrieveEnd(self);
        FTransactionInProgress := FALSE;
      end; {_ try _}
    end; {_ if not FTransactionInProgress then _}
end; {_ procedure TNMPOP3.GetMailMessage(MailNumber: integer); _}

procedure TNMPOP3.Extract(InString: string; var OutString: string);
var i: integer;
  found: boolean;
begin
  CertifyConnect;
  i := -1;
  found := FALSE;
  repeat
    i := i + 1;
    if (Pos(InString, FMailMessage.FHead[i]) > 0) then found := TRUE;
  until found or (i = (FMailMessage.FHead.count - 1));
  if found then OutString := Trim(Copy(FMailMessage.FHead[i], Pos(':', FMailMessage.FHead[i]) + 1, 255))
  else {_ NOT if found then OutString := Trim(Copy(FMailMessage.FHead[i], Pos(':', FMailMessage.FHead[i]) + 1, 255)) _}  OutString := '';
end; {_ procedure TNMPOP3.Extract(InString: string; var OutString: string); _}

procedure TNMPOP3.Reset;
var ReplyMess: string;
begin
  CertifyConnect;
  ReplyMess := Transaction(Cons_Cmd_Rset);
  if assigned(FOnReset) then FOnReset(self);
end; {_ procedure TNMPOP3.Reset; _}

procedure TNMPOP3.List;
var ReplyMess: string;
begin
  if not FTransactionInProgress then
    begin
      FTransactionInProgress := TRUE;
      try
        CertifyConnect;
        ReplyMess := Transaction(Cons_Cmd_List);
        ReplyMess := Readln;
        SetLength(ReplyMess, length(ReplyMess) - 2);
        while (ReplyMess <> '.') do
          begin
            if assigned(FOnList) then FOnList(StrToInt(NthWord(ReplyMess, ' ', 1)), StrToInt(NthWord(ReplyMess, ' ', 2)));
            ReplyMess := Readln;
            SetLength(ReplyMess, length(ReplyMess) - 2);
          end; {_ while (ReplyMess <> '.') do _}
      finally
        FTransactionInProgress := FALSE;
      end; {_ try _}
    end; {_ if not FTransactionInProgress then _}
end; {_ procedure TNMPOP3.List; _}


procedure TNMPOP3.ReadMailParts;
var ReplyMess: string;
  LastPart: boolean;
  TemMessage: TMailMessage;
begin
   {Extract Boundary Information}
  LastPart := FALSE;
   {Read Till First Boundary}
  TemMessage := TMailMessage.Create;
  repeat
    ReplyMess := FMailMessage.FRawBody[Readindex];
    inc(Readindex);
  until Pos(FMailMessage.FBoundary, ReplyMess) > 0;
  repeat
    if not FAbort then ReadHeader(true, TemMessage);
    if not FAbort then LastPart := ReadBody(FMailMessage);
  until (ReadIndex = FMailMessage.FRawBody.count) or (LastPart) or (FAbort) or (ReplyMess = '.' + #13#10);
  TemMessage.Free;
   {repeat
      ReplyMess := readln;
   until ReplyMess = '.' + #13#10; }
end; {_ procedure TNMPOP3.ReadMailParts; _}

procedure TNMPOP3.ReadHeader(Readfile: boolean; var MailMessage: TMailMessage);
var ReplyMess: string;
begin
  repeat
    if not FAbort then
      begin
        if ReadFile then
          begin
            if ReadIndex = FMailMessage.FRawBody.count then exit;
            ReplyMess := FMailMessage.FRawBody[Readindex];
            inc(Readindex);
          end
        else
          begin
            ReplyMess := ReadLn;
            FBytesRecvd := FBytesRecvd + length(ReplyMess);
            if assigned(OnPacketRecvd) then OnPacketRecvd(Self);
            SetLength(ReplyMess, length(ReplyMess) - 2);
          end;
        if FFirstPart = 2 then FMailMessage.FHead.add(ReplyMess);
        if (ReplyMess <> '') then
          begin
            if UpperCase(NthWord(ReplyMess, ' ', 1)) = Cons_Head_CSubj then
              FMailMessage.Fsubject := Copy(ReplyMess, 9, 256);
            if UpperCase(NthWord(ReplyMess, ' ', 1)) = Cons_Head_CFrom then
              FMailMessage.FFrom := Copy(ReplyMess, 7, 256);
            if UpperCase(NthWord(ReplyMess, ' ', 1)) = Cons_Head_CType then
              FMailMessage.FContentType := Copy(ReplyMess, 15, 256);
            if UpperCase(NthWord(ReplyMess, ' ', 1)) = Cons_Head_CMid then
              FMailMessage.FMessageID := Copy(ReplyMess, 13, 256);
            if Pos(Cons_Head_CBoun, UpperCase(ReplyMess)) > 0 then
              begin
                MailMessage.FBoundary := Copy(ReplyMess, Pos(Cons_Head_CBoun, UpperCase(ReplyMess)) + 9, 256);
                if (MailMessage.FBoundary[1] = #22) then
                  SetLength(MailMessage.FBoundary, Length(MailMessage.FBoundary) - 2)
                else {_ NOT if Boundary[1] = #22 then _}
                  begin
                    SetLength(MailMessage.FBoundary, Length(MailMessage.FBoundary) - 3);
                    MailMessage.FBoundary := Copy(MailMessage.FBoundary, 2, 255);
                  end; {_ NOT if Boundary[1] = #22 then _}
              end;
            if Pos(Cons_Head_CCTE, UpperCase(ReplyMess)) > 0 then
              FContent_type := Copy(ReplyMess, 28, 256);
            if (Pos(Cons_Head_FileN, UpperCase(ReplyMess)) > 0) or (Pos('NAME', UpperCase(ReplyMess)) > 0) then
              FFilename := NthWord(ReplyMess, '"', 2);
          end; {_ if (ReplyMess <> '') then _}
      end; {_ if not FAbort then _}
  until (ReplyMess = '') or FAbort;
  if FFirstPart = 2 then FFirstPart := 1;
end; {_ procedure TNMPOP3.ReadHeader; _}

//BD 1-7-99 To support files with multiple .s

function LastPos(StringSought, TheString: string): Integer;
var
  CurrentPos: Integer;
begin
  Result := 0;
  while Pos(StringSought, TheString) > 0 do
    begin
      CurrentPos := Pos(StringSought, TheString) + Length(StringSought) - 1;
      Result := Result + CurrentPos;
      TheString := Copy(TheString, CurrentPos + 1, Length(TheString));
    end;
  if Result > 0 then
    Result := Result - (Length(StringSought) - 1);
end;
//BD 1-7-99 To support files with multiple .s

function TNMPOP3.ReadBody(var MailMessage: TMailMessage): boolean;
var OutStream: TFileStream;
  ReplyMess, TFname1, TFName2: string;
  i: integer;
  Ins, Ous: TFileStream;

begin
  try
    result := FALSE;
    OutStream := nil;
   {if FFirstPart=1 then if (FContenttype<>'') and (pos('ascii',FContenttype)=0) then FFirstPart:=0;  }
    if FFirstPart = 0 then
      begin
        inc(TFileIndex);
        OutStream := TFileStream.create(FAttachFilePath + 'Temp' + IntToStr(TFileIndex) + '.mme', fmCreate);
      end; {_ if FFirstPart = 0 then _}
    StatusMessage(Status_Informational, sPOP_Cons_Msg_ExtrF);
    if ReadIndex = FMailMessage.FRawBody.count then exit;
    ReplyMess := FMailMessage.FRawBody[Readindex];
    inc(Readindex);
    while (Readindex <> FMailMessage.FRawBody.count) and (Pos(MailMessage.FBoundary, ReplyMess) = 0) and (ReplyMess <> '.' + #13#10) and (not FAbort) do
      begin
        if FFirstPart > 0 then
          begin
         //SetLength(ReplyMess, length(ReplyMess) - 2);
            FMailMessage.FBody.add(ReplyMess);
          end {_ if FFirstPart > 0 then _}
        else {_ NOT if FFirstPart > 0 then _} {FMailMessage.FBody.add(ReplyMess);}
          begin
            ReplyMess := ReplyMess + CRLF;
            OutStream.WriteBuffer(ReplyMess[1], length(ReplyMess));
          end;
        ReplyMess := FMailMessage.FRawBody[Readindex];
        inc(Readindex);
      end;
    if not Fabort and (FFirstPart = 0) and (OutStream.size > 0) then
      begin
        OutStream.Free;
        if FFileName = '' then FFileName := 'text.tmp';
        TFName1 := Copy(FFileName, 1, LastPos('.', FFileName) - 1);
        TFName2 := Copy(FFileName, Length(TFName1) + 2, Length(FFileName));
        i := 1;
        while FileExists(FAttachFilePath + FFileName) do
          begin
            FFileName := TFName1 + '_' + IntToStr(i) + '.' + TFName2;
            i := i + 1;
          end; {_ while FileExists(FAttachFilePath + FFileName) do _}

      // Modification made by Edward T. Smith Sep 09 1998
        if assigned(FOnDecodeStart) then
          FOnDecodeStart(FFileName);
      // End
        FMailMessage.FBody.add(#13#10 + sPOP_Cons_Msg_File + FFileName + sPOP_Cons_Msg_Extr);
        FMailMessage.FAttachments.Add(FFileName);
        FMailMessage.FContentTypes.Add(FMailMessage.Contenttype);
        if (Pos(Cons_Head_B641, Lowercase(FContent_type)) > 0) or (Pos(Cons_Head_UUEn, FContent_type) > 0) then
          begin
            Ins := TFileStream.create(FAttachFilePath + 'Temp' + IntToStr(TFileIndex) + '.mme', fmOpenRead);
            Ous := TFileStream.create(FAttachFilePath + FFilename, fmCreate);
            try
              NMUUProcessor1.InputStream := Ins;
              NMUUProcessor1.OutputStream := Ous;
              if (Pos(Cons_Head_UUEn, FContent_type) > 0) then NMUUProcessor1.method := UUCode else NMUUProcessor1.method := UUMime;
              StatusMessage(Status_Informational, sPOP_Cons_Msg_Deco);
              if ins.size <> 0 then NMUUProcessor1.Decode;
            finally
              Ins.free;
              Ous.free;
            end; {_ try _}
          end {_ if (Pos(Cons_Head_B641, FContent_type) > 0) or (Pos(Cons_Head_B642, FContent_type) > 0) or (Pos(Cons_Head_UUEn, FContent_type) > 0) then _}
        else {_ NOT if (Pos(Cons_Head_B641, FContent_type) > 0) or (Pos(Cons_Head_B642, FContent_type) > 0) or (Pos(Cons_Head_UUEn, FContent_type) > 0) then _}
          begin
            if FileExists(FAttachFilePath + FFilename) then DeleteFile(FAttachFilePath + FFilename);
            RenameFile(FAttachFilePath + 'Temp' + IntToStr(TFileIndex) + '.mme', FAttachFilePath + FFilename);
          end;
      end; {_ if not Fabort and (FFirstPart = 0) then _}
    if (Pos(MailMessage.FBoundary, ReplyMess) > 0) then
      begin
        ReplyMess := Copy(ReplyMess, Length(ReplyMess) - 3, 256);
        if Pos('--', ReplyMess) > 0 then result := true;
      end; {_ if (Pos(FBoundary, ReplyMess) > 0) then _}
    FFirstPart := 0;
  finally
    if FileExists(FAttachFilePath + 'Temp' + IntToStr(TFileIndex) + '.mme') then Deletefile(FAttachFilePath + 'Temp' + IntToStr(TFileIndex) + '.mme');
  end;
end; {_ function TNMPOP3.ReadBody: boolean; _}

procedure TNMPOP3.DeleteMailMessage(MailNumber: integer);
var ReplyMess: string;
  Done: boolean;
begin
  if not FTransactionInProgress then
    begin
      Done := FALSE;
      FTransactionInProgress := TRUE;
      try
        CertifyConnect;
        ReplyMess := Transaction(Cons_Cmd_Dele + IntToStr(MailNumber));
        if NthWord(ReplyMess, ' ', 1) = Cons_Err_Resp then
          begin
            if assigned(FOnFailure) then FOnFailure(self);
            raise Exception.create(ReplyMess);
          end {_ if NthWord(ReplyMess, ' ', 1) <> Cons_OK_Resp then _}
        else {_ NOT if NthWord(ReplyMess, ' ', 1) <> Cons_OK_Resp then _}  Done := TRUE;
      finally
        FTransactionInProgress := FALSE;
        if Done then
          if assigned(FOnSuccess) then
            FOnSuccess(self);
      end; {_ try _}
    end; {_ if not FTransactionInProgress then _}
end; {_ procedure TNMPOP3.DeleteMailMessage(MailNumber: integer); _}


function TNMPOP3.UniqueID(MailNumber: integer): string;
var ReplyMess: string;
begin
  if not FTransactionInProgress then
    begin
      Result := '';
      FTransactionInProgress := TRUE;
      try
        CertifyConnect;
        ReplyMess := Transaction(Cons_Cmd_Uidl + IntToStr(MailNumber));
        if NthWord(ReplyMess, ' ', 1) <> Cons_OK_Resp then
          begin
            if assigned(FOnFailure) then FOnFailure(self);
            raise Exception.create(ReplyMess);
          end {_ if NthWord(ReplyMess, ' ', 1) <> Cons_OK_Resp then _}
        else {_ NOT if NthWord(ReplyMess, ' ', 1) <> Cons_OK_Resp then _}
          Result := NthWord(ReplyMess, ' ', 3);
      finally
        FTransactionInProgress := FALSE;
      end; {_ try _}
    end; {_ if not FTransactionInProgress then _}
end;

procedure TNMPOP3.Abort;
begin
  Cancel;
  if Connected then
    begin
      //if FTransactionInProgress then
      //begin
      //   Cancel;
      //end {_ if FTransactionInProgress then _}
      //else {_ NOT if FTransactionInProgress then _}
      //begin
      inherited Disconnect;
      ClearInput;
      //end; {_ NOT if FTransactionInProgress then _}
    end; {_ if (not BeenCanceled) and Connected then _}
end; {_ procedure TNMPOP3.Abort; _}


procedure TNMPOP3.AbortResume(Sender: TObject);
begin
   //inherited Disconnect;
   //TMemoryStream(FIstream).clear;
end; {_ procedure TNMPOP3.AbortResume(Sender: TObject); _}

constructor TMailMessage.create;
begin
  FHead := TExStringList.create;
  FBody := TStringList.create;
  FAttachments := TStringList.create;
  FContentTypes := TStringList.create;
  FRawBody := TStringList.create;
  FPartHeaders := Tlist.Create;
end; {_ constructor TMailMessage.create; _}

destructor TMailMessage.destroy;
begin
  FHead.free;
  FBody.free;
  FAttachments.free;
  FContentTypes.free;
  FRawBody.free;
  FPartHeaders.free;
end; {_ destructor TMailMessage.destroy; _}

end.