من یکی دو سال پیش، برای یک نفر، کد زیر رو نوشته بودم، تا کلیت انجام همچین کاری دستش بیاد. این کد از Indy 10 استفاده میکنه، و یک کلاس مشتق شده از TThread را پیاده سازی میکنه که در یک Thread مستقل، در فواصل زمانی مشخص، به یک Mail Server (به طور پیش فرض GMail) وصل میشه، و پوشه Inbox آن را برای وجود پیام های جدید بررسی میکنه، و علاوه بر اینکه وجود پیام جدید را اطلاع میده، آدرس ارسال کننده و موضوع هر ایمیل جدید را هم بررسی میکنه، و اگر ایمیل حاوی موضوع مورد نظر کاربر بود، یا از آدرس مورد نظر کاربر فرستاده شده بود، کل محتوای اون ایمیل را دانلود، و در اختیار کاربر قرار میده. می تونید از همین کد برای بررسی چگونگی چک کردن ایمیل از طریق IMAP استفاده کنید.
(************************************************* ******************************)
/// <summary>
/// Contains TMailChecker class.
/// </summary>
///
/// <author> Ali Keshavarz </author>
///
/// <email> vcldeveloper - g mail com </email>
///
/// <date> 11/20/2009 </date>
/// <update> 01/06/2010 </update>
/// LICENSE NOTICE:
/// This work is licensed under the Creative Commons Attribution 3.0 Unported
/// License. To view a copy of this license, visit
/// http://creativecommons.org/licenses/by/3.0/
/// or send a letter to Creative Commons, 171 Second Street, Suite 300,
/// San Francisco, California, 94105, USA.
(************************************************* ******************************)
unit uMailChecker;
//{$DEFINE DEBUG_MODE}
interface
uses
Classes, SysUtils {$IFDEF MSWINDOWS} , Windows {$ENDIF},
IdComponent, IdExplicitTLSClientServerBase, IdIMAP4, IdSSLOpenSSL, IdMessage,
IdLogFile;
type
/// <summary>
/// Event for sending error message. ErrorMsg is the error message
/// which is raised.
/// </summary>
TErrorNotify = procedure (Sender: TObject; const ErrorMsg: string; IsFatal: Boolean) of object;
/// <summary>
/// Event for sending number of unread messages, and number of messages that
/// are found matching the specified criteria in Senders and Subjects properties.
/// </summary>
TMailBoxCheckedNotify = procedure (Sender: TObject; UnseenCount, FoundCount: Cardinal) of object;
/// <summary>
/// Event for notifying the caller of a received message or message header.
/// </summary>
TMessageNotify = procedure (Sender: TObject; Msg: TIdMessage) of object;
/// <summary>
/// Event for sending status text to other thread about connection.
/// </summary>
TStatusNotify = procedure (Sender: TObject; const StatusText: string) of object;
/// <summary>
/// TMailChecker is a TThread descendant which connects to a given IMAP server
/// and checks it for unread messages periodically. If a message matches its
/// Senders and Subjects properties, it retrieves that message.
/// </summary>
TMailChecker = class(TThread)
strict private
FInterval : Cardinal;
FIsWorking : Boolean;
FMailBox : string;
FOnError : TErrorNotify;
FOnLoggedIn : TNotifyEvent;
FOnLoggedOut : TNotifyEvent;
FOnMailBoxChecked : TMailBoxCheckedNotify;
FOnMessageFound : TMessageNotify;
FOnStatus : TStatusNotify;
FOnUnseenMessage : TMessageNotify;
FSenders : TStrings;
FSubjects : TStrings;
/// Handle of synchronization Event object which is used for periodical mailbox checking.
FSyncEvent : THandle;
FSyncObject : TMREWSync;
function GetHost: string;
function GetPassword: string;
function GetPort: Word;
function GetTLS: TIdUseTLS;
function GetUserName: string;
procedure SetHost(const Value: string);
procedure SetName;
procedure SetPassword(const Value: string);
procedure SetPort(Value: Word);
procedure SetSenders(Value: TStrings);
procedure SetSubjects(Value: TStrings);
procedure SetTLS(Value: TIdUseTLS);
procedure SetUserName(const Value: string);
private
///Indicates if the error occured is a fatal OS exception.
FErrorIsFatal : Boolean;
/// Error message to be sent to DoOnError method
FErrorMsg : string;
/// IMAP4 component
FImap : TIdIMAP4;
/// Number of messages found matching Senders or Subjects properties.
FFoundCount : Cardinal;
/// IdMessage object to store a found or unread email message.
FFoundMsg : TIdMessage;
/// Indy Intercept object for logging IMAP communication in debug mode.
{$IFDEF DEBUG_MODE}FLogIntercept : TIdLogFile;{$ENDIF}
/// OpenSSL IO Handler
FSSLSocketHandler : TIdSSLIOHandlerSocketOpenSSL;
/// Status text to be sent to DoOnStatus method
FStatusText : string;
/// Number of unread messages found in the mailbox.
FUnseenCount : Cardinal;
procedure DoOnIMAP4Status(Sender: TObject; const AStatus: TIdStatus; const AStatusText: string);
procedure DoOnIMAP4WorkPart(Sender: TObject; AWorkMode: TWorkMode; AWorkCount: Int64);
function LookupMessage(MsgNum: Integer): Boolean;
protected
procedure CheckMailBox;
procedure DoOnError; virtual;
procedure DoOnLoggedIn; virtual;
procedure DoOnLoggedOut; virtual;
procedure DoOnMailBoxChecked; virtual;
procedure DoOnMessageFound; virtual;
procedure DoOnStatus; virtual;
procedure DoOnUnseenMessage; virtual;
procedure Execute; override;
function MailBoxHasRecentMessages: Boolean; virtual;
public
constructor Create;
destructor Destroy; override;
procedure StartWork;
procedure StopWork;
/// <summary>
/// IMAP host URI. Default = imap.gmail.com
/// </summary>
property Host : string read GetHost write SetHost;
/// <summary>
/// Time interval for checking mailbox for arrived messages. Default = 30 seconds.
/// </summary>
property Interval : Cardinal read FInterval write FInterval default 300000;
/// <summary>
/// Specifies whether the thread is working or not.
/// </summary>
property IsWorking : Boolean read FIsWorking default False;
/// <summary>
/// IMAP MailBox to be checked. Do not modify this value from another thread
/// when IsWorking is True.
/// </summary>
property MailBox : string read FMailBox write FMailBox;
/// <summary>
/// Returns error message to main thread when an exception is raised during
/// execution of the thread.
/// </summary>
property OnError: TErrorNotify read FOnError write FOnError;
/// <summary>
/// Notifies main thread that login to remote server is done successfully.
/// </summary>
property OnLoggedIn : TNotifyEvent read FOnLoggedIn write FOnLoggedIn;
/// <summary>
/// Notifies main thread that log out from remote server is done successfully.
/// </summary>
property OnLoggedOut : TNotifyEvent read FOnLoggedOut write FOnLoggedOut;
/// <summary>
/// Notifies main thread that mailbox is checked, and returns number of unread
/// and found messages.
/// </summary>
property OnMailBoxChecked : TMailBoxCheckedNotify read FOnMailBoxChecked write FOnMailBoxChecked;
/// <summary>
/// Notifies main thread that a message matching either a value in Senders
/// or Subjects lists is found. Msg contains the full message header and body.
/// </summary>
property OnMessageFound : TMessageNotify read FOnMessageFound write FOnMessageFound;
/// <summary>
/// Returns connection status to main thread.
/// </summary>
property OnStatus : TStatusNotify read FOnStatus write FOnStatus;
/// <summary>
/// Notifies main thread that an unseen message is available in the mailbox.
/// Msg returns header part of the message, not its body.
/// </summary>
property OnUnseenMessage : TMessageNotify read FOnUnseenMessage write FOnUnseenMessage;
/// <summary> User account password on server. </summary>
property Password : string read GetPassword write SetPassword;
/// <summary> Remote server port number. </summary>
property Port : Word read GetPort write SetPort;
/// <summary>
/// List of email addresses which should be found in the From field of each
/// unread message on the mailbox.
/// </summary>
/// <remarks>
/// Do not modify this list without synchronized access if IsWorking = True.
/// Use SyncObject for synchronized access to this list.
/// </remarks>
property Senders : TStrings read FSenders write SetSenders;
/// <summary>
/// List of subjects which should be found in the Subject field of each
/// unread message on the mailbox.
/// </summary>
/// <remarks>
/// Do not modify this list without synchronized access if IsWorking = True.
/// Use SyncObject for synchronized access to this list.
/// </remarks>
property Subjects : TStrings read FSubjects write SetSubjects;
/// <summary>
/// Synchronization object which is provided for synchronized access to
/// Subjects and Senders properties.
/// </summary>
property SyncObject : TMREWSync read FSyncObject;
/// <summary> TLS mode to be used for SSL connection </summary>
property TLS : TIdUseTLS read GetTLS write SetTLS;
/// <summary> User account user name on server. </summary>
property UserName : string read GetUserName write SetUserName;
end;
implementation
resourcestring
StrConnecting = 'Connecting...';
StrCannotOpenMailBoc = 'Cannot open selected mail box';
StrCannotRetireveFoundMsg = 'Cannot retireve found message';
StrThreadExecutionIsFinished = 'Thread execution is finished. Create a new instance';
{$IFDEF MSWINDOWS}
type
TThreadNameInfo = record
FType: LongWord; // must be 0x1000
FName: PAnsiChar; // pointer to name (in user address space)
FThreadID: LongWord; // thread ID (-1 indicates caller thread)
FFlags: LongWord; // reserved for future use, must be zero
end;
{$ENDIF}
{ TMailChecker }
constructor TMailChecker.Create;
begin
inherited Create(True);
FSyncEvent := CreateEvent(nil,True,True,'MailCheckerEvent');
FSyncObject := TMREWSync.Create;
FSenders := TStringList.Create;
FSubjects := TStringList.Create;
FFoundMsg := TIdMessage.Create;
{$IFDEF DEBUG_MODE}
FLogIntercept := TIdLogFile.Create;
FLogIntercept.LogTime := True;
FLogIntercept.Filename := ExtractFilePath(ParamStr(0)) + 'LogFile.txt';
FLogIntercept.Active := True;
{$ENDIF}
FSSLSocketHandler := TIdSSLIOHandlerSocketOpenSSL.Create;
FSSLSocketHandler.SSLOptions.Method := sslvSSLv23;
{$IFDEF DEBUG_MODE}
FSSLSocketHandler.Intercept := FLogIntercept;
{$ENDIF}
FImap := TIdIMAP4.Create;
FImap.IOHandler := FSSLSocketHandler;
FImap.OnStatus := DoOnIMAP4Status;
FImap.OnWorkForPart := DoOnIMAP4WorkPart;
//Set default values for GMail account
FImap.Host := 'imap.gmail.com';
FImap.Port := 993;
FImap.UseTLS := utUseImplicitTLS;
FIsWorking := False;
FMailBox := 'INBOX';
FInterval := 300000; //5 mins
end;
destructor TMailChecker.Destroy;
begin
FImap.Free;
FSSLSocketHandler.Free;
{$IFDEF DEBUG_MODE}
FLogIntercept.Close;
FLogIntercept.Free;
{$ENDIF}
FSenders.Free;
FSubjects.Free;
FFoundMsg.Free;
FSyncObject.Free;
inherited;
end;
procedure TMailChecker.CheckMailBox;
var
Flags: TIdMessageFlagsSet;
MsgNum: Integer;
begin
try
//Connect to the server
if not FImap.Connected then
begin
FStatusText := StrConnecting;
Queue(DoOnStatus);
FImap.Connect(True);
Queue(DoOnLoggedIn);
end;
//Set active folder on the server
if FImap.SelectMailBox(FMailBox) then
begin
//If there is no recent messages, then cancel this round of checking.
if not MailBoxHasRecentMessages then
Exit;
//Iterate through all messages in the mailbox.
for MsgNum := 1 to FImap.MailBox.TotalMsgs do
begin
if Terminated then Break;
//Only look for messages that are {recent and} not already read
FImap.RetrieveFlags(MsgNum,Flags);
if (not (mfSeen in Flags)) {and (mfRecent in Flags)} then
begin
//Retrive message header
if FImap.RetrieveHeader(MsgNum,FFoundMsg) then
begin
Inc(FUnseenCount);
Synchronize(DoOnUnseenMessage);
//Check if the message matches Subjects and Senders properties.
if LookupMessage(MsgNum) then
Inc(FFoundCount);
end;
end;
FFoundMsg.Clear;
end; // for
//Notify main thread that mail box check is done.
Queue(DoOnMailBoxChecked);
end // if SelectMailBox
else
raise Exception.Create(StrCannotOpenMailBoc);
except
//Return exception via OnError event
on E: Exception do
begin
//Disconnect in case any error occured to force a reconnect in the next
//loop iteration. Do not omit False param, it prevents Disconnect to
//raise any exception during disconnection.
FImap.Disconnect(False);
FErrorMsg := E.Message;
//check if the exception is a fatal OS exception.
FErrorIsFatal := (E is EExternal);
//Notify main thread about the Exception.
Synchronize(DoOnError);
end;
end;
end;
procedure TMailChecker.DoOnMailBoxChecked;
begin
if Assigned(FOnMailBoxChecked) then
FOnMailBoxChecked(Self,FUnseenCount,FFoundCount);
end;
procedure TMailChecker.DoOnMessageFound;
begin
if Assigned(FOnMessageFound) then
FOnMessageFound(Self,FFoundMsg);
end;
procedure TMailChecker.DoOnStatus;
begin
if Assigned(FOnStatus) then
FOnStatus(Self,FStatusText);
end;
procedure TMailChecker.DoOnUnseenMessage;
begin
if Assigned(FOnUnseenMessage) then
FOnUnseenMessage(Self,FFoundMsg);
end;
procedure TMailChecker.DoOnError;
begin
if Assigned(FOnError) then
FOnError(Self,FErrorMsg,FErrorIsFatal);
end;
procedure TMailChecker.DoOnIMAP4Status(Sender: TObject; const AStatus: TIdStatus; const AStatusText: string);
begin
FStatusText := AStatusText;
Queue(DoOnStatus);
end;
/// <summary>
/// This event handler is invoked by FImap4.OnWorkPart event. Refer to TIdIMAP4.OnWorkPart docummentaion.
/// </summary>
procedure TMailChecker.DoOnIMAP4WorkPart(Sender: TObject; AWorkMode: TWorkMode; AWorkCount: Int64);
begin
try
//If thread is terminated during retrival of a message content, then stop transfer
if Terminated then
FImap.Disconnect();
except
//Suppress any exception that might happen during diconnection
end;
end;
procedure TMailChecker.DoOnLoggedIn;
begin
if Assigned(FOnLoggedIn) then
FOnLoggedIn(Self);
end;
procedure TMailChecker.DoOnLoggedOut;
begin
if Assigned(FOnLoggedOut) then
FOnLoggedOut(Self);
end;
/// <summary>
/// Main execution code for the thread.
/// </summary>
procedure TMailChecker.Execute;
begin
SetName;
try
FIsWorking := True;
repeat
//Make the event non-signaled so that it will make a delay at the end of the loop.
ResetEvent(FSyncEvent);
FUnseenCount := 0;
FFoundCount := 0;
//Check mailbox for unread messages
CheckMailBox;
until Terminated or (WaitForSingleObject(FSyncEvent,FInterval) = WAIT_OBJECT_0);
finally
FImap.Disconnect;
FIsWorking := False;
Synchronize(DoOnLoggedOut);
end;
end;
function TMailChecker.GetHost: string;
begin
Result := FImap.Host;
end;
function TMailChecker.GetPassword: string;
begin
Result := FImap.Password;
end;
function TMailChecker.GetPort: Word;
begin
Result := FImap.Port;
end;
function TMailChecker.GetTLS: TIdUseTLS;
begin
Result := FImap.UseTLS;
end;
function TMailChecker.GetUserName: string;
begin
Result := FImap.UserName;
end;
/// <summary>
/// Looks up Senders and Subjects list to find out if any of their entires match
/// the given message.
/// </summary>
/// <param name="MsgNum">Message number to be retrieved from mailbox.</param>
function TMailChecker.LookupMessage(MsgNum: Integer): Boolean;
var
MsgList: array of Integer;
Flags : TIdMessageFlagsSet;
begin
//Synchronize access to Subjects and Senders lists.
FSyncObject.BeginRead;
try
//Check if the message matches the senders or subjects we are
//looking for.
Result := (FSenders.IndexOf(FFoundMsg.From.Address) >= 0) or
(FSubjects.IndexOf(FFoundMsg.Subject) >= 0);
if Result then
begin
//Retrieve full message (Header + Body)
if FImap.Retrieve(MsgNum, FFoundMsg) then
begin
//Mark the message on the server as Seen (Read)
SetLength(MsgList, 1);
MsgList[0] := MsgNum;
Flags := FFoundMsg.Flags;
Include(Flags, mfSeen);
if FImap.Connected then
begin
FImap.StoreFlags(MsgList, sdReplace, Flags);
//Notify main thread that full message is ready
Synchronize(DoOnMessageFound);
end;
end
else
raise Exception.Create(StrCannotRetireveFoundMsg);
end;
finally
FSyncObject.EndRead;
end; //try-finally ->FSyncObject
end;
function TMailChecker.MailBoxHasRecentMessages: Boolean;
begin
{BUG: Google's IMAP implementaion does not support "\Recent" flag, so
codes which check for this flag will fail!
Result := (FImap.MailBox.RecentMsgs <= 0); }
Result := True;
end;
procedure TMailChecker.SetHost(const Value: string);
begin
FImap.Host := Value;
end;
procedure TMailChecker.SetName;
{$IFDEF MSWINDOWS}
var
ThreadNameInfo: TThreadNameInfo;
{$ENDIF}
begin
{$IFDEF MSWINDOWS}
ThreadNameInfo.FType := $1000;
ThreadNameInfo.FName := 'Mail Checker';
ThreadNameInfo.FThreadID := $FFFFFFFF;
ThreadNameInfo.FFlags := 0;
try
RaiseException( $406D1388, 0, sizeof(ThreadNameInfo) div sizeof(LongWord), @ThreadNameInfo );
except
end;
{$ENDIF}
end;
procedure TMailChecker.SetPassword(const Value: string);
begin
FImap.Password := Value;
end;
procedure TMailChecker.SetPort(Value: Word);
begin
FImap.Port := Value;
end;
procedure TMailChecker.SetSenders(Value: TStrings);
begin
FSenders.Assign(Value);
end;
procedure TMailChecker.SetSubjects(Value: TStrings);
begin
FSubjects.Assign(Value);
end;
procedure TMailChecker.SetTLS(Value: TIdUseTLS);
begin
FImap.UseTLS := Value;
end;
procedure TMailChecker.SetUserName(const Value: string);
begin
FImap.UserName := Value;
end;
/// <summary>
/// Starts thread for checking mail.
/// </summary>
/// <remarks>
/// Take note that once the thread is started it runs until StopWork
/// method is called. When the thread is stopped using StopWork method, it cannot
/// be resumed by calling StartWork method. You need to create a new instance of
/// TMailChecker every time StopWork method is called.
/// If StartWork is called after calling StopWork in the same instance, an exception
/// will raise.
/// </remarks>
procedure TMailChecker.StartWork;
begin
if Suspended then
Resume
else
raise Exception.Create(StrThreadExecutionIsFinished);
end;
/// <summary>
/// Stops thread.
/// </summary>
/// <remarks>
/// Take note that once the thread is started it runs until StopWork
/// method is called. When the thread is stopped using StopWork method, it cannot
/// be resumed by calling StartWork method. You need to create a new instance of
/// TMailChecker every time StopWork method is called.
/// </remarks>
procedure TMailChecker.StopWork;
begin
SetEvent(FSyncEvent);
Terminate;
end;
end.