outlooktarget.pas

来自「Drag files and Drop to delphi forms 0402」· PAS 代码 · 共 855 行 · 第 1/2 页

unit OutlookTarget;

interface

uses
  MapiDefs,
  Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
  ExtCtrls, ComCtrls, StdCtrls, DragDrop, DropTarget, DragDropText, ImgList,
  Menus;

type
  TMessage = class(TObject)
  private
    FMessage: IMessage;
    FAttachments: TInterfaceList;
    FAttachmentsLoaded: boolean;
    function GetAttachments: TInterfaceList;
  public
    constructor Create(const AMessage: IMessage);
    destructor Destroy; override;
    property Msg: IMessage read FMessage;
    property Attachments: TInterfaceList read GetAttachments;
  end;

  TFormOutlookTarget = class(TForm)
    DataFormatAdapterOutlook: TDataFormatAdapter;
    DropEmptyTarget1: TDropEmptyTarget;
    ImageListSmall: TImageList;
    StatusBar1: TStatusBar;
    ImageListBig: TImageList;
    PanelMain: TPanel;
    ListViewBrowser: TListView;
    PanelFrom: TPanel;
    Label1: TLabel;
    EditFrom: TEdit;
    PanelTo: TPanel;
    Label2: TLabel;
    ScrollBox1: TScrollBox;
    ListViewTo: TListView;
    PanelSubject: TPanel;
    Label3: TLabel;
    EditSubject: TEdit;
    MemoBody: TRichEdit;
    SplitterAttachments: TSplitter;
    ListViewAttachments: TListView;
    SplitterBrowser: TSplitter;
    PopupMenu1: TPopupMenu;
    MenuAttachmentViewLargeIcons: TMenuItem;
    MenuAttachmentViewSmallIcons: TMenuItem;
    MenuAttachmentViewList: TMenuItem;
    MenuAttachmentViewDetails: TMenuItem;
    MenuAttachmentOpen: TMenuItem;
    MenuAttachmentView: TMenuItem;
    N1: TMenuItem;
    procedure FormCreate(Sender: TObject);
    procedure FormDestroy(Sender: TObject);
    procedure DropTextTarget1Drop(Sender: TObject; ShiftState: TShiftState;
      APoint: TPoint; var Effect: Integer);
    procedure ListViewToInfoTip(Sender: TObject; Item: TListItem;
      var InfoTip: String);
    procedure ListViewAttachmentsDblClick(Sender: TObject);
    procedure ListViewAttachmentsDeletion(Sender: TObject;
      Item: TListItem);
    procedure ListViewBrowserDeletion(Sender: TObject; Item: TListItem);
    procedure ListViewBrowserSelectItem(Sender: TObject; Item: TListItem;
      Selected: Boolean);
    procedure MenuAttachmentViewLargeIconsClick(Sender: TObject);
    procedure MenuAttachmentViewSmallIconsClick(Sender: TObject);
    procedure MenuAttachmentViewListClick(Sender: TObject);
    procedure MenuAttachmentViewDetailsClick(Sender: TObject);
    procedure ListViewAttachmentsResize(Sender: TObject);
  private
    FCleanUpList: TStringList;
    FOwnedMessage: TMessage;

    procedure Reset;
    procedure ResetView;
    procedure CleanUp;
    procedure ViewMessage(AMessage: TMessage);
    procedure ReadBodyText(const AMessage: IMessage);
    procedure AddAttachment(const Attachment: IAttach; Number: integer);
    function GetSender(const AMessage: IMessage): string;
    function GetSubject(const AMessage: IMessage): string;
    procedure FormatAttachmentList;
  public
    property OwnedMessage: TMessage read FOwnedMessage write FOwnedMessage;
  end;

var
  FormOutlookTarget: TFormOutlookTarget;

implementation

{$R *.DFM}

uses
  MapiUtil,
  MapiTags,
  ComObj,
  ActiveX,
  ShellAPI,
  // Note: In order to get the Outlook data format support linked into the
  // application, we have to include the appropriate units in the uses clause.
  // If you forget to do this, you will get a run time error.
  // The DragDropFormats unit contains the TFileContentsStorageClipboardFormat class.
  // The DragDropInternet unit contains the TOutlookDataFormat class.
  DragDropFormats,
  DragDropInternet;


constructor TMessage.Create(const AMessage: IMessage);
begin
  FMessage := AMessage;
  FAttachments := TInterfaceList.Create;
end;

destructor TMessage.Destroy;
begin
  FAttachments.Free;
  inherited Destroy;
end;

{$RANGECHECKS OFF}
function TMessage.GetAttachments: TInterfaceList;
const
  AttachmentTags: packed record
    Values: ULONG;
    PropTags: array[0..0] of ULONG;
  end = (Values: 1; PropTags: (PR_ATTACH_NUM));

var
  Table: IMAPITable;
  Rows: PSRowSet;
  i: integer;
  Attachment: IAttach;
begin
  if (not FAttachmentsLoaded) then
  begin
    FAttachmentsLoaded := True;
    (*
    ** Get list of attachment interfaces from message
    **
    ** Note: This will only succeed the first time it is called for an IMessage.
    ** The reason is probably that it is illegal (according to MSDN) to call
    ** IMessage.OpenAttach more than once for a given attachment. However, it
    ** might also be a bug in my code, but whatever the reason the solution is
    ** beyond the scope of this demo.
    ** Let me know if you find a solution.
    *)
    if (Succeeded(FMessage.GetAttachmentTable(0, Table))) then
    begin
      if (Succeeded(HrQueryAllRows(Table, @AttachmentTags, nil, nil, 0, Rows))) then
        try
          for i := 0 to integer(Rows.cRows)-1 do
          begin
            // Get one attachment at a time
            if (Rows.aRow[i].lpProps[0].ulPropTag and PROP_TYPE_MASK <> PT_ERROR) and
              (Succeeded(FMessage.OpenAttach(Rows.aRow[i].lpProps[0].Value.l, IAttach, 0, Attachment))) then
              FAttachments.Add(Attachment);
          end;

        finally
          FreePRows(Rows);
        end;
      Table := nil;
    end;
  end;
  Result := FAttachments;
end;
{$RANGECHECKS ON}

type
  TMAPIINIT_0 =
    record
      Version: ULONG;
      Flags: ULONG;
    end;

  PMAPIINIT_0 = ^TMAPIINIT_0;
  TMAPIINIT = TMAPIINIT_0;
  PMAPIINIT = ^TMAPIINIT;

const
  MAPI_INIT_VERSION = 0;
  MAPI_MULTITHREAD_NOTIFICATIONS = $00000001;
  MAPI_NO_COINIT = $00000008;

var
  MapiInit: TMAPIINIT_0 = (Version: MAPI_INIT_VERSION; Flags: 0);

procedure TFormOutlookTarget.FormCreate(Sender: TObject);
var
  SHFileInfo: TSHFileInfo;
begin
  try
    // It appears that for for Win XP and later it is OK to let MAPI call
    // coInitialize.
    // V5.1 = WinXP.
//    if ((Win32MajorVersion shl 16) or Win32MinorVersion < $00050001) then
//      MapiInit.Flags := MapiInit.Flags or MAPI_NO_COINIT;

    OleCheck(MAPIInitialize(@MapiInit));
  except
    on E: Exception do
      ShowMessage(Format('Failed to initialize MAPI: %s', [E.Message]));
  end;

  // FCleanUpList contains a list of temporary files that should be deleted
  // before the application exits.
  FCleanUpList := TStringList.Create;

  // Get the system image list to use for the attachment listview.
  ImageListSmall.Handle := SHGetFileInfo('', 0, SHFileInfo, sizeOf(SHFileInfo),
    SHGFI_SYSICONINDEX or SHGFI_SMALLICON);
  ImageListBig.Handle := SHGetFileInfo('', 0, SHFileInfo, sizeOf(SHFileInfo),
    SHGFI_SYSICONINDEX or SHGFI_LARGEICON);

  ListViewBrowser.Visible := False;
  SplitterBrowser.Visible := False;
end;

procedure TFormOutlookTarget.FormDestroy(Sender: TObject);
begin
  CleanUp;
  FreeAndNil(FCleanUpList);
  FreeAndNil(FOwnedMessage); 
  MAPIUninitialize;
end;

procedure TFormOutlookTarget.CleanUp;
var
  i: integer;
begin
  for i := 0 to FCleanUpList.Count-1 do
    try
      DeleteFile(FCleanUpList[i]);
    except
      // Ignore errors - nothing we can do about it anyway.
    end;

  FCleanUpList.Clear;
end;

procedure TFormOutlookTarget.Reset;
begin
  ListViewBrowser.Items.Clear;
  ListViewBrowser.Visible := False;
  SplitterBrowser.Visible := False;
  ResetView;
end;

procedure TFormOutlookTarget.ResetView;
begin
  ListViewTo.Items.Clear;
  ListViewTo.Height := 0;
  EditFrom.Text := '';
  EditFrom.Hint := '';
  EditSubject.Text := '';
  MemoBody.Lines.Clear;
  ListViewAttachments.Items.Clear;
  SplitterAttachments.Hide;
  ListViewAttachments.Hide;
end;

procedure TFormOutlookTarget.DropTextTarget1Drop(Sender: TObject;
  ShiftState: TShiftState; APoint: TPoint; var Effect: Integer);
var
  OutlookDataFormat: TOutlookDataFormat;
  i: integer;
  Item: TListItem;
  AMessage: IMessage;
begin
  // Check if we have a data format and if so...
  if (DataFormatAdapterOutlook.DataFormat <> nil) then
  begin
    // ...Extract the dropped data from it.
    OutlookDataFormat := DataFormatAdapterOutlook.DataFormat as TOutlookDataFormat;

    (*
    ** Reset everything
    *)
    Reset;

    CleanUp;

    // Get all the dropped messages
    for i := 0 to OutlookDataFormat.Messages.Count-1 do
    begin
      // Get an IMessage interface
      if (Supports(OutlookDataFormat.Messages[i], IMessage, AMessage)) then
      begin
        Item := ListViewBrowser.Items.Add;
        Item.Caption := GetSender(AMessage);
        Item.SubItems.Add(GetSubject(AMessage));
        Item.Data := TMessage.Create(AMessage);
      end;
    end;

    StatusBar1.SimpleText := Format('%d messages dropped', [ListViewBrowser.Items.Count]);

    if (ListViewBrowser.Items.Count > 1) then
    begin
      ListViewBrowser.Visible := True;
      SplitterBrowser.Left := Width;
      SplitterBrowser.Visible := True;
    end;

    // If there's only one message, display it without further ado
    if (ListViewBrowser.Items.Count = 1) then
      ViewMessage(TMessage(ListViewBrowser.Items[0].Data))
    else
      // Otherwise select and display the first message
      if (ListViewBrowser.Items.Count > 0) then
        ListViewBrowser.Items[0].Selected := True;
  end;
end;

procedure TFormOutlookTarget.ListViewBrowserDeletion(Sender: TObject;
  Item: TListItem);
begin
  // Zap TMessage object
  if (Item.Data <> nil) then
    TObject(Item.Data).Free;
end;

procedure TFormOutlookTarget.ListViewBrowserSelectItem(Sender: TObject;
  Item: TListItem; Selected: Boolean);
begin
  (*
  ** Display the message details when we select a message in the browser listview
  *)
  if (Selected) and (Item.Data <> nil) then
    ViewMessage(TMessage(Item.Data));
end;

function TFormOutlookTarget.GetSender(const AMessage: IMessage): string;
var
  Prop: PSPropValue;
begin
  if (Succeeded(HrGetOneProp(AMessage, PR_SENDER_NAME, Prop))) then
    try
      Result := Prop.Value.lpszA;
    finally
      MAPIFreeBuffer(Prop);
    end
  else
    Result := '';
end;

function TFormOutlookTarget.GetSubject(const AMessage: IMessage): string;
var
  Prop: PSPropValue;
begin
  if (Succeeded(HrGetOneProp(AMessage, PR_SUBJECT, Prop))) then
    try
      Result := Prop.Value.lpszA;
    finally
      MAPIFreeBuffer(Prop);
    end
  else
    Result := '';
end;

{$RANGECHECKS OFF}
procedure TFormOutlookTarget.ViewMessage(AMessage: TMessage);
const
  AddressTags: packed record
    Values: ULONG;
    PropTags: array[0..1] of ULONG;
  end = (Values: 2; PropTags: (PR_DISPLAY_NAME, PR_EMAIL_ADDRESS));

var
  i: integer;
  Prop: PSPropValue;
  Table: IMAPITable;
  Rows: PSRowSet;
  Name, Address: string;
  r: TRect;
begin
  ResetView;

  (*
  ** Get Recipients
  *)
  if (Succeeded(AMessage.Msg.GetRecipientTable(0, Table))) then
  begin
    if (Succeeded(HrQueryAllRows(Table, @AddressTags, nil, nil, 0, Rows))) then
      try
        for i := 0 to integer(Rows.cRows)-1 do
        begin
          if (Rows.aRow[i].lpProps[0].ulPropTag = PR_DISPLAY_NAME) then
            Name := Rows.aRow[i].lpProps[0].Value.lpszA
          else
            Name := '';

          if (Rows.aRow[i].lpProps[1].ulPropTag = PR_EMAIL_ADDRESS) then
            Address := Rows.aRow[i].lpProps[1].Value.lpszA
          else
            Address := '';

          with ListViewTo.Items.Add do
          begin
            Caption := Name;
            SubItems.Add(Address);
          end;
        end;

        if (ListViewTo.Items.Count > 0) then
        begin
          r := ListViewTo.Items[0].DisplayRect(drBounds);
          ListViewTo.Height := ListViewTo.Items.Count*(r.Bottom-r.Top+2);
        end;

      finally
        FreePRows(Rows);
      end;
    Table := nil;
  end;

  (*
  ** Get sender
  *)
  if (Succeeded(HrGetOneProp(AMessage.Msg, PR_SENDER_EMAIL_ADDRESS, Prop))) then
    try
      Address := Prop.Value.lpszA;
    finally
      MAPIFreeBuffer(Prop);
    end