delphi - 将邮件从 OutLook 拉到文件中

Question

从我的 Delphi 程序中，我希望能够从我的 OutLook 中的某个文件夹中检索所有邮件并将它们保存为文件。
我需要检索发件人、主题、日期和消息 ID，以便将信息保存在表格中(如果可能，更多部分)
我希望将每封邮件保存在一个文件中，以便以后可以访问它们。

Answer 1

这是完全可能的。您需要的是 Outlook 自动化。可以是普通的 Vanilla 类型，也可以是使用 Delphi 附带的 COM 服务器包装器的那种。如果您使用的是较新版本的 Delphi 之一，则可能必须安装相应的软件包才能在您的调色板中找到它们。见 How to get TExcelWorksheet (the 64-bit version) in XE2?了解更多信息。

有关如何使 Outlook 自动化的更多信息，请直接访问源:有关 Outlook COM 对象模型和 API 的文档的 MSDN:http://msdn.microsoft.com/en-us/library/ms268893(v=vs.80).aspx

另一个来源是 Deborah Pate 的 COM 编程站点。可能很久没更新了，但是里面的信息还是不错的，相关的:http://www.djpate.freeserve.co.uk/Automation.htm

示例代码

单元包含两个类来读取特定文件夹中的邮件。它使用 Delphi 形式的 Outlook COM 服务器包装器(一个非常旧的版本)，但您不需要将它们放在调色板上，因为它们是在代码中实例化的。当然，您确实需要在搜索路径上有 COM 包装器单元。

像这样实例化 TSiteMailList 类:

FMailList := TSiteMailList.Create('MAPI', 'Folder1', 'Folder2');

MAPI 是 Outlook MAPI 命名空间。 Folder1 和 Folder2 是 Outlook 邮件文件夹的名称。此处可以使用“收件箱”作为默认邮件收件箱。

TSiteMailList 类声明:

  TSiteMailList = class(TObject)
  private
    FShowUnreadOnly: boolean;
    FMails: TObjectList;

    FOutlook: TOutlookApplication;
    FNameSpace: NameSpace;
    FNewMailsFolder: MAPIFolder;
    FProcessedMailsFolder: MAPIFolder;
    function FindFolder(FolderPath: string): MAPIFolder;
    procedure LoadMails;
    function GetSiteMail(idx: integer): TSiteMail;
    function GetShowUnreadOnly: boolean;
    procedure SetShowUnreadOnly(const Value: boolean);
  protected
    function GetCount: integer;
  public
    constructor Create(MAPINameSpace: string; NewMailsFolder, ProcessedMailsFolder:
        string);
    destructor Destroy; override;
    procedure MarkAsProcessed(SiteMail: TSiteMail);
    procedure Reload;
    property ShowUnreadOnly: boolean read GetShowUnreadOnly write SetShowUnreadOnly;
    property Count: integer read GetCount;
    property SiteMail[idx: integer]: TSiteMail read GetSiteMail;
  end;

它的构造函数和析构函数:

constructor TSiteMailList.Create(MAPINameSpace: string; NewMailsFolder,
    ProcessedMailsFolder: string);
begin
  FOutlook := TOutlookApplication.Create( nil );
  FOutlook.ConnectKind := ckNewInstance;
  FOutlook.Connect;
  FNameSpace := FOutlook.GetNameSpace( MAPINameSpace );
  FNameSpace.Logon( '', '', False, False );
  FNewMailsFolder := FindFolder( NewMailsFolder );
  FProcessedMailsFolder := FindFolder( ProcessedMailsFolder );

  FShowUnreadOnly := false;
  FMails := TObjectList.Create( true );
  LoadMails;
end;

destructor TSiteMailList.Destroy;
begin
  FMails.Free;
  if FNameSpace <> nil then begin
    FNameSpace.Logoff;
  end;
  FOutlook.Disconnect;
  FOutlook.Free;

  inherited;
end;

Outlook 文件夹可以嵌套。传递给构造函数的文件夹名称可以使用“\”分隔文件夹名称。下面的代码解析路径并找到相应的 Outlook 文件夹:

procedure ExtractFolderFromPath(var path, folder: string);
var
  i: integer;
begin
  folder := '';
  if path[1] = '\' then begin
    path := Copy( path, 2, Length( path ) - 1 );
  end;
  i := Pos( '\', path );
  if i > 0 then begin
    folder := Copy( path, 1, i - 1 );
    path := Copy( path, i + 1, Length( path ) - i );
  end else begin
    folder := path;
    path := '';
  end;
end;

function TSiteMailList.FindFolder(FolderPath: string): MAPIFolder;
var
  path: string;
  foldername: string;
  xFolder: MAPIFolder;
begin
  path := FolderPath;
  ExtractFolderFromPath( path, foldername );
  if foldername <> '' then begin
    xFolder := FNameSpace.Folders.Item( foldername );
  end;
  while path <> '' do begin
    ExtractFolderFromPath( path, foldername );
    xFolder := xFolder.Folders.Item( foldername );
  end;
  Result := xFolder;
end;

getter 和 setter 非常简单，所以我把它们排除在外。 LoadMails 方法是访问文件夹中每个邮件项所需的方法:

procedure TSiteMailList.LoadMails;
var
  i: integer;
  GeneralItem: IDispatch;
  MI: MailItem;
begin
  FMails.Clear;
  for i := 1 to FNewMailsFolder.Items.Count do begin
    GeneralItem := FNewMailsFolder.Items.Item( i );
    if Sysutils.Supports(GeneralItem, MailItem, MI) then begin
      if not FShowUnreadOnly
      or ( FShowUnreadOnly and ( MI.Unread = true ) )
      then begin
        FMails.Add( TSiteMail.Create( i, MI ) );
      end;
    end;
  end;
end;

TSiteMailList 使用 TSiteMail 类来跟踪有关其构造函数的第一个文件夹参数指定的文件夹中的 Outlook 邮件项目的信息。 TSiteMail 类声明:

  TSiteMail = class(TObject)
  private
    FOutlookIdx: integer;
    FMailItem: MailItem;
    function GetIsRead: boolean;
    procedure SetIsRead(const Value: boolean);
  protected
    function GetBody: string;
    function GetFileCount: integer;
    function GetFileName(idx: integer): string;
    function GetReceived: TDateTime;
    function GetSender: string;
    function GetSubject: string;
  public
    constructor Create(idx: integer; MI: MailItem);
    destructor Destroy; override;
    function IndexOfFileName(Name: string): integer;
    procedure MoveToFolder(Folder: MAPIFolder);
    procedure SaveFile(idx: integer; FileName: string);

    property Body: string read GetBody;
    property FileCount: integer read GetFileCount;
    property FileName[idx: integer]: string read GetFileName;
    property IsRead: boolean read GetIsRead write SetIsRead;
    property Received: TDateTime read GetReceived;
    property Sender: string read GetSender;
    property Subject: string read GetSubject;
  end;

及其实现:

constructor TSiteMail.Create(idx: integer; MI: MailItem);
begin
  FOutlookIdx := idx;
  FMailItem := MI;
end;

destructor TSiteMail.Destroy;
begin
  FMailItem := nil; // Release interface
  inherited;
end;

function TSiteMail.GetBody: string;
begin
  Result := FMailItem.Body;
end;

function TSiteMail.GetFileCount: integer;
begin
  Result := FMailItem.Attachments.Count;
end;

function TSiteMail.GetFileName(idx: integer): string;
begin
  Result := FMailItem.Attachments.Item( idx + 1 ).FileName;
end;

function TSiteMail.GetIsRead: boolean;
begin
  Result := not FMailItem.UnRead;
end;

function TSiteMail.GetReceived: TDateTime;
begin
  Result := FMailItem.ReceivedTime;
end;

function TSiteMail.GetSender: string;
begin
  Result := FMailItem.SenderName;
end;

function TSiteMail.GetSubject: string;
begin
  Result := FMailItem.Subject;
end;

function TSiteMail.IndexOfFileName(Name: string): integer;
var
  idx: integer;
begin
  Result := -1;
  for idx := 1 to FMailItem.Attachments.Count do begin
    if CompareText( Name, FMailItem.Attachments.Item( idx ).FileName ) = 0 then begin
      Result := idx - 1;
      break;
    end;
  end;
end;

procedure TSiteMail.MoveToFolder(Folder: MAPIFolder);
begin
  FMailItem.Move( Folder );
end;

procedure TSiteMail.SaveFile(idx: integer; FileName: string);
begin
  FMailItem.Attachments.Item( idx + 1 ).SaveAsFile( FileName );
end;

procedure TSiteMail.SetIsRead(const Value: boolean);
begin
  FMailItem.UnRead := not Value;
end;