Development

unit unfrmmessage;
(*
 In this unit we will do the following:
 - When we are given Msgstore and ENTRYID of a Message, we will get an interface to the Imessage object.
 - We will require the following properties of the Imessage:

 PR_MESSAGE_CLASS -  property contains a text string that identifies t
 he sender-defined message class, such as IPM.Note
 PR_SUBJECT       -  property contains the full subject of a message
 PR_BODY          -  property contains the message text
 PR_SENDER_EMAIL_ADDRESS - property contains the message sender's e-mail address
 PR_HASATTACH     - property contains TRUE if a message contains at least one attachment
 PR_RTF_COMPRESSED- property contains the Rich Text Format version of the message text,
 usually in compressed form
 PR_RTF_IN_SYNC   - property contains TRUE if PR_RTF_COMPRESSED has the same
 text content as PR_BODY for this message

 - We will visualize the message text
 - If there are Attachments, we will find out their number and will define them
 - We will require the following attachment properties:

 PR_ATTACH_RENDERING - property contains a Microsoft Windows metafile
 with rendering information for an attachment
 PR_ATTACH_NUM       - property contains a number that uniquely identifies
 the attachment within its parent message
 PR_RENDERING_POSITION - property contains an offset, in characters,
 to use in rendering an attachment within the main
 message text
 PR_ATTACH_METHOD      - property contains a MAPI-defined constant
 representing the way the contents of an attachment
 can be accessed
 PR_ATTACH_LONG_FILENAME - property contains an attachment's long filename
 and extension, excluding path
 PR_ATTACH_FILENAME - property contains an attachment's base filename
 and extension, excluding path
 PR_ATTACH_SIZE     - property contains the sum, in bytes, of the sizes
 of all properties on an attachment
*)

interface

{$I IMI.INC}

uses
  Classes, Controls, Forms, Graphics, ComCtrls, ExtCtrls, StdCtrls,
  ExtendedMAPI;

type
  TfrmMessage = class(TForm)
    Panel1: TPanel;
    Label1: TLabel;
    lbMessageClass: TLabel;
    Label2: TLabel;
    lbMessageSubject: TLabel;
    MessageBody: TRichEdit;
    Label3: TLabel;
    lbMessageSender: TLabel;
    Label4: TLabel;
    lbMessageAttachments: TLabel;
    Panel2: TPanel;
    lbAttachments: TListBox;
    Label5: TLabel;
    AttachmentImage: TImage;
    procedure lbAttachmentsClick(Sender: TObject);
  private
    { Private declarations }
    HR: HRESULT;
  public
    { Public declarations }

    procedure OpenMessage(MsgStore: ImsgStore; MessageENTRYID: PSBinary);
  end;

var
  frmMessage: TfrmMessage;

implementation

uses Dialogs, Windows, SysUtils, ActiveX, MAPIUtils, MAPIMacros, EDK;
{$R *.DFM}
{$I XE.INC}

procedure TfrmMessage.OpenMessage(MsgStore: ImsgStore; MessageENTRYID: PSBinary);
var
  BytesRead, BytesRead2, ObjType: ULONG;
  MAPIMessage: IMessage;
  AttachmentPropTagArray, MessagePropTagArray: PSPropTagArray;
  MessagePropValueArray: PSPropValue;
  IsUpdated: BOOL;
  HasAttachments: boolean;
  RTFStreamCompressed, RTFStreamUncompressed, MetafileStream: IStream;
  StreamOle: IStream;
  AttachmentTable: IMAPITable;
  Prows: PSRowSet;
  Atachment: IAttach;
  StreamBuffer: array [0 .. 4095] of byte;
  DestinationStream: TStream;
  BodyStream: TStringStream;
  CurSeekPos: {$IFDEF DELPHI2015XE8} UINT64 {$ELSE} Largeint {$ENDIF} ;
  cb: ULONG;
  Metafile: TMetafile;
  MetafileHandle: THandle;
  MetaFilePict: TMetafilePict;
  Canvas: TCanvas;
  notUsed: HWND;
  AttachementName: String;
  PAttachement: PChar;
  i: ULONG;
begin
  AttachmentImage.Picture.Graphic := nil;
  DestinationStream := nil;
  MessagePropTagArray := nil;
  MessagePropValueArray := nil;
  RTFStreamCompressed := nil;
  RTFStreamUncompressed := nil;
  AttachmentTable := nil;
  AttachmentPropTagArray := nil;
  Prows := nil;
  Atachment := nil;
  MetafileStream := nil;
  StreamOle := nil;

  (*
   We get an interface to the MAPI Message object
   *)
  try
    HR := MsgStore.OpenEntry(MessageENTRYID.cb, PENTRYID(MessageENTRYID.lpb), @IID_IMessage, MAPI_BEST_ACCESS, ObjType, IUnknown(MAPIMessage));
    if Failed(HR) then
    begin
      ShowMessage(GetMAPIError(MsgStore, HR));
      Exit;
    end;

    (*
     We will build a PropTagArray containing
     the MAPI Message properties that we require
     *)

    HR := SizedSPropTagArray([PR_MESSAGE_CLASS, PR_SUBJECT, CHANGE_PROP_TYPE(PR_BODY, PT_UNSPECIFIED), PR_SENDER_EMAIL_ADDRESS, PR_HASATTACH,
      PR_RTF_COMPRESSED, PR_RTF_IN_SYNC], MessagePropTagArray);
    if Failed(HR) then
    begin
      ShowMessage(GetMAPIError(nil, HR));
      Exit;
    end;

    ObjType := 0;
    (*
     We take the required properties
     *)

    HR := MAPIMessage.GetProps(MessagePropTagArray, 0, ObjType, MessagePropValueArray);
    if Failed(HR) then
    begin
      ShowMessage(GetMAPIError(MAPIMessage, HR));
      Exit;
    end;

    // We assign each property that we take  to label, memo, etc...
    if Assigned(MessagePropValueArray) then
    begin
      if (PSPropValueArray(MessagePropValueArray)[0].ulPropTag = PR_MESSAGE_CLASS) and Assigned(PSPropValueArray(MessagePropValueArray)[0].Value.lpsz) then
        lbMessageClass.Caption := StrPas(PSPropValueArray(MessagePropValueArray)[0].Value.lpsz)
      else
        lbMessageClass.Caption := 'Not Defined';

      lbMessageClass.Hint := lbMessageClass.Caption;

      if (PSPropValueArray(MessagePropValueArray)[1].ulPropTag = PR_SUBJECT) and Assigned(PSPropValueArray(MessagePropValueArray)[1].Value.lpsz) then
        lbMessageSubject.Caption := StrPas(PSPropValueArray(MessagePropValueArray)[1].Value.lpsz)
      else
        lbMessageSubject.Caption := 'No Subject';

      lbMessageSubject.Hint := lbMessageSubject.Caption;

      MessageBody.Lines.Clear;

      if (PROP_TYPE(PSPropValueArray(MessagePropValueArray)[2].ulPropTag) <> PT_ERROR) // PR_BODY
      then
      begin
        if PROP_TYPE(PSPropValueArray(MessagePropValueArray)[2].ulPropTag) = PT_STRING8 then
          MessageBody.Lines.LoadFromStream(TStringStream.Create(AnsiString(PSPropValueArray(MessagePropValueArray)[2].Value.lpszA)));
        if PROP_TYPE(PSPropValueArray(MessagePropValueArray)[2].ulPropTag) = PT_UNICODE then
          MessageBody.Lines.LoadFromStream(TStringStream.Create(WideString(PSPropValueArray(MessagePropValueArray)[2].Value.lpszW)));
      end
      else
      begin
        if PSPropValueArray(MessagePropValueArray)[2].Value.Err = MAPI_E_NOT_ENOUGH_MEMORY then
        begin
          hr := MAPIMessage.OpenProperty(PR_BODY_A, @IID_IStream,
            // interface ID reference
            STGM_READ, // interface flags
            MAPI_DEFERRED_ERRORS, // reduces RPCs
            IUnknown(StreamOle));
          if not Failed(hr) then
          begin
            BodyStream := TStringStream.Create(''{$IFDEF DELPHI2009}, TEncoding.ascii {$ENDIF});
            try
              IStreamToStream(StreamOle, BodyStream);
              BodyStream.Position := 0;
              MessageBody.Lines.LoadFromStream(BodyStream);
            finally
              FreeAndNil(BodyStream);
            end;
          end;
        end;
      end;

      if (PSPropValueArray(MessagePropValueArray)[3].ulPropTag = PR_SENDER_EMAIL_ADDRESS) and Assigned(PSPropValueArray(MessagePropValueArray)[3].Value.lpsz)
        then
        lbMessageSender.Caption := StrPas(PSPropValueArray(MessagePropValueArray)[3].Value.lpsz)
      else
        lbMessageSender.Caption := '';

      lbMessageSender.Hint := lbMessageSender.Caption;
      HasAttachments := False;

      if (PSPropValueArray(MessagePropValueArray)[4].ulPropTag = PR_HASATTACH) then
        HasAttachments := boolean(PSPropValueArray(MessagePropValueArray)[4].Value.b);

      if HasAttachments then
        lbMessageAttachments.Caption := 'True'
      else
        lbMessageAttachments.Caption := 'False';

      // If FORMATED RTF BODY exists, we will visualize it.
      if (PSPropValueArray(MessagePropValueArray)[5].ulPropTag = PR_RTF_COMPRESSED) then
      begin
        // RTFSync
        // Ensures that the rich text format (RTF) body of a message
        // matches the plain text body.
        // It is necessary to call this function before reading the RTF body
        // and after modifying the RTF body.

        if (PSPropValueArray(MessagePropValueArray)[6].ulPropTag = PR_RTF_IN_SYNC) and (BOOL(PSPropValueArray(MessagePropValueArray)[6].Value.b) = False) then
        begin
          HR := RTFSync(MAPIMessage, RTF_SYNC_BODY_CHANGED, IsUpdated);

          if Failed(HR) then
          begin
            ShowMessage('MAPI Error on RTFSync');
            Exit;
          end;

          // If the value of the isUpdated parameter is set to TRUE,
          // then IMAPIProp.SaveChanges should be called for the message.
          // RTFSync does not call SaveChanges as part of its implementation.
          // If SaveChanges is not called the modifications will not be saved in the message.

          if IsUpdated then
            HR := MAPIMessage.SaveChanges(0); // KEEP_OPEN_READWRITE

          if Failed(HR) then
          begin
            ShowMessage(GetMAPIError(MAPIMessage, HR));
            Exit;
          end;
        end;

        // Opening compressed RTF
        HR := MAPIMessage.OpenProperty(PR_RTF_COMPRESSED, @IID_IStream, 0, MAPI_DEFERRED_ERRORS, IUnknown(RTFStreamCompressed));

        if Failed(HR) then
        begin
          ShowMessage(GetMAPIError(MAPIMessage, HR));
          Exit;
        end;

        // WrapCompressedRTFStream returns a stream containing the uncompressed
        // RTF body of a message.

        HR := WrapCompressedRTFStream(RTFStreamCompressed, 0, RTFStreamUncompressed);

        if Failed(HR) then
        begin
          ShowMessage(GetMAPIError(nil, HR) + #13#10 + 'Error in the execution of WrapCompressedRTFStream');
          Exit;
        end;

        ZeroMemory(@StreamBuffer, Length(StreamBuffer));
        BytesRead := 0;

        DestinationStream := TMemoryStream.Create;
        HR := RTFStreamUncompressed.Read(@StreamBuffer, Length(StreamBuffer) - 1, @BytesRead);

        if Failed(HR) then
        begin
          ShowMessage('Error in the execution of RTFStreamUncompressed');
          Exit;
        end;

        repeat
          DestinationStream.WriteBuffer(StreamBuffer, BytesRead);
          HR := RTFStreamUncompressed.Read(@StreamBuffer, Length(StreamBuffer), @BytesRead);
        until BytesRead <= 0;

        DestinationStream.Position := 0;
        MessageBody.Lines.LoadFromStream(DestinationStream);
        DestinationStream.Free;
        DestinationStream := nil;
      end; // PR_RTF_COMPRESSED

      // �If there are Attachments, we need to open the Attachment Table
      if HasAttachments then
      begin
        HR := MAPIMessage.GetAttachmentTable(0, AttachmentTable);

        if Failed(HR) then
        begin
          ShowMessage(GetMAPIError(MAPIMessage, HR));
          Exit;
        end;

        (*
         We build PropTagArray for the Attachments Properties
         that we are interested in
         *)
        HR := SizedSPropTagArray([PR_ATTACH_RENDERING, PR_ATTACH_NUM, PR_RENDERING_POSITION, PR_ATTACH_METHOD, PR_ATTACH_LONG_FILENAME, PR_ATTACH_FILENAME,
          PR_ATTACH_SIZE], AttachmentPropTagArray);

        if Failed(HR) then
        begin
          ShowMessage('Error in the building of Attachments PropTagArray');
          Exit;
        end;

        lbAttachments.Items.Clear;

        (*
         We assume that the number of attachments in the message
         will not be extremely large,
         so we will use the HrQueryAllRows function
         *)

        cb := 0;

        HR := HrQueryAllRows(AttachmentTable, AttachmentPropTagArray, nil, nil, cb, Prows);
        if Failed(HR) then
        begin
          ShowMessage('Error in the execution of HrQueryAllRows');
          Exit;
        end;

        (*
         If the attachment is inbuilt in the body of the text
         (e.g. when you "drag and drop" MS WORD file into message)
         we will visualize the icon associated to the file.
         *)

        if Assigned(Prows) and (Prows.cRows > 0) then
        begin
          lbMessageAttachments.Caption := IntToStr(Prows.cRows);

          Metafile := nil;

          for cb := 0 to Prows.cRows - 1 do
          begin
            if (PSPropValueArray(Prows.aRow[cb].lpProps)[AttachmentPropTagArray.cValues - 5].ulPropTag = PR_RENDERING_POSITION) and
              (PSPropValueArray(Prows.aRow[cb].lpProps)[AttachmentPropTagArray.cValues - 5].Value.L <> -1) and
              (PSPropValueArray(Prows.aRow[cb].lpProps)[AttachmentPropTagArray.cValues - 7].ulPropTag = PR_ATTACH_RENDERING) and
              (PSPropValueArray(Prows.aRow[cb].lpProps)[AttachmentPropTagArray.cValues - 7].Value.bin.cb > 0) then
            begin
              Atachment := nil;
              HR := MAPIMessage.OpenAttach(PSPropValueArray(Prows.aRow[cb].lpProps)[AttachmentPropTagArray.cValues - 6].Value.L, @IID_IAttachment,
                MAPI_BEST_ACCESS or MAPI_DEFERRED_ERRORS, Atachment);
              if Failed(HR) then
              begin
                ShowMessage(GetMAPIError(MAPIMessage, HR));
                Exit;
              end;

              MetafileStream := nil;

              // We will request metafile with rendering information for an attachment
              HR := Atachment.OpenProperty(PR_ATTACH_RENDERING, @IID_IStream, 0, MAPI_DEFERRED_ERRORS, IUnknown(MetafileStream));
              if Failed(HR) then
              begin
                ShowMessage(GetMAPIError(Atachment, HR));
                Exit;
              end;

              ZeroMemory(@StreamBuffer, Length(StreamBuffer));
              BytesRead := 0;

              HR := MetafileStream.Seek(0, STREAM_SEEK_SET, CurSeekPos);

              if Failed(HR) then
              begin
                ShowMessage('MAPI Error');
                Exit;
              end;

              BytesRead2 := 0;
              repeat
                HR := MetafileStream.Read(@StreamBuffer, Length(StreamBuffer), @BytesRead);
                if Failed(HR) then
                begin
                  ShowMessage('MAPI Error');
                  Exit;
                end;
                BytesRead2 := BytesRead2 + BytesRead;
              until BytesRead <= 0;

              Canvas := TCanvas.Create;
              Canvas.Handle := GetDeviceContext(notUsed);

              MetafileHandle := SetWinMetaFileBits(BytesRead2, @StreamBuffer, GetDC(Canvas.Handle), MetaFilePict);

              Metafile := TMetafile.Create;
              Metafile.ReleaseHandle;
              Metafile.Handle := MetafileHandle;
              MetafileStream := nil;
              AttachementName := '';

              HR := HrMAPIGetPropString(Atachment, PR_ATTACH_LONG_FILENAME, i, Pointer(PAttachement));
              if not Failed(HR) then
              begin
                AttachementName := String(PAttachement);
                MAPIFreeBuffer(PAttachement);
              end;

              if AttachementName = '' then
                HR := HrMAPIGetPropString(Atachment, PR_ATTACH_FILENAME, i, Pointer(PAttachement));
              if not Failed(HR) then
              begin
                AttachementName := String(PAttachement);
                MAPIFreeBuffer(PAttachement);
              end;

              Atachment := nil;
            end; // Attachments

            begin
              Atachment := nil;
              HR := MAPIMessage.OpenAttach(PSPropValueArray(Prows.aRow[cb].lpProps)[AttachmentPropTagArray.cValues - 6].Value.L, @IID_IAttachment,
                MAPI_BEST_ACCESS or MAPI_DEFERRED_ERRORS, Atachment);

              AttachementName := '';
              HR := HrMAPIGetPropString(Atachment, PR_ATTACH_LONG_FILENAME, i, Pointer(PAttachement));
              if not Failed(HR) then
              begin
                AttachementName := String(PAttachement);
                MAPIFreeBuffer(PAttachement);
              end;

              if AttachementName = '' then
              begin
                HR := HrMAPIGetPropString(Atachment, PR_ATTACH_FILENAME, i, Pointer(PAttachement));
                if not Failed(HR) then
                begin
                  AttachementName := String(PAttachement);
                  MAPIFreeBuffer(PAttachement);
                end;
              end;

              Atachment := nil;
            end;

            if (AttachementName = '') and (PSPropValueArray(Prows.aRow[cb].lpProps)[AttachmentPropTagArray.cValues - 3].ulPropTag = PR_ATTACH_LONG_FILENAME)
              then
              AttachementName := StrPas(PSPropValueArray(Prows.aRow[cb].lpProps)[AttachmentPropTagArray.cValues - 3].Value.lpsz);

            if (AttachementName = '') and (PSPropValueArray(Prows.aRow[cb].lpProps)[AttachmentPropTagArray.cValues - 2].ulPropTag = PR_ATTACH_FILENAME) then
              AttachementName := StrPas(PSPropValueArray(Prows.aRow[cb].lpProps)[AttachmentPropTagArray.cValues - 2].Value.lpsz);

            if (AttachementName <> '') and (PSPropValueArray(Prows.aRow[cb].lpProps)[AttachmentPropTagArray.cValues - 1].ulPropTag = PR_ATTACH_SIZE) then
              lbAttachments.Items.AddObject(AttachementName + ' -> ' + FormatFloat('###' + ThousandSeparator + '###' + ThousandSeparator + '##0',
                  ((PSPropValueArray(Prows.aRow[cb].lpProps)[AttachmentPropTagArray.cValues - 1].Value.L) div 1024)) + ' K', Metafile);
          end;
        end;
      end; // if HasAttachments then
    end; // if Assigned(MessagePropValueArray) then
  finally
    if Assigned(DestinationStream) then
      DestinationStream.Free;
    if Assigned(MessagePropTagArray) then
      MAPIFreeBuffer(MessagePropTagArray);
    MessagePropTagArray := nil;
    if Assigned(MessagePropValueArray) then
      MAPIFreeBuffer(MessagePropValueArray);
    MessagePropValueArray := nil;
    RTFStreamCompressed := nil;
    RTFStreamUncompressed := nil;
    AttachmentTable := nil;
    AttachmentPropTagArray := nil;
    Prows := nil;
    Atachment := nil;
    MetafileStream := nil;
  end;
end;

procedure TfrmMessage.lbAttachmentsClick(Sender: TObject);
var
  iCount: integer;
begin
  for iCount := 0 to (lbAttachments.Items.Count - 1) do
    if lbAttachments.Selected[iCount] then
      if Assigned(lbAttachments.Items.Objects[iCount]) then
        AttachmentImage.Picture.Graphic := TMetafile(lbAttachments.Items.Objects[iCount]);
end;

end.