Development

unit unfrmmessage;

interface

{$I IMI.INC}

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

type
  TMessageAttachment = record
    Name: string;
    ATTACH_NUM: longint;
    ATTACH_METHOD: longint;
    Picture: TMetafile;
  end;

  PMessageAttachment = ^TMessageAttachment;

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;
    bgSave: TButton;
    SaveDialog1: TSaveDialog;
    btSaveMessage: TButton;
    SaveDialogMessage: TSaveDialog;
    Image1: TImage;
    procedure lbAttachmentsClick(Sender: TObject);
    procedure FormClose(Sender: TObject; var Action: TCloseAction);
    procedure bgSaveClick(Sender: TObject);
    procedure btSaveMessageClick(Sender: TObject);
  private
    { Private declarations }
    hr: HRESULT;
    MAPIMessage: IMessage;
    procedure ProcessAttachment;
    procedure SaveAttachment(ATTACH_NUM, ATTACH_METHOD: ULONG;
      AttachName: string);
  public
    { Public declarations }

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

var
  frmMessage: TfrmMessage;

implementation

uses
{$IFDEF DELPHI2011XE2}
UITypes,
{$ENDIF}
ActiveX, SysUtils, ComObj, EDK, MAPIUtils, MAPIMacros, ShellApi;
{$R *.DFM}
{$I XE.INC}

procedure TfrmMessage.OpenMessage(MsgStore: ImsgStore;
  MessageENTRYID: PSBinary);
var
  ObjType: ULONG;

  MessagePropTagArray: PSPropTagArray;

  MessagePropValueArray: PSPropValue;

  HasAttachments: boolean;

  RTFStreamCompressed, RTFStreamUncompressed: IStream;

  BodyStream: TStringStream;

type
  MessagePropEnum = (mcPR_MESSAGE_CLASS, mcPR_SUBJECT, mcPR_BODY,
    mcPR_SENDER_EMAIL_ADDRESS, mcPR_HASATTACH, mcPR_RTF_COMPRESSED,
    mcPR_RTF_IN_SYNC);

  procedure LoadMessageBody;
  begin
    hr := MAPIMessage.OpenProperty(PR_BODY_A, @IID_IStream, STGM_READ,
      MAPI_DEFERRED_ERRORS, IUnknown(RTFStreamCompressed));

    if Failed(hr) and (hr<>MAPI_E_NOT_FOUND)  then
    begin
      ShowMessage(GetMAPIError(MAPIMessage, hr));
      Exit;
    end;

    BodyStream := TStringStream.Create(''
{$IFDEF DELPHI2009}, TEncoding.ascii {$ENDIF});
    try
      IStreamToStream(RTFStreamCompressed, BodyStream);
      BodyStream.Position := 0;
      MessageBody.Lines.LoadFromStream(BodyStream);
    finally
      FreeAndNil(BodyStream);
    end;
    RTFStreamCompressed := nil;

  end;

  procedure LoadRTF;
  var
    RTF_IN_SYNC: Bool;
    IsUpdated, mustsync: Bool;
    SupMask: ULONG;
  begin
    (* PR_RTF_IN_SYNC
      A value of TRUE means that the PR_BODY property, the plain text version of this message,
      and the PR_RTF_COMPRESSED property, the Rich Text Format version, are identical
      except for white space in PR_BODY and formatting in PR_RTF_COMPRESSED.
      The text in the two versions consists of the same characters in the same sequence.
      A value of FALSE means that the two versions are not synchronized for text content
      but are capable of being synchronized by the RTFSync function.
      One version has been altered and the other version has not.
      No value, PR_RTF_IN_SYNC is not set at all, means that the two versions,
      if both exist or ever existed, cannot be synchronized.
      One version has been deleted or altered so radically that synchronization is
      no longer possible.
    *)

    hr := HrMAPIGetPropBoolean(MAPIMessage, PR_RTF_IN_SYNC, RTF_IN_SYNC);
    if Failed(hr) and (hr <> MAPI_E_NOT_FOUND) then
    begin
      ShowMessage(GetMAPIError(MAPIMessage, hr));
      Exit;
    end;

    hr := HrMAPIGetPropLong(MAPIMessage, PR_STORE_SUPPORT_MASK, SupMask);
    if Failed(hr) then
    begin
      ShowMessage(GetMAPIError(MAPIMessage, hr));
      Exit;
    end;

    mustsync := true;

    if ((SupMask and STORE_RTF_OK) <> 0) then
      mustsync := false
    else if RTF_IN_SYNC <> true then
      mustsync := false;

    if (mustsync) 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.

      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, STGM_READ,
      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.
    if Bool(SupMask and STORE_UNCOMPRESSED_RTF) then
      SupMask := STORE_UNCOMPRESSED_RTF
    else
      SupMask := 0;
    hr := WrapCompressedRTFStream(RTFStreamCompressed, SupMask,
      RTFStreamUncompressed);

    if Failed(hr) then
    begin
      ShowMessage('WrapCompressedRTFStream Error');
      Exit;
    end;

    BodyStream := TStringStream.Create(''
{$IFDEF DELPHI2009}, TEncoding.ascii {$ENDIF});

    try
      IStreamToStream(RTFStreamUncompressed, BodyStream);
      BodyStream.Position := 0;
      MessageBody.Lines.LoadFromStream(BodyStream);
    finally
      FreeAndNil(BodyStream);
    end;

    RTFStreamCompressed := nil;

  end;

begin
  AttachmentImage.Picture.Graphic := nil;
  BodyStream := nil;
  MessagePropTagArray := nil;
  MessagePropValueArray := nil;
  RTFStreamCompressed := nil;
  RTFStreamUncompressed := nil;


  // We will open "the message"

  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;

    // Allocate Buffer for Message Properties
    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('MAPI Memory Error');
      Exit;
    end;

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

    // Retrieving each propery and assign to label, memo, etc...
    if Assigned(MessagePropValueArray) then
    begin
      if (PSPropValueArray(MessagePropValueArray)[Ord(mcPR_MESSAGE_CLASS)
        ].ulPropTag = PR_MESSAGE_CLASS) and
        Assigned(PSPropValueArray(MessagePropValueArray)[Ord(mcPR_MESSAGE_CLASS)
        ].Value.lpsz) then
        lbMessageClass.Caption := StrPas(PSPropValueArray(MessagePropValueArray)
          [Ord(mcPR_MESSAGE_CLASS)].Value.lpsz)
      else
        lbMessageClass.Caption := 'Not Defined';

      lbMessageClass.Hint := lbMessageClass.Caption;

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

      lbMessageSubject.Hint := lbMessageSubject.Caption;

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

      lbMessageSender.Hint := lbMessageSender.Caption;

      HasAttachments := false;

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

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

      MessageBody.Lines.Clear;

      // first we will check for a property of the PR_BODY type. If there is any, we will show it in ����
      // since the TEXT in the PR_BODY field may be quite large, we will use IStream
      LoadMessageBody;


      // If there is a formatted text, we will show it

      // We will display FORMATED RTF BODY (if exist)
      if FPropExists(MAPIMessage, PR_RTF_COMPRESSED) then
        LoadRTF;

      // Opening  Attachment Table
      if HasAttachments then
        ProcessAttachment;

    end; // if Assigned(MessagePropValueArray) then

    // Mark as read
    hr := MAPIMessage.SetReadFlag(MSGFLAG_READ);
    if Failed(hr) then
    begin
      ShowMessage(GetMAPIError(MAPIMessage, hr));
      Exit;
    end;

  finally
    if Assigned(BodyStream) then
      BodyStream.Free;
    if Assigned(MessagePropTagArray) then
      MAPIFreeBuffer(MessagePropTagArray);
    MessagePropTagArray := nil;
    if Assigned(MessagePropValueArray) then
      MAPIFreeBuffer(MessagePropValueArray);
    MessagePropValueArray := nil;
    RTFStreamCompressed := nil;
    RTFStreamUncompressed := nil;

  end;
end;

procedure TfrmMessage.ProcessAttachment;
var
  AttachmentTable: IMAPITable;
  AttachmentPropTagArray: PSPropTagArray;
  Rows: PSRowSet;
  Attachment: IAttach;
  AttProp: PMessageAttachment;

  Count: ULONG;
  MetafileStream: IStream;
  aPropVal: PSPropValue;
type
  AttachPropEnum = (acPR_ATTACH_RENDERING, acPR_ATTACH_NUM,
    acPR_RENDERING_POSITION, acPR_ATTACH_METHOD, acPR_ATTACH_LONG_FILENAME,
    acPR_ATTACH_FILENAME, acPR_ATTACH_SIZE, acPR_DISPLAY_NAME);

  procedure RenderAttachment;
  var
    StreamBuffer: array [0 .. 4095] of byte;
    iBytesRead, iBytesRead2: int64;
    iCurSeekPos: {$IFDEF DELPHI2015XE8} UINT64 {$ELSE} INT64 {$ENDIF};
    Canvas: TCanvas;
    notUsed: HWnd;
    MetafileHandle: THandle;
    MetaFilePict: TMetaFilePict;
  begin
    if (PSPropValueArray(Rows.aRow[Count].lpProps)[Ord(acPR_RENDERING_POSITION)
      ].ulPropTag = PR_RENDERING_POSITION) and
      (PSPropValueArray(Rows.aRow[Count].lpProps)[Ord(acPR_RENDERING_POSITION)
      ].Value.L <> -1) and (PSPropValueArray(Rows.aRow[Count].lpProps)
      [Ord(acPR_ATTACH_RENDERING)].ulPropTag = PR_ATTACH_RENDERING) and
      (PSPropValueArray(Rows.aRow[Count].lpProps)[Ord(acPR_ATTACH_RENDERING)
      ].Value.bin.cb > 0) then
    begin
      Attachment := nil;
      hr := MAPIMessage.OpenAttach(PSPropValueArray(Rows.aRow[Count].lpProps)
        [Ord(acPR_ATTACH_NUM)].Value.L, @IID_IAttachment, MAPI_BEST_ACCESS or
        MAPI_DEFERRED_ERRORS, Attachment);

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

      MetafileStream := nil;

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

      ZeroMemory(@StreamBuffer, Length(StreamBuffer));

      iBytesRead := 0;

      hr := MetafileStream.Seek(0, STREAM_SEEK_SET, iCurSeekPos);

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

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

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

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

      AttProp.Picture := TMetafile.Create;
      AttProp.Picture.ReleaseHandle;
      AttProp.Picture.Handle := MetafileHandle;

      MetafileStream := nil;
      Attachment := nil;

    end
    else
      AttProp.Picture := nil;
  end;

begin
  AttachmentTable := nil;
  AttachmentPropTagArray := nil;
  Rows := nil;
  Attachment := nil;
  MetafileStream := nil;
  aPropVal := nil;
  try

    hr := MAPIMessage.GetAttachmentTable(0, AttachmentTable);

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

    // Allocate Buffer for Attachments Properties
    hr := SizedSPropTagArray([PR_ATTACH_RENDERING, PR_ATTACH_NUM,
      PR_RENDERING_POSITION, PR_ATTACH_METHOD, PR_ATTACH_LONG_FILENAME,
      PR_ATTACH_FILENAME, PR_ATTACH_SIZE, PR_DISPLAY_NAME],
      AttachmentPropTagArray);

    if Failed(hr) then
    begin
      ShowMessage('MAPI Error when Allocate Buffer for Attachments Properties');
      Exit;
    end;

    lbAttachments.Items.Clear;


    // HrQueryAllRows - Retrieves all rows of a table.

    hr := HrQueryAllRows(AttachmentTable, AttachmentPropTagArray, nil,
      nil, 0, Rows);
    if Failed(hr) then
    begin
      ShowMessage('MAPI Error when HrQueryAllRows');
      Exit;
    end;

    // If Attacment is EMBEDED in BODY (example when you "drag and drop" MS WORD file into message)
    // we will show it icon
    if Assigned(Rows) and (Rows.cRows > 0) then
    begin
      lbMessageAttachments.Caption := IntToStr(Rows.cRows);

      for Count := 0 to Rows.cRows - 1 do
      begin

        New(AttProp);

        RenderAttachment;

        AttProp.ATTACH_NUM := PSPropValueArray(Rows.aRow[Count].lpProps)
          [Ord(acPR_ATTACH_NUM)].Value.L;
        AttProp.ATTACH_METHOD := PSPropValueArray(Rows.aRow[Count].lpProps)
          [Ord(acPR_ATTACH_METHOD)].Value.L;

        if (PSPropValueArray(Rows.aRow[Count].lpProps)[Ord(acPR_ATTACH_FILENAME)
          ].ulPropTag = PR_ATTACH_FILENAME) and
          (PSPropValueArray(Rows.aRow[Count].lpProps)[Ord(acPR_ATTACH_SIZE)
          ].ulPropTag = PR_ATTACH_SIZE) then

        begin

          AttProp.Name := StrPas(PSPropValueArray(Rows.aRow[Count].lpProps)
            [Ord(acPR_ATTACH_FILENAME)].Value.lpsz);

          lbAttachments.Items.AddObject(AttProp.Name + ' -> ' +
            FormatFloat('###' + ThousandSeparator + '###' + ThousandSeparator +
            '##0', ((PSPropValueArray(Rows.aRow[Count].lpProps)
            [Ord(acPR_ATTACH_SIZE)].Value.L) div 1024)) + ' K',
            TObject(AttProp));
        end
        else
        begin
          if (PSPropValueArray(Rows.aRow[Count].lpProps)[Ord(acPR_ATTACH_SIZE)
            ].ulPropTag = PR_ATTACH_SIZE) and
            (PSPropValueArray(Rows.aRow[Count].lpProps)[Ord(acPR_DISPLAY_NAME)
            ].ulPropTag = PR_DISPLAY_NAME) then
          begin
            AttProp.Name := StrPas(PSPropValueArray(Rows.aRow[Count].lpProps)
              [Ord(acPR_DISPLAY_NAME)].Value.lpsz);

            lbAttachments.Items.AddObject(AttProp.Name + ' -> ' +
              FormatFloat('###' + ThousandSeparator + '###' + ThousandSeparator
              + '##0', ((PSPropValueArray(Rows.aRow[Count].lpProps)
              [Ord(acPR_ATTACH_SIZE)].Value.L) div 1024)) + ' K',
              TObject(AttProp));
          end
          else
          begin
            if succeeded(MAPIMessage.OpenAttach(AttProp.ATTACH_NUM, nil, 0,
              Attachment)) then
            begin
              if succeeded(HrGetOneProp(Attachment, PR_ATTACH_FILENAME,
                aPropVal)) then
              begin
                if Assigned(aPropVal) and
                  (aPropVal.ulPropTag = PR_ATTACH_FILENAME) then
                  AttProp.Name := StrPas(aPropVal.Value.lpsz);
                if Assigned(aPropVal) then
                  MAPIFreeBuffer(aPropVal);
                aPropVal := nil;
              end
              else
                AttProp.Name := 'No Name';
              lbAttachments.Items.AddObject(AttProp.Name + ' -> Undefined Size',
                TObject(AttProp));
              if Assigned(aPropVal) then
                MAPIFreeBuffer(aPropVal);
            end;
          end;
        end;
      end;
    end;
  finally
    if Assigned(AttachmentPropTagArray) then
      MAPIFreeBuffer(AttachmentPropTagArray);
    AttachmentPropTagArray := nil;

    if Assigned(Rows) then
      FreePRows(Rows);
    Rows := nil;
    AttachmentTable := nil;
    Attachment := nil;
    MetafileStream := nil;
  end;
end;

procedure TfrmMessage.lbAttachmentsClick(Sender: TObject);
var
  I: integer;

  procedure ShowIcon(Value: string);
  var
    sfi: TSHFileInfo;
  begin
    ZeroMemory(@sfi, sizeof(sfi));
    SHGetFileInfo(PChar(Value), FILE_ATTRIBUTE_NORMAL, sfi, sizeof(sfi),
      SHGFI_USEFILEATTRIBUTES or SHGFI_ICON or SHGFI_SMALLICON);

    Image1.Picture.Icon.Handle := sfi.hIcon;
  end;

begin
  for I := 0 to (lbAttachments.Items.Count - 1) do
    try
      if lbAttachments.Selected[I] then
      begin
        bgSave.Enabled := true;
        if Assigned(PMessageAttachment(lbAttachments.Items.Objects[I]).Picture)
        then
          AttachmentImage.Picture.Graphic :=
            PMessageAttachment(lbAttachments.Items.Objects[I]).Picture
        else
          ShowIcon(PMessageAttachment(lbAttachments.Items.Objects[I]).Name);
        Exit;
      end;

    except
    end;
end;

procedure TfrmMessage.FormClose(Sender: TObject; var Action: TCloseAction);
var
  iCount: integer;
  AttProp: PMessageAttachment;
begin
  if Assigned(MAPIMessage) then
    MAPIMessage := nil;
  for iCount := 0 to (lbAttachments.Items.Count - 1) do
  begin
    AttProp := PMessageAttachment(lbAttachments.Items.Objects[iCount]);
    Dispose(AttProp);
    lbAttachments.Items.Objects[iCount] := nil;
  end;
end;

procedure TfrmMessage.bgSaveClick(Sender: TObject);
var
  iCount: integer;
begin
  for iCount := 0 to (lbAttachments.Items.Count - 1) do
    try
      if lbAttachments.Selected[iCount] then
      begin
        SaveAttachment(PMessageAttachment(lbAttachments.Items.Objects[iCount])
          .ATTACH_NUM, PMessageAttachment(lbAttachments.Items.Objects[iCount])
          .ATTACH_METHOD, PMessageAttachment(lbAttachments.Items.Objects
          [iCount]).Name);
        Exit;
      end;

    except
    end;
end;

function MAPIMessageToStream(const MAPIMessage: IMessage;
  out Stream: TStream): boolean;
var
  FIStream: TStreamAdapter;
  FStorage: IStorage;
  FMalloc: IMalloc;
  FMessage: IMessage;
  FProblem: PSPropProblemArray;
  iCount: integer;
  NewPosition: {$IFDEF DELPHI2015XE8} UINT64 {$ELSE} INT64 {$ENDIF};
  hr: HRESULT;
begin
  Result := false;
  FMalloc := nil;
  FProblem := nil;
  FIStream := nil;

  try
    FIStream := TStreamAdapter.Create(TMemoryStream.Create, soOwned);
    hr := HrIStorageFromStream(IStream(FIStream), @IID_IStream, STGSTRM_CREATE,
      FStorage);
    if Failed(hr) then
      Exit;

    Pointer(FMalloc) := MAPIGetDefaultMalloc;

    if not Assigned(FMalloc) then
      Exit;

    hr := OpenIMsgOnIStg(nil, PAllocateBuffer(@ExtendedMAPI.MAPIAllocateBuffer),
      PAllocateMore(@ExtendedMAPI.MAPIAllocateMore),
      PFreeBuffer(@ExtendedMAPI.MAPIFreeBuffer), FMalloc, nil, FStorage, nil, 0,
      MAPI_UNICODE, FMessage);

    if Failed(hr) or not Assigned(FMessage) then
      Exit;

    hr := WriteClassStg(FStorage, CLSID_MailMessage);
    if Failed(hr) then
      Exit;

    hr := MAPIMessage.CopyTo(0, nil, nil, 0, nil, @IID_IMessage,
      Pointer(FMessage), MAPI_DIALOG, FProblem);

    if Failed(hr) then
      Exit;

    if Assigned(FProblem) then
      for iCount := 0 to FProblem.cProblem - 1 do
      begin
        if FProblem.aProblem[iCount].scode = MAPI_E_COMPUTED then
          continue;
        // MAPI_E_UNEXPECTED for Named
      end;

    hr := FMessage.SaveChanges(Force_Save);
    if Failed(hr) then
      Exit;
    hr := FStorage.Commit(STGC_DEFAULT);
    if Failed(hr) then
      Exit;
    FIStream.Seek(0, 0, NewPosition);
    Result := true;
  finally
    if Result then
    begin
      Stream := TMemoryStream.Create;
      Stream.CopyFrom(FIStream.Stream, FIStream.Stream.Size);
      Stream.Seek(0, 0);
    end
    else
      Stream := nil;
  end;

  if Assigned(FProblem) then
    MAPIFreeBuffer(FProblem);
  FStorage := nil;
  FMessage := nil;
  FMalloc := nil;
  // FreeAndNil(FIStream);
end;

procedure TfrmMessage.SaveAttachment(ATTACH_NUM, ATTACH_METHOD: ULONG;
  AttachName: string);
var
  Stream: IMessage;
  DestMemoryStream: TStream;

  // StreamBuffer: array[0..4095] of byte;
  // iBytesRead:   longint;
  Attachment: IAttach;

begin

  SaveDialog1.FileName := AttachName;
  DestMemoryStream := nil;

  if SaveDialog1.Execute = false then
    Exit;

  (* Open Attachment *)
  try
    hr := MAPIMessage.OpenAttach(ATTACH_NUM, @IID_IAttachment,
      MAPI_BEST_ACCESS or MAPI_DEFERRED_ERRORS, Attachment);

    if Failed(hr) then
    begin
      MessageDlg(GetMAPIError(MAPIMessage, hr), mtError, [mbOK], 0);
      Exit;
    end;

    (* Our object is found as a byte array
      (what else can it be?!?)  in a property named PR_ATTACH_DATA_BIN

      We will load it in OLE Stream, transfer it to a buffer, read this buffer
      from DELPHI Stream, and save the contents of the DELPHI Stream object in
      our file system using the function SaveToFile.
      There may be a cleverer way, but this as the first that came to our mind.
    *)
    hr := Attachment.OpenProperty(PR_ATTACH_DATA_OBJ, @IID_IMessage, 0, 0,
      IUnknown(Stream));

    if Failed(hr) then
    begin
      MessageDlg(GetMAPIError(Attachment, hr), mtError, [mbOK], 0);
      Exit;
    end;

    DestMemoryStream := TMemoryStream.Create;

    MAPIMessageToStream(Stream, DestMemoryStream);

    TMemoryStream(DestMemoryStream).SaveToFile(SaveDialog1.FileName);

    Exit;
    (*
      ZeroMemory( @StreamBuffer, Length(StreamBuffer));

      iBytesRead := 0;
      DestMemoryStream := TMemoryStream.Create;

      hr := Stream.Read( @StreamBuffer, Length(StreamBuffer) - 1, @iBytesRead);
      OleCheck(HR);


      repeat
      DestMemoryStream.WriteBuffer(StreamBuffer, iBytesRead);
      hr := Stream.Read( @StreamBuffer, Length(StreamBuffer) - 1, @iBytesRead);

      until iBytesRead <= 0;

      DestMemoryStream.Position := 0;

      TMemoryStream(DestMemoryStream).SaveToFile(SaveDialog1.FileName);
    *)
  finally
    if Assigned(DestMemoryStream) then
      DestMemoryStream.Free;
    Stream := nil;
  end;
end;

procedure TfrmMessage.btSaveMessageClick(Sender: TObject);
var
  pMalloc: IMalloc;
  szMessageFileName, szPath: array [0 .. MAX_PATH - 1] of Char;
  Subject: PSPropValue;
  pStorage: IStorage;
  pMsgSession: PMSGSESS;
  pIMsg: IMessage;
  excludeTags: PSPropTagArray;
  tempStr: string;
  WideCharStr: WideString;
begin

  ZeroMemory(@szPath, MAX_PATH);

  (* create the file name in the directory where "TMP" is defined
    with subject as the filename and ".msg" extension.

    get temp file directory

  *)
  GetTempPathA(MAX_PATH - 1, @szPath);

  (*
    get subject line of message to copy. This will be used as the
    new file name.

    File name will be constructed from message subject
    We will get message subject using HrGetOneProp function
    The HrGetOneProp function retrieves the value of a single property
    from a property interface, that is, an interface derived from IMAPIProp.


    function HrGetOneProp(
    lpMapiProp:IMAPIPROP;
    ulPropTag:ULONG;
    out lppProp:PSPropValue): HResult;stdcall;

    lpMapiProp
    [in] Pointer to the IMAPIProp interface from which the property value is to be retrieved.
    ulPropTag
    [in] Property tag of the property to be retrieved.
    lppProp
    [out] Pointer to the returned PSPropValue structure defining the retrieved property value.
  *)

  Subject := nil;
  pMalloc := nil;
  pMsgSession := nil;
  pIMsg := nil;
  excludeTags := nil;
  try

    hr := HrGetOneProp(MAPIMessage, PR_SUBJECT, Subject);

    if Failed(hr) then
      if hr <> MAPI_E_NOT_FOUND then
      begin
        MessageDlg(GetMAPIError(MAPIMessage, hr), mtError, [mbOK], 0);
        Exit;
      end;

    // fuse path, subject, and suffix into one string

    ZeroMemory(@szMessageFileName, MAX_PATH);
    if Assigned(Subject) and Assigned(Subject.Value.lpsz) then
      lstrcpy(@szMessageFileName, Subject.Value.lpsz)
    else
      strcopy(@szMessageFileName, 'MAPI_MESSAGE_FROM_DELPHI');
    strcat(@szMessageFileName, '.msg');

    // Free PSPropValue - We no need it more
    if Assigned(Subject) then
    begin
      MAPIFreeBuffer(Subject);
      Subject := nil;
    end;

    SaveDialogMessage.InitialDir := szPath;

    tempStr := szMessageFileName;

    while Pos(':', tempStr) > 0 do
      tempStr[Pos(':', tempStr)] := '_';

    while Pos('\', tempStr) > 0 do
      tempStr[Pos('\', tempStr)] := '_';

    while Pos('/', tempStr) > 0 do
      tempStr[Pos('/', tempStr)] := '_';
    SaveDialogMessage.FileName := tempStr;

    if SaveDialogMessage.Execute = false then
      Exit;

    ZeroMemory(@szMessageFileName, MAX_PATH);
    lstrcpy(@szMessageFileName, PChar(SaveDialogMessage.FileName));

    // Convert new file name to WideString
    WideCharStr := WideString(AnsiString(szMessageFileName));

    // get memory allocation function

    Pointer(pMalloc) := MAPIGetDefaultMalloc;


    // create compound file
    {
      function StgCreateDocfile(pwcsName: POleStr;     //Points to path of compound file
      // to create
      grfMode: Longint;      //Specifies the access mode for opening the
      // storage object
      reserved: Longint;     //Reserved; must be zero
      out stgOpen: IStorage  //Points to location for returning the new
      // storage object
      ): HResult; stdcall;

      function StgCreateDocfile creates a new compound file storage object
      using the COM-provided compound file implementation for the IStorage interface.
    }

    OleCheck(StgCreateDocfile(PWideChar(WideCharStr), STGM_READWRITE or
      STGM_TRANSACTED or STGM_CREATE, 0, pStorage));

    // Open an IMessage session
    {
      The OpenIMsgSession function creates and opens a message session
      that groups the messages created within it.

      function OpenIMsgSession (lpMalloc : IMalloc;  //Input parameter pointing to a standard OLE memory allocator.
      ulFlags : ULONG;      //Reserved; must be zero.
      out lppMsgSess : PMSGSESS //Output parameter pointing to a variable where the returned message-session object is stored.
      ) : SCODE; stdcall;

      A message session is used by client applications and service providers
      that want to deal with several related MAPI IMessage objects
      built on top of underlying OLE IStorage objects.
    }

    OleCheck(OpenIMsgSession(pMalloc, 0, pMsgSession));

    {
      The OpenIMsgOnIStg function builds a new IMessage object
      on top of an existing OLE IStorage object,
      to be used within a message session.

      function OpenIMsgOnIStg (
      lpMsgSess : PMSGSESS;               // [in] Pointer to a message session object
      // within which the new IMessage-on-IStorage object
      // is to be created.

      lpAllocateBuffer : PALLOCATEBUFFER; //[in] Pointer to the MAPIAllocateBuffer function,
      // to be used where required by MAPI to allocate memory.

      lpAllocateMore : PALLOCATEMORE;     //[in] Pointer to the MAPIAllocateMore function,
      // to be used where required by MAPI to allocate additional memory.

      lpFreeBuffer : PFREEBUFFER;         //[in] Pointer to the MAPIFreeBuffer function,
      //to be used where required by MAPI to free memory.

      lpMalloc : IMalloc;                 //[in] Pointer to a memory allocator object exposing the OLE IMalloc interface.
      // The IMessage interface needs to use this allocation method when working with
      // interfaces such as IStorage and IStream.

      lpMapiSup : Pointer;                //[in] Optional pointer to a MAPI support object that a service provider
      can use to call the methods of the IMAPISupport : IUnknown interface.

      lpStg : IStorage;                   // Pointer to an OLE IStorage object that is open and has read-only or read/write access.
      // Because IMessage does not support write-only access, OpenIMsgOnIStg
      // does not accept a storage object opened in write-only mode.

      var lpfMsgCallRelease : TMSGCALLRELEASE;  // Optional pointer to a callback function
      // based on the TMSGCALLRELEASE prototype that MAPI
      // is to call following the last release
      // on the IMessage-on-IStorage object.

      ulCallerData : ULONG;          // [in] 32-bit caller data saved by MAPI with the IMessage-on-IStorage object
      // and passed to the TMSGCALLRELEASE based callback function.
      // The data provides context about the IMessage object being released
      // and the IStorage object it was built on top of.

      ulFlags : ULONG;               //[in] Bitmask of flags used to control whether the OLE IStorage.Commit method
      // is called when the client application or service provider calls the IMessage.SaveChanges method.
      // The following flag can be set:
      //   IMSG_NO_ISTG_COMMIT -  The OLE method IStorage.Commit
      //                          is not to be called when the client
      //                          or provider calls SaveChanges.

      out lppMsg : IMessage          //[out] Pointer to the opened IMessage object.
      ) : SCODE; stdcall;
    }

    OleCheck(OpenIMsgOnIStg(pMsgSession,
      PAllocateBuffer(@ExtendedMAPI.MAPIAllocateBuffer),
      PAllocateMore(@ExtendedMAPI.MAPIAllocateMore),
      PFreeBuffer(@ExtendedMAPI.MAPIFreeBuffer), pMalloc, nil, pStorage, nil, 0,
      0, pIMsg));

    // write the CLSID to the IStorage instance - pStorage. This will
    // only work with clients that support this compound document type
    // as the storage medium. If the client does not support
    // CLSID_MailMessage as the compound document, you will have to use
    // the CLSID that it does support.

    OleCheck(WriteClassStg(pStorage, CLSID_MailMessage));

    // Specify properties to exclude in the copy operation. These are
    // the properties that Exchange excludes to save bits and time.
    // Should not be necessary to exclude these, but speeds the process
    // when a lot of messages are being copied.

    OleCheck(SizedSPropTagArray([PR_ACCESS, PR_BODY, PR_RTF_SYNC_BODY_COUNT,
      PR_RTF_SYNC_BODY_CRC, PR_RTF_SYNC_BODY_TAG, PR_RTF_SYNC_PREFIX_COUNT,
      PR_RTF_SYNC_TRAILING_COUNT], excludeTags));

    // copy message properties to IMessage object opened on top of
    // IStorage.
    hr := MAPIMessage.CopyTo(0, nil, excludeTags, 0, nil, @IID_IMessage,
      Pointer(pIMsg), 0, PSPropProblemArray(nil^));

    if Failed(hr) then
    begin
      MessageDlg(GetMAPIError(MAPIMessage, hr), mtError, [mbOK], 0);
      Exit;
    end;

    // save changes to IMessage object.
    OleCheck(pIMsg.SaveChanges(KEEP_OPEN_READWRITE));

    // save changes in storage of new doc file
    OleCheck(pStorage.Commit(STGC_DEFAULT));

    // free objects and clean up memory
    if Assigned(excludeTags) then
      OleCheck(MAPIFreeBuffer(excludeTags));
    excludeTags := nil;
    pStorage := nil;
    Pointer(pIMsg) := nil;
    // The CloseIMsgSession function closes a message session
    // and all the messages created within that session.
    CloseIMsgSession(pMsgSession);
    pMsgSession := nil;
  finally
    if Assigned(Subject) then
      MAPIFreeBuffer(Subject);
    Subject := nil;
    pMalloc := nil;
    pIMsg := nil;
    if Assigned(excludeTags) then
      MAPIFreeBuffer(excludeTags);
    excludeTags := nil;
    if Assigned(pMsgSession) then
      CloseIMsgSession(pMsgSession);
    pMsgSession := nil;

  end;
end;

end.