outlooktarget.pas

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

  else
    Address := '';
  EditFrom.Text := GetSender(AMessage.Msg);
  EditFrom.Hint := Address;

  (*
  ** Get subject
  *)
  EditSubject.Text := GetSubject(AMessage.Msg);

  (*
  ** Get body
  *)
  ReadBodyText(AMessage.Msg);

  (*
  ** Get attachments
  *)
  for i := 0 to AMessage.Attachments.Count-1 do
    AddAttachment(IAttach(AMessage.Attachments[i]), i);

  (*
  ** Only display attachment listview if msg has any attachments.
  *)
  if (ListViewAttachments.Items.Count > 0) then
  begin
    FormatAttachmentList;
    r := ListViewAttachments.Items[0].DisplayRect(drBounds);
    ListViewAttachments.Height := r.Bottom-r.Top+6;
    ListViewAttachments.Top := 0;
    ListViewAttachments.Show;
    SplitterAttachments.Top := 0;
    SplitterAttachments.Show;
  end;

end;
{$RANGECHECKS ON}

procedure TFormOutlookTarget.ListViewToInfoTip(Sender: TObject;
  Item: TListItem; var InfoTip: String);
begin
  // Display email address as a hint
  InfoTip := Item.SubItems[0];
end;

procedure TFormOutlookTarget.ReadBodyText(const AMessage: IMessage);
var
  Data, Chunk: string;
  SourceStream: IStream;
  Size: integer;
  Dummy: int64;
begin
  MemoBody.Lines.Clear;

  (*
  ** We could use HrGetOneProp to get the message body, but since we would like
  ** to limit the amount of data we read, and the body can potentially be quite
  ** big, we read the body text from a stream instead.
  **
  if (Succeeded(HrGetOneProp(AMessage, PR_BODY, Prop))) then
    try
      MemoBody.Lines.Text := Prop.Value.lpszA;
    finally
      MAPIFreeBuffer(Prop);
    end;
  *)

  if (Succeeded(AMessage.OpenProperty(PR_BODY, IStream, STGM_READ, 0, IUnknown(SourceStream)))) then
  begin
    SetLength(Chunk, 64*1024);
    Data := '';

    // Read up to 256Kb from stream
    SourceStream.Seek(0, STREAM_SEEK_SET, Dummy);
    while (Succeeded(SourceStream.Read(PChar(Chunk), Length(Chunk), @Size))) and
      (Size > 0) and (Length(Data) < 1024*1024*256) do
    begin
      Data := Data+Copy(Chunk, 1, Size);
    end;

    MemoBody.Lines.Text := Data;
  end;
end;

const
  // Attachment listview column indices
  ColType = 0;
  ColSize = 1;
  ColDisplay = 2;
  ColFile = 3;

procedure TFormOutlookTarget.AddAttachment(const Attachment: IAttach; Number: integer);
var
  Method: integer;
  Item: TListItem;
  Prop: PSPropValue;
  s: string;
  Size: integer;
  Stream: IStream;
  Pos: Largeint;
  Msg: IMessage;
  SHFileInfo: TSHFileInfo;
begin
  Item := ListViewAttachments.Items.Add;
  Item.Caption := ''; // Formatted name
  Item.SubItems.Add(''); // File type
  Item.SubItems.Add(''); // Formatted size
  Item.SubItems.Add(''); // Display name
  Item.SubItems.Add(''); // File name
  Item.ImageIndex := 0;

  // Try to get size of attachment (incl. properties and other overhead).
  // Note: This seems to be the correct way of getting the attachment size, but
  // I have never seen the call succeed.
  if (Succeeded(HrGetOneProp(Attachment, PR_ATTACH_SIZE, Prop))) then
    try
      Size := Prop.Value.l;
    finally
      MAPIFreeBuffer(Prop);
    end
  else
    Size := 0;

  if (Succeeded(HrGetOneProp(Attachment, PR_ATTACH_METHOD, Prop))) then
    try
      Method := Prop.Value.l;
    finally
      MAPIFreeBuffer(Prop);
    end
  else
    Method := -1;

  case Method of
    ATTACH_BY_VALUE:
      // Attachment is a file stored in an IStream object
      begin
        // Get size of attachment stream
        if (Size = 0) and
          (Succeeded(Attachment.OpenProperty(PR_ATTACH_DATA_BIN, IStream, STGM_READ, 0, IUnknown(Stream)))) then
        begin
          Stream.Seek(0, STREAM_SEEK_END, Pos);
          Size := Pos;
        end;

        // Get attachment filename
        if (Succeeded(HrGetOneProp(Attachment, PR_ATTACH_FILENAME, Prop))) then
          try
            s := Prop.Value.lpszA;
          finally
            MAPIFreeBuffer(Prop);
          end
        else
          s := '';

        if (s = '') then
          s := format('Attachment %d', [Number]);

        Item.SubItems[ColDisplay] := s;
      end;

    ATTACH_BY_REFERENCE,
    ATTACH_BY_REF_RESOLVE,
    ATTACH_BY_REF_ONLY:
      // Attachment is a link to a file
      begin
        // Get attachment path
        if (Succeeded(HrGetOneProp(Attachment, PR_ATTACH_PATHNAME, Prop))) then
          try
            s := Prop.Value.lpszA;
          finally
            MAPIFreeBuffer(Prop);
          end
        else
          s := '';

        if (s = '') then
          s := format('File reference %d', [Number]);
        Item.SubItems[ColDisplay] := s;
      end;

    ATTACH_EMBEDDED_MSG:
      // Attachment is a message stored in an IMessage object
      begin
        // Get size of message
        if (Size = 0) and
          (Succeeded(Attachment.OpenProperty(PR_ATTACH_DATA_OBJ, IMessage, 0, 0, IUnknown(Msg)))) then
        begin
          if (Succeeded(HrGetOneProp(Msg, PR_MESSAGE_SIZE, Prop))) then
            try
              Size := Prop.Value.l;
            finally
              MAPIFreeBuffer(Prop);
            end
          else
            Size := 0;
        end;


        s := GetSubject(Msg);
        if (s = '') then
          s := format('Embedded message %d', [Number]);
        Item.SubItems[ColDisplay] := s;
        Item.SubItems[ColFile] := s+'.msg';
      end;

    // Attachment is a OLE object stored in a IStream or IStorage object
    ATTACH_OLE:
      begin
        Item.SubItems[ColDisplay] := 'OLE object';
      end;
  else
    // Unsupported attachment
    Item.SubItems[ColDisplay] := 'Unknown attachment';
  end;

  if (Item.SubItems[ColFile] = '') then
    Item.SubItems[ColFile] := Item.SubItems[ColDisplay];

  // Get the icon associated with the attachment file type
  // Beware: SHGetFileInfo can change the "current directory"
  if (Succeeded(SHGetFileInfo(PChar(Item.SubItems[ColFile]), 0, SHFileInfo, sizeOf(SHFileInfo),
      SHGFI_USEFILEATTRIBUTES or SHGFI_SYSICONINDEX or SHGFI_LARGEICON or SHGFI_TYPENAME))) then
  begin
    Item.ImageIndex := SHFileInfo.iIcon;
    Item.SubItems[ColType] := SHFileInfo.szTypeName;
  end;

  // Format the attachment size
  if (Size > 1024*1014) then
    Item.SubItems[ColSize] := IntToStr(Size div (1024*1024))+'Mb'
  else
    if (Size > 1024) then
      Item.SubItems[ColSize] := IntToStr(Size div 1024)+'Kb'
    else
      if (Size > 0) then
        Item.SubItems[ColSize] := IntToStr(Size)+' bytes'
      else
        Item.SubItems[ColSize] := '';

  // Save interface for later.
  // According to MSDN an Attachment can be opened only once (IMessage.OpenAttach).
  Item.Data := pointer(Attachment);

  // Now that the interface is stored and managed in list items's data property,
  // we avoid decrementing the reference count here.
//  pointer(Attachment) := nil;
end;

procedure TFormOutlookTarget.ListViewAttachmentsDeletion(Sender: TObject;
  Item: TListItem);
begin
  // Zap reference to IAttachment object
//  if (Item.Data <> nil) then
//    IUnknown(Item.Data)._Release;
end;

function MAPIAllocateBuffer(cbSize: ULONG; var lppBuffer: pointer): SCODE; stdcall; external 'mapi32.dll';
function MAPIFreeBuffer(lpBuffer: pointer): ULONG; stdcall; external 'mapi32.dll';

procedure TFormOutlookTarget.ListViewAttachmentsDblClick(Sender: TObject);

  procedure Execute(const FileName: string);
  begin
    if (FileName = '') then
      exit;

    // ... launch the file's default application to open it.
    Screen.Cursor := crAppStart;
    try
      Application.ProcessMessages; {otherwise cursor change will be missed}
      ShellExecute(0, nil, PChar(FileName), nil, nil, SW_NORMAL);
    finally
      Screen.Cursor := crDefault;
    end;

    // Add temp file to list of files to be deleted before we exit
    if (FCleanUpList.IndexOf(FileName) = -1) then
      FCleanUpList.Add(FileName);
  end;

var
  Attachment: IAttach;

  Method: integer;
  Prop: PSPropValue;

  FileName: string;
  SourceStream, DestStream: IStream;
  Dummy: int64;

  Msg: IMessage;

begin
  if (ListViewAttachments.Selected <> nil) and (ListViewAttachments.Selected.Data <> nil) then
  begin
    Attachment := IAttach(ListViewAttachments.Selected.Data);

    if (not Succeeded(HrGetOneProp(Attachment, PR_ATTACH_METHOD, Prop))) then
      exit;

    try
      Method := Prop.Value.l;
    finally
      MAPIFreeBuffer(Prop);
    end;

    case Method of
      ATTACH_BY_VALUE:
        // Attachment is a file stored in an IStream object
        begin
          OleCheck(Attachment.OpenProperty(PR_ATTACH_DATA_BIN, IStream, STGM_READ, 0, IUnknown(SourceStream)));

          FileName := ExtractFilePath(Application.ExeName)+
            ListViewAttachments.Selected.SubItems[ColFile];

          // Extract the attachment to an external file and...
          SourceStream.Seek(0, STREAM_SEEK_SET, Dummy);
          OleCheck(OpenStreamOnFile(@MAPIAllocateBuffer, @MAPIFreeBuffer, STGM_CREATE or STGM_READWRITE,
            PChar(FileName), nil, DestStream));
          // Another way to do it: DestStream := TFixedStreamAdapter.Create(TFileStream.Create(FileName, fmCreate), soOwned);
          SourceStream.CopyTo(DestStream, -1, Dummy, Dummy);
          DestStream := nil;

          Execute(FileName);
        end;

      ATTACH_BY_REFERENCE,
      ATTACH_BY_REF_RESOLVE,
      ATTACH_BY_REF_ONLY:
        // Attachment is a link to a file
        begin
          // Get attachment path
          if (not Succeeded(HrGetOneProp(Attachment, PR_ATTACH_PATHNAME, Prop))) then
            exit;
          try
            FileName := Prop.Value.lpszA;
          finally
            MAPIFreeBuffer(Prop);
          end;

          Execute(FileName);
        end;

      ATTACH_EMBEDDED_MSG:
        // Attachment is a message stored in an IMessage object
        begin
          // Get size of message
          if (Succeeded(Attachment.OpenProperty(PR_ATTACH_DATA_OBJ, IMessage, 0, 0, IUnknown(Msg)))) then
          begin
            with TFormOutlookTarget.Create(Self) do
            begin
              OwnedMessage := TMessage.Create(Msg);
              ViewMessage(OwnedMessage);
              Show;
              Msg := nil;
            end;
          end;
        end;

      // Attachment is a OLE object stored in a IStream or IStorage object
      ATTACH_OLE:
        // Note: The actual handling of the OLE object is beyond the scope of
        // this demo. You'll have to figure it out for yourself.
        exit;
    else
      // Unsupported attachment
      exit;
    end;
  end;
end;

procedure TFormOutlookTarget.FormatAttachmentList;
var
  i: integer;
begin
  for i := 0 to ListViewAttachments.Items.Count-1 do
    if (not MenuAttachmentViewDetails.Checked) then
    begin
      if (ListViewAttachments.Items[i].SubItems[ColSize] <> '') then
        // Display attachment as "filename (size)"
        ListViewAttachments.Items[i].Caption :=
          format('%s (%s)', [ListViewAttachments.Items[i].SubItems[ColDisplay],
            ListViewAttachments.Items[i].SubItems[ColSize]])
      else
        // Display attachment as "filename"
        ListViewAttachments.Items[i].Caption :=
          ListViewAttachments.Items[i].SubItems[ColDisplay];
    end else
      ListViewAttachments.Items[i].Caption := ListViewAttachments.Items[i].SubItems[ColDisplay];
end;

procedure TFormOutlookTarget.MenuAttachmentViewLargeIconsClick(Sender: TObject);
begin
  TMenuItem(Sender).Checked := True;
  FormatAttachmentList;
  ListViewAttachments.ViewStyle := vsIcon;
end;

procedure TFormOutlookTarget.MenuAttachmentViewSmallIconsClick(Sender: TObject);
begin
  TMenuItem(Sender).Checked := True;
  FormatAttachmentList;
  ListViewAttachments.ViewStyle := vsSmallIcon;
end;

procedure TFormOutlookTarget.MenuAttachmentViewListClick(Sender: TObject);
begin
  TMenuItem(Sender).Checked := True;
  FormatAttachmentList;
  ListViewAttachments.ViewStyle := vsList;
end;

procedure TFormOutlookTarget.MenuAttachmentViewDetailsClick(Sender: TObject);
begin
  TMenuItem(Sender).Checked := True;
  FormatAttachmentList;
  ListViewAttachments.ViewStyle := vsReport;
end;

procedure TFormOutlookTarget.ListViewAttachmentsResize(Sender: TObject);
begin
  // Work around list view resize/repaint bug.
  ListViewAttachments.Repaint;
end;

end.