Development

unit unNewMess;

interface

{$I IMI.INC}

uses
  Classes, Controls, Dialogs, Forms, Buttons, ExtCtrls, ExtendedMAPI, StdCtrls;

type
  TfrmNewMess = class(TForm)
    Panel1: TPanel;
    sbSend: TSpeedButton;
    sbSave: TSpeedButton;
    Panel2: TPanel;
    sbTo: TSpeedButton;
    sbCc: TSpeedButton;
    scBcc: TSpeedButton;
    ebTo: TEdit;
    ebCc: TEdit;
    ebBcc: TEdit;
    MessageBody: TMemo;
    Label1: TLabel;
    ebSuubject: TEdit;
    sbAttach: TSpeedButton;
    Label2: TLabel;
    ebAttach: TEdit;
    OpenDialog: TOpenDialog;
    SpeedButton1: TSpeedButton;
    OpenDialog2: TOpenDialog;
    procedure FormClose(Sender: TObject; var Action: TCloseAction);
    procedure sbToClick(Sender: TObject);
    procedure sbCcClick(Sender: TObject);
    procedure scBccClick(Sender: TObject);
    procedure sbSendClick(Sender: TObject);
    procedure sbSaveClick(Sender: TObject);
    procedure ebSuubjectChange(Sender: TObject);
    procedure sbAttachClick(Sender: TObject);
    procedure SpeedButton1Click(Sender: TObject);
  private
    { Private declarations }
    hr: HRESULT;
    Folder: IMAPIFolder;
    MAPIMessage: IMessage;
    SentMailEID: PSPropValue;
    AddressListRecipients: PADRLIST;
    procedure ShowAddressBook(Value: integer);
    function SaveMessage: HRESULT;
    procedure AddAttachment;
    procedure Resolve;
  public
    { Public declarations }
    procedure CreateMessage(MsgStore: ImsgStore);
  end;

var
  frmNewMess: TfrmNewMess;

implementation

uses
{$IFDEF DELPHI2011XE2} UITypes, {$ENDIF} SysUtils, Windows, ActiveX, Comobj, EDK, MainUnit, MAPIMacros, MAPIUtils;

{$R *.DFM}

function HrMAPIGetPropString(const Obj: IMAPIProp;
  // pointer to object
  PropTag: ULONG; // property tag
  out RetPropTag: ULONG; // property tag
  out cbProp: ULONG; // count of bytes in property
  out Prop: Pointer) // pointer to property address variable
  : HRESULT;
var
  hr: HRESULT;
  hrT: HRESULT;
  cValues: ULONG;
  PropValue: PSPropValue;
  xcbProp: ULONG;
  rgPropTag: TSPropTagArray;
begin
  hr := NOERROR;

  cValues := 0;
  PropValue := nil;
  xcbProp := 0;

  cbProp := 0;
  Prop := nil;

  ZeroMemory(@rgPropTag, SizeOf(TSPropTagArray));
  rgPropTag.cValues := 1;
  rgPropTag.aulPropTag[0] := CHANGE_PROP_TYPE(PropTag, PT_UNSPECIFIED);
  Result := hr;
  try
    hrT := Obj.GetProps(PSPropTagArray(@rgPropTag), fMapiUnicode, cValues, PropValue);
    if (hrT = MAPI_E_BAD_CHARWIDTH) then
      hrT := Obj.GetProps(PSPropTagArray(@rgPropTag), 0, cValues, PropValue);

    if (hrT = MAPI_W_ERRORS_RETURNED) then
    begin
      if ((PropValue <> nil) and (PropValue.Value.ul = ULONG(MAPI_E_NOT_FOUND)))
      then
        hr := (MAPI_E_NOT_FOUND)
      else
        hr := (E_FAIL);

      Exit;
    end;

    if failed(hrT) then
    begin
      PropValue := nil;

      hr := (E_FAIL);
      Exit;
    end;

    ASSERT(cValues <> 0, 'ZERO cValues variable');

    ASSERT(PropValue <> nil, 'Nil lpPropValue variable');

    if (PROP_TYPE(PropValue.ulPropTag) = PT_STRING8) then
    begin
      if (PropValue.Value.lpszA <> nil) then
        xcbProp := cbStrLen(PropValue.Value.lpszA);
    end
    else if (PropValue.Value.lpszW <> nil) then
      xcbProp := cbStrLen(PropValue.Value.lpszW);

    hr := MAPIAllocateBuffer(xcbProp, Prop);

    if failed(hr) then
    begin
      hr := (E_OUTOFMEMORY);
      Exit;
    end;

    ASSERT(Prop <> nil, 'Nil lppvProp pointer');

    if (PROP_TYPE(PropValue.ulPropTag) = PT_STRING8) then
      CopyMemory(Prop, PropValue.Value.lpszA, xcbProp)
    else
      CopyMemory(Prop, PropValue.Value.lpszW, xcbProp);

    cbProp := xcbProp;
    RetPropTag := PropValue.ulPropTag;
  finally

    if Assigned(PropValue) then
      MAPIFreeBuffer(PropValue);
    Result := hr;
  end;
end;

Function GetPropString(Const MAPIObject: IMAPIProp; Const PropTag: ULONG): String;
Var
  cbProp: ULONG; // count of bytes in property
  RetPropTag: ULONG;
  Prop: Pointer;
  hr: HRESULT;
Begin
  Prop := nil;
  Result := '';

  if ((PROP_TYPE(PropTag) <> PT_STRING8) and (PROP_TYPE(PropTag) <> PT_UNICODE))
    or not Assigned(MAPIObject) then
    raise Exception.Create(GetMApiError(nil, MAPI_E_INVALID_PARAMETER));

  Try

    hr := HrMAPIGetPropString(MAPIObject, PropTag, RetPropTag, cbProp, Prop);
    If failed(hr) Then
    begin
      if hr = MAPI_E_NOT_FOUND then
        Exit;
      Raise Exception.Create(GetMApiError(MAPIObject, hr));

    end;
{$IFDEF UNICODE}
    if PROP_TYPE(RetPropTag) = PT_STRING8 then
      Result := PAnsiCharToUnicode(PAnsiChar(Prop))
    else
      Result := PWideChar(Prop);
{$ELSE}
    if PROP_TYPE(RetPropTag) = PT_STRING8 then
      Result := PAnsiChar(Prop)
    else
      Result := PWideCharToAnsiString(PWideChar(Prop));
{$ENDIF}
  Finally
    If Assigned(Prop) Then
      ExtendedMAPI.MAPIFreeBuffer(Prop);
  End;
End;

procedure TfrmNewMess.CreateMessage(MsgStore: ImsgStore);
var
  ObjType: ULONG;
  OutboxEntryID: TSBinary;
begin
  OutboxEntryID.cb := 0;
  OutboxEntryID.lpb := nil;

  Folder := nil;
  MAPIMessage := nil;
  SentMailEID := nil;

  try
    hr := HrMAPIFindOutbox(MsgStore, OutboxEntryID.cb,
      PEntryID(OutboxEntryID.lpb));
    if failed(hr) then
    begin
      MessageDlg(GetMApiError(MsgStore, hr), mtError, [mbOK], 0);
      Exit;
    end;

    hr := HrGetOneProp(MsgStore, PR_IPM_SENTMAIL_ENTRYID, SentMailEID);
    if failed(hr) then
    begin
      MessageDlg(GetMApiError(MsgStore, hr), mtError, [mbOK], 0);
      Exit;
    end;

    SentMailEID.ulPropTag := PR_SENTMAIL_ENTRYID;

    hr := MsgStore.OpenEntry(OutboxEntryID.cb, PEntryID(OutboxEntryID.lpb),
      @IID_IMAPIFolder, MAPI_DEFERRED_ERRORS or MAPI_MODIFY, ObjType,
      IUnknown(Folder));

    if failed(hr) then
    begin
      MessageDlg(GetMApiError(MsgStore, hr), mtError, [mbOK], 0);
      Exit;
    end;

    hr := Folder.CreateMessage(nil, MAPI_DEFERRED_ERRORS, MAPIMessage);
    if failed(hr) then
    begin
      MessageDlg(GetMApiError(Folder, hr), mtError, [mbOK], 0);
      Exit;
    end;

    hr := HrSetOneProp(MAPIMessage, SentMailEID);
    if failed(hr) then
    begin
      MessageDlg(GetMApiError(nil, hr), mtError, [mbOK], 0);
      Exit;
    end;

  finally
    if Assigned(OutboxEntryID.lpb) then
      MAPIFreeBuffer(OutboxEntryID.lpb);

    if failed(hr) then
    begin
      if Assigned(MAPIMessage) then
        MAPIMessage := nil;
      if Assigned(Folder) then
        Folder := nil;
    end;

  end;
end;

procedure TfrmNewMess.FormClose(Sender: TObject; var Action: TCloseAction);
begin
  if Assigned(AddressListRecipients) then
    FreePadrlist(AddressListRecipients);
  if Assigned(SentMailEID) then
    MAPIFreeBuffer(SentMailEID);
  if Assigned(MAPIMessage) then
    MAPIMessage := nil;
  if Assigned(Folder) then
    Folder := nil;
end;

procedure TfrmNewMess.ShowAddressBook(Value: integer);
type
  DestTitles = array [0 .. 2] of PChar;
  DestComps = array [0 .. 2] of ULONG;

type
  LTSPropTagArray = record
    cValues: ULONG;
    aulPropTag: array [0 .. 1] of ULONG;
  end;
const
  RecipientTablePropTagArray: LTSPropTagArray = (cValues: 2;
    aulPropTag: (PR_DISPLAY_NAME, PR_RECIPIENT_TYPE));
  prPR_DISPLAY_NAME = 0;
  prPR_RECIPIENT_TYPE = 1;

var
  AddressBook: IAddrBook;
  AddressBookParameters: TADRPARM;
  UIParam: ULONG_PTR;
  AddressBookDestTitles: DestTitles;
  AddressBookDestComps: DestComps;
  TempString: string;
  iCount: integer;
  RecipientTable: IMAPITable;
  RowCount, ActionFlag: ULONG;
  Rows: PSRowSet;
begin

  Resolve;

  AddressBook := nil;
  Rows := nil;
  RecipientTable := nil;

  try
    hr := FMapiSession.OpenAddressBook(Self.Handle, nil, 0, AddressBook);
    if failed(hr) then
    begin
      MessageDlg(GetMApiError(FMapiSession, hr), mtError, [mbOK], 0);
      Exit;
    end;

    ZeroMemory(@AddressBookParameters, SizeOf(AddressBookParameters));

    AddressBookParameters.lpszCaption := 'MAPI tests Address from DELPHI';
    AddressBookParameters.lpszNewEntryTitle := 'For this test only';
    AddressBookParameters.nDestFieldFocus := Value;

    AddressBookDestTitles[0] := 'To';
    AddressBookDestTitles[1] := 'Cc';
    AddressBookDestTitles[2] := 'Bcc';
    AddressBookDestComps[0] := ULONG(MAPI_TO);
    AddressBookDestComps[1] := ULONG(MAPI_CC);
    AddressBookDestComps[2] := ULONG(MAPI_BCC);

    AddressBookParameters.ulFlags := DIALOG_MODAL or fMapiUnicode or
      AB_UNICODEUI;
    AddressBookParameters.lpszDestWellsTitle := 'Message Recipients';
    AddressBookParameters.cDestFields := 3;
    AddressBookParameters.lppszDestTitles := @AddressBookDestTitles;
    AddressBookParameters.lpulDestComps := @AddressBookDestComps;

    UIParam := Self.Handle;

    hr := AddressBook.Address(UIParam, @AddressBookParameters, AddressListRecipients);
    if failed(hr) then
    begin
      MessageDlg(GetMApiError(AddressBook, hr), mtError, [mbOK], 0);
      Exit;
    end;

    ebTo.Text := '';
    ebCc.Text := '';
    ebBcc.Text := '';

    ActionFlag := 0; // The entire recipient table is replaced

    if Assigned(AddressListRecipients) then
      hr := MAPIMessage.ModifyRecipients(ActionFlag, AddressListRecipients);

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

    hr := MAPIMessage.GetRecipientTable(0, RecipientTable);
    if failed(hr) then
    begin
      MessageDlg(GetMApiError(MAPIMessage, hr), mtError, [mbOK], 0);
      Exit;
    end;

    hr := RecipientTable.SetColumns(@RecipientTablePropTagArray, TBL_BATCH);
    if failed(hr) then
    begin
      MessageDlg(GetMApiError(RecipientTable, hr), mtError, [mbOK], 0);
      Exit;
    end;

    hr := RecipientTable.GetRowCount(0, RowCount);
    if failed(hr) then
    begin
      MessageDlg(GetMApiError(RecipientTable, hr), mtError, [mbOK], 0);
      Exit;
    end;

    if RowCount > 0 then
    begin
      hr := RecipientTable.QueryRows(RowCount, TBL_NOADVANCE, Rows);
      if failed(hr) then
      begin
        MessageDlg(GetMApiError(RecipientTable, hr), mtError, [mbOK], 0);
        Exit;
      end;

      for iCount := 0 to RowCount - 1 do
        case PSPropValueArray(Rows.aRow[iCount].lpProps)[prPR_RECIPIENT_TYPE]
          .Value.l of
          MAPI_TO:
            ebTo.Text := ebTo.Text + ' ' + PSPropValueArray(Rows.aRow[iCount].lpProps)[prPR_DISPLAY_NAME].Value.lpsz + ';';
          MAPI_CC:
            ebCc.Text := ebCc.Text + ' ' + PSPropValueArray(Rows.aRow[iCount].lpProps)[prPR_DISPLAY_NAME].Value.lpsz + ';';
          MAPI_BCC:
            ebBcc.Text := ebBcc.Text + ' ' + PSPropValueArray(Rows.aRow[iCount].lpProps)[prPR_DISPLAY_NAME].Value.lpsz + ';';
        end;
    end;

    TempString := ebTo.Text;

    if LastDelimiter(';', TempString) = Length(TempString) then
      Delete(TempString, Length(TempString), 1);
    ebTo.Text := Trim(TempString);

    TempString := ebCc.Text;
    if LastDelimiter(';', TempString) = Length(TempString) then
      Delete(TempString, Length(TempString), 1);
    ebCc.Text := Trim(TempString);

    TempString := ebBcc.Text;
    if LastDelimiter(';', TempString) = Length(TempString) then
      Delete(TempString, Length(TempString), 1);
    ebBcc.Text := Trim(TempString);

  finally
    if Assigned(AddressBook) then
      AddressBook := nil;
    if Assigned(Rows) then
      FreePRows(Rows);
    if Assigned(RecipientTable) then
      RecipientTable := nil;

  end;
end;

procedure TfrmNewMess.sbToClick(Sender: TObject);
begin
  ShowAddressBook(0);
end;

procedure TfrmNewMess.sbCcClick(Sender: TObject);
begin
  ShowAddressBook(1);
end;

procedure TfrmNewMess.scBccClick(Sender: TObject);
begin
  ShowAddressBook(2);
end;

function TfrmNewMess.SaveMessage: HRESULT;
var
  CountWritten: ULONG;
  MessageBodyStream: IStream;
  Stream: TStream;
  PropArray: TSPropValue;
begin
  Result := S_FALSE;
  Stream := nil;
  MessageBodyStream := nil;
  ebSuubject.Text := Trim(ebSuubject.Text);
  if ebSuubject.Text = '' then
  begin
    ShowMessage('Subject is missing!');
    Exit;
  end;

  if (Trim(ebTo.Text) = '') then
  begin
    ShowMessage('Recipient To is missing!');
    Exit;
  end;

  try

    hr := MAPIMessage.OpenProperty(PR_BODY_A, @IID_IStream, 0, MAPI_CREATE or MAPI_DEFERRED_ERRORS or MAPI_MODIFY,
      IUnknown(MessageBodyStream));

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

    Stream := TMemoryStream.Create;
    MessageBody.Lines.SaveToStream(Stream);
    Stream.Seek(soFromBeginning, 0);

    OleCheck(MessageBodyStream.Write(TMemoryStream(Stream).Memory, Stream.Size,
      @CountWritten));

    OleCheck(MessageBodyStream.Commit(STGC_DEFAULT));

    PropArray.ulPropTag := PR_SUBJECT;
    MAPIAllocateBuffer(Length(ebSuubject.Text) * SizeOf(Char) + SizeOf(Char), Pointer(PropArray.Value.lpsz));

    StrPCopy(PropArray.Value.lpsz, ebSuubject.Text);

    hr := MAPIMessage.SetProps(1, @PropArray, PSPropProblemArray(nil^));
    if failed(hr) then
    begin
      MessageDlg(GetMApiError(MAPIMessage, hr), mtError, [mbOK], 0);
      Exit;
    end;

    MAPIFreeBuffer(PropArray.Value.lpsz);
    PropArray.Value.lpsz := nil;

    PropArray.ulPropTag := PR_CONVERSATION_TOPIC;
    MAPIAllocateBuffer(Length(ebSuubject.Text) * SizeOf(Char) + SizeOf(Char),
      Pointer(PropArray.Value.lpsz));
    StrPCopy(PropArray.Value.lpsz, ebSuubject.Text);

    hr := MAPIMessage.SetProps(1, @PropArray, PSPropProblemArray(nil^));
    if failed(hr) then
    begin
      MessageDlg(GetMApiError(MAPIMessage, hr), mtError, [mbOK], 0);
      Exit;
    end;

    MAPIFreeBuffer(PropArray.Value.lpsz);
    PropArray.Value.lpsz := nil;

    hr := MAPIMessage.SetProps(1, SentMailEID, PSPropProblemArray(nil^));
    if failed(hr) then
    begin
      MessageDlg(GetMApiError(MAPIMessage, hr), mtError, [mbOK], 0);
      Exit;
    end;

    PropArray.ulPropTag := PR_MESSAGE_CLASS;
    MAPIAllocateBuffer(Length('IPM.Note') * SizeOf(Char) + SizeOf(Char), Pointer(PropArray.Value.lpsz));
    StrPCopy(PropArray.Value.lpsz, 'IPM.Note');

    hr := MAPIMessage.SetProps(1, @PropArray, PSPropProblemArray(nil^));
    if failed(hr) then
    begin
      MessageDlg(GetMApiError(MAPIMessage, hr), mtError, [mbOK], 0);
      Exit;
    end;
    MAPIFreeBuffer(PropArray.Value.lpsz);
    PropArray.Value.lpsz := nil;

    Resolve;

    hr := MAPIMessage.SaveChanges(KEEP_OPEN_READWRITE); // FORCE_SAVE
    if failed(hr) then
    begin
      MessageDlg(GetMApiError(MAPIMessage, hr), mtError, [mbOK], 0);
      Exit;
    end;
  finally

    if Assigned(PropArray.Value.lpsz) then
      MAPIFreeBuffer(PropArray.Value.lpsz);
    if Assigned(Stream) then
      FreeAndNil(Stream);
    if Assigned(MessageBodyStream) then
      MessageBodyStream := nil;
    Result := hr;
  end;
end;

procedure TfrmNewMess.sbSendClick(Sender: TObject);
begin
  if SaveMessage = S_OK then
  begin
    hr := MAPIMessage.SubmitMessage(FORCE_SUBMIT);
    if failed(hr) then
    begin
      MessageDlg(GetMApiError(MAPIMessage, hr), mtError, [mbOK], 0);
      Exit;
    end;
    ModalResult := mrOk;
  end;

end;

procedure TfrmNewMess.sbSaveClick(Sender: TObject);
begin
  SaveMessage;
end;

procedure TfrmNewMess.ebSuubjectChange(Sender: TObject);
begin
  Self.Caption := Trim(ebSuubject.Text) + ' (Plain Text)';
end;

procedure TfrmNewMess.sbAttachClick(Sender: TObject);
begin
  if OpenDialog.Execute then
    AddAttachment;
end;

procedure TfrmNewMess.AddAttachment;
var
  AttachmentNumber: ULONG;
  Attachment: IAttach;
  PropArray: array [0 .. 3] of TSPropValue;
  FileName: string;
  FileAttachmentStream: IStream;
  FileStream, MemoryStream: TStream;
  CountWritten: ULONG;
begin

  if FileExists(OpenDialog.FileName) = False then
    Exit;

  FileName := ExtractFileName(OpenDialog.FileName);

  Attachment := nil;
  FileAttachmentStream := nil;
  FileStream := nil;
  MemoryStream := nil;

  try
    hr := MAPIMessage.CreateAttach(nil, MAPI_DEFERRED_ERRORS, AttachmentNumber,
      Attachment);
    if failed(hr) then
    begin
      MessageDlg(GetMApiError(MAPIMessage, hr), mtError, [mbOK], 0);
      Exit;
    end;

    PropArray[0].ulPropTag := PR_ATTACH_METHOD;
    PropArray[0].Value.ul := ATTACH_BY_VALUE;

    PropArray[1].ulPropTag := PR_ATTACH_LONG_FILENAME;
    GetMem(PropArray[1].Value.lpsz, Length(FileName) * SizeOf(Char) + 1);
    StrPCopy(PropArray[1].Value.lpsz, FileName);

    PropArray[2].ulPropTag := PR_ATTACH_FILENAME;
    GetMem(PropArray[2].Value.lpsz, Length(FileName) * SizeOf(Char) + 1);
    StrPCopy(PropArray[2].Value.lpsz, FileName);

    PropArray[3].ulPropTag := PR_DISPLAY_NAME;
    GetMem(PropArray[3].Value.lpsz, Length(FileName) * SizeOf(Char) + 1);
    StrPCopy(PropArray[3].Value.lpsz, FileName);

    hr := Attachment.SetProps(4, @PropArray, PSPropProblemArray(nil^));
    if failed(hr) then
    begin
      MessageDlg(GetMApiError(Attachment, hr), mtError, [mbOK], 0);
      Exit;
    end;

    hr := Attachment.OpenProperty(PR_ATTACH_DATA_BIN, @IID_IStream, 0,
      MAPI_CREATE or MAPI_DEFERRED_ERRORS or MAPI_MODIFY,
      IUnknown(FileAttachmentStream));
    if failed(hr) then
    begin
      MessageDlg(GetMApiError(Attachment, hr), mtError, [mbOK], 0);
      Exit;
    end;

    FileStream := TFileStream.Create(OpenDialog.FileName,
      fmOpenRead or fmShareDenyWrite);
    FileStream.Seek(soFromBeginning, 0);

    MemoryStream := TMemoryStream.Create;
    MemoryStream.CopyFrom(FileStream, FileStream.Size);
    FreeAndNil(FileStream);
    MemoryStream.Seek(soFromBeginning, 0);

    OleCheck(FileAttachmentStream.Write(TMemoryStream(MemoryStream).Memory,
      MemoryStream.Size, @CountWritten));

    OleCheck(FileAttachmentStream.Commit(STGC_DEFAULT));
    FreeAndNil(MemoryStream);
    hr := Attachment.SaveChanges(KEEP_OPEN_READWRITE);
    if failed(hr) then
    begin
      MessageDlg(GetMApiError(Attachment, hr), mtError, [mbOK], 0);
      Exit;
    end;

    if CountWritten < 1024 then
      FileName := FileName + ' (' + IntToStr(CountWritten) + ' bytes)'
    else
      FileName := FileName + ' (' + IntToStr(CountWritten div 1024) + ' KB)';

    ebAttach.Text := ebAttach.Text + FileName + ';';

  finally
    if Assigned(PropArray[3].Value.lpsz) then
      FreeMem(PropArray[3].Value.lpsz);
    if Assigned(PropArray[2].Value.lpsz) then
      FreeMem(PropArray[2].Value.lpsz);
    if Assigned(PropArray[1].Value.lpsz) then
      FreeMem(PropArray[1].Value.lpsz);

    if Assigned(FileStream) then
      FreeAndNil(FileStream);
    if Assigned(MemoryStream) then
      FreeAndNil(MemoryStream);
    FileAttachmentStream := nil;
    Attachment := nil;
  end;
end;

procedure TfrmNewMess.Resolve;
type
  LTSPropTagArray = record
    cValues: ULONG;
    aulPropTag: array [0 .. 1] of ULONG;
  end;
const
  FPropTagArray: LTSPropTagArray = (cValues: 2; aulPropTag: (PR_DISPLAY_NAME, PR_RECIPIENT_TYPE));

var
  TempAddressList: PADRLIST;
  AddressBook: IAddrBook;
  RecipientsTo, RecipientsCC, RecipientsBCC: TStringList;

  Entries, Counter, iCount: integer;

  procedure SplitRecipients(var RecipientList: TStringList;
    RecipientsString: string);
  var
    Recipients: string;
  begin
    Recipients := Trim(RecipientsString);

    if LastDelimiter(';', Recipients) = Length(Recipients) then
      Delete(Recipients, Length(Recipients), 1);

    if POS(';', Recipients) > 0 then
      while POS(';', Recipients) > 0 do
      begin
        RecipientList.Add(Trim(Copy(Recipients, 1, POS(';', Recipients) - 1)));
        Delete(Recipients, 1, POS(';', Recipients));
      end
    else
    begin
      if Trim(Recipients) <> EmptyStr then
        RecipientList.Add(Trim(Recipients));
      Recipients := EmptyStr;
    end;

    if Length(Recipients) > 0 then
      RecipientList.Add(Trim(Recipients));
  end;

begin

  AddressBook := nil;
  RecipientsTo := nil;
  RecipientsCC := nil;
  RecipientsBCC := nil;
  TempAddressList := nil;

  try

    hr := FMapiSession.OpenAddressBook(Self.Handle, nil, 0, AddressBook);
    if failed(hr) then
    begin
      MessageDlg(GetMApiError(FMapiSession, hr), mtError, [mbOK], 0);
      Exit;
    end;

    RecipientsTo := TStringList.Create;
    RecipientsTo.Sorted := True;
    RecipientsTo.Duplicates := dupIgnore;
    SplitRecipients(RecipientsTo, ebTo.Text);

    RecipientsCC := TStringList.Create;
    RecipientsCC.Sorted := True;
    RecipientsCC.Duplicates := dupIgnore;
    SplitRecipients(RecipientsCC, ebCc.Text);

    RecipientsBCC := TStringList.Create;
    RecipientsBCC.Sorted := True;
    RecipientsBCC.Duplicates := dupIgnore;
    SplitRecipients(RecipientsBCC, ebBcc.Text);

    Entries := RecipientsTo.Count + RecipientsCC.Count + RecipientsBCC.Count;

    if Entries > 0 then
    begin
      MAPIAllocateBuffer(CbNewADRLIST(Entries), Pointer(TempAddressList));

      ZeroMemory(TempAddressList, CbNewADRLIST(Entries));
      TempAddressList.cEntries := Entries;

      for iCount := 0 to RecipientsTo.Count - 1 do
      begin
        SizedPropValueArray(4, TempAddressList.aEntries[iCount].rgPropVals);

        TempAddressList.aEntries[iCount].cValues := 4;

        PSPropValueArray(TempAddressList.aEntries[iCount].rgPropVals)[0].ulPropTag := PR_EMAIL_ADDRESS;
        PSPropValueArray(TempAddressList.aEntries[iCount].rgPropVals)[0].Value.lpsz := PChar(RecipientsTo[iCount]);
        PSPropValueArray(TempAddressList.aEntries[iCount].rgPropVals)[1].ulPropTag := PR_ADDRTYPE;
        PSPropValueArray(TempAddressList.aEntries[iCount].rgPropVals)[1].Value.lpsz := 'SMTP';
        PSPropValueArray(TempAddressList.aEntries[iCount].rgPropVals)[2].ulPropTag := PR_DISPLAY_NAME;
        PSPropValueArray(TempAddressList.aEntries[iCount].rgPropVals)[2].Value.lpsz := PChar(RecipientsTo[iCount]);
        PSPropValueArray(TempAddressList.aEntries[iCount].rgPropVals)[3].ulPropTag := PR_RECIPIENT_TYPE;
        PSPropValueArray(TempAddressList.aEntries[iCount].rgPropVals)[3].Value.l := MAPI_TO;
      end;

      Entries := RecipientsTo.Count;

      for iCount := 0 to RecipientsCC.Count - 1 do
      begin
        SizedPropValueArray(4, TempAddressList.aEntries[Entries + iCount].rgPropVals);

        TempAddressList.aEntries[Entries + iCount].cValues := 4;

        PSPropValueArray(TempAddressList.aEntries[Entries + iCount].rgPropVals)[0].ulPropTag := PR_EMAIL_ADDRESS;
        PSPropValueArray(TempAddressList.aEntries[Entries + iCount].rgPropVals)[0].Value.lpsz := PChar(RecipientsCC[iCount]);
        PSPropValueArray(TempAddressList.aEntries[Entries + iCount].rgPropVals)[1].ulPropTag := PR_ADDRTYPE;
        PSPropValueArray(TempAddressList.aEntries[Entries + iCount].rgPropVals)[1].Value.lpsz := 'SMTP';
        PSPropValueArray(TempAddressList.aEntries[Entries + iCount].rgPropVals)[2].ulPropTag := PR_DISPLAY_NAME;
        PSPropValueArray(TempAddressList.aEntries[Entries + iCount].rgPropVals)[2].Value.lpsz := PChar(RecipientsCC[iCount]);
        PSPropValueArray(TempAddressList.aEntries[Entries + iCount].rgPropVals)[3].ulPropTag := PR_RECIPIENT_TYPE;
        PSPropValueArray(TempAddressList.aEntries[Entries + iCount].rgPropVals)[3].Value.l := MAPI_CC;
      end;

      Entries := Entries + RecipientsCC.Count;

      for iCount := 0 to RecipientsBCC.Count - 1 do
      begin
        SizedPropValueArray(4, TempAddressList.aEntries[Entries + iCount]
          .rgPropVals);

        TempAddressList.aEntries[Entries + iCount].cValues := 4;
        PSPropValueArray(TempAddressList.aEntries[Entries + iCount].rgPropVals)[0].ulPropTag := PR_EMAIL_ADDRESS;
        PSPropValueArray(TempAddressList.aEntries[Entries + iCount].rgPropVals)[0].Value.lpsz := PChar(RecipientsBCC[iCount]);
        PSPropValueArray(TempAddressList.aEntries[Entries + iCount].rgPropVals)[1].ulPropTag := PR_ADDRTYPE;
        PSPropValueArray(TempAddressList.aEntries[Entries + iCount].rgPropVals)[1].Value.lpsz := 'SMTP';
        PSPropValueArray(TempAddressList.aEntries[Entries + iCount].rgPropVals)[2].ulPropTag := PR_DISPLAY_NAME;
        PSPropValueArray(TempAddressList.aEntries[Entries + iCount].rgPropVals)[2].Value.lpsz := PChar(RecipientsBCC[iCount]);
        PSPropValueArray(TempAddressList.aEntries[Entries + iCount].rgPropVals)[3].ulPropTag := PR_RECIPIENT_TYPE;
        PSPropValueArray(TempAddressList.aEntries[Entries + iCount].rgPropVals)[3].Value.l := MAPI_BCC;
      end;

      hr := AddressBook.ResolveName(Self.Handle, MAPI_DIALOG or fMapiUnicode or AB_UNICODEUI, 'Who?', TempAddressList);
      if failed(hr) then
      begin
        MessageDlg(GetMApiError(AddressBook, hr), mtError, [mbOK], 0);
        Exit;
      end;

      if Assigned(AddressListRecipients) then
      begin
        FreePadrlist(AddressListRecipients);
        AddressListRecipients := nil;
      end;

      hr := HrMAPICreateSizedAddressList(TempAddressList.cEntries, AddressListRecipients);
      if failed(hr) then
      begin
        MessageDlg(GetMApiError(nil, hr), mtError, [mbOK], 0);
        Exit;
      end;

      for Entries := 0 to TempAddressList.cEntries - 1 do
        HrMAPISetAddressList(Entries, TempAddressList.aEntries[Entries].cValues,
          TempAddressList.aEntries[Entries].rgPropVals, AddressListRecipients);

      if Assigned(TempAddressList) then
      begin
        FreePadrlist(TempAddressList);
        TempAddressList := nil;
      end;
    end;

    RecipientsTo.Clear;
    RecipientsCC.Clear;
    RecipientsBCC.Clear;

    if Assigned(AddressListRecipients) then
      for iCount := 0 to AddressListRecipients.cEntries - 1 do
        for Counter := 0 to AddressListRecipients.aEntries[iCount].cValues - 1 do
          if (PSPropValueArray(AddressListRecipients.aEntries[iCount].rgPropVals)[Counter].ulPropTag = PR_RECIPIENT_TYPE) then
          begin

            if PSPropValueArray(AddressListRecipients.aEntries[iCount].rgPropVals)[Counter].Value.l = MAPI_TO then
              for Entries := 0 to AddressListRecipients.aEntries[iCount].cValues - 1 do
                if PSPropValueArray(AddressListRecipients.aEntries[iCount].rgPropVals)[Entries].ulPropTag = PR_DISPLAY_NAME then
                begin
                  RecipientsTo.Add(PSPropValueArray(AddressListRecipients.aEntries[iCount].rgPropVals)[Entries].Value.lpsz);
                  break;
                end;

            if PSPropValueArray(AddressListRecipients.aEntries[iCount].rgPropVals)[Counter].Value.l = MAPI_CC then
              for Entries := 0 to AddressListRecipients.aEntries[iCount].cValues - 1 do
                if PSPropValueArray(AddressListRecipients.aEntries[iCount].rgPropVals)[Entries].ulPropTag = PR_DISPLAY_NAME then
                begin
                  RecipientsCC.Add(PSPropValueArray(AddressListRecipients.aEntries[iCount].rgPropVals)[Entries].Value.lpsz);
                  break;
                end;

            if PSPropValueArray(AddressListRecipients.aEntries[iCount].rgPropVals)[Counter].Value.l = MAPI_BCC then
              for Entries := 0 to AddressListRecipients.aEntries[iCount].cValues - 1 do
                if PSPropValueArray(AddressListRecipients.aEntries[iCount].rgPropVals)[Entries].ulPropTag = PR_DISPLAY_NAME then
                begin
                  RecipientsBCC.Add(PSPropValueArray(AddressListRecipients.aEntries[iCount].rgPropVals)[Entries].Value.lpsz);
                  break;
                end;

            break;
          end;

    if Assigned(TempAddressList) then
    begin
      FreePadrlist(TempAddressList);
      TempAddressList := nil;
    end;

    if Assigned(AddressListRecipients) then
    begin
      hr := MAPIMessage.ModifyRecipients(0, AddressListRecipients);
      if failed(hr) then
      begin
        MessageDlg(GetMApiError(MAPIMessage, hr), mtError, [mbOK], 0);
        Exit;
      end;

    end;

    ebTo.Text := '';
    for Entries := 0 to RecipientsTo.Count - 1 do
      ebTo.Text := ebTo.Text + RecipientsTo[Entries] + ';';

    ebCc.Text := '';
    for Entries := 0 to RecipientsCC.Count - 1 do
      ebCc.Text := ebCc.Text + RecipientsCC[Entries] + ';';

    ebBcc.Text := '';
    for Entries := 0 to RecipientsBCC.Count - 1 do
      ebBcc.Text := ebBcc.Text + RecipientsBCC[Entries] + ';';

  finally
    if Assigned(TempAddressList) then
    begin
      FreePadrlist(TempAddressList);
      TempAddressList := nil;
    end;

    if Assigned(RecipientsTo) then
      RecipientsTo.Free;
    if Assigned(RecipientsCC) then
      RecipientsCC.Free;
    if Assigned(RecipientsBCC) then
      RecipientsBCC.Free;
    AddressBook := nil;
  end;
end;

procedure TfrmNewMess.SpeedButton1Click(Sender: TObject);
var
  MsgName: WideString;
  hr: HRESULT;
  FStorage: IStorage;
  FMalloc: IMalloc;
  FMAPIMessage: IMessage;
  Tbl: IMAPITable;
  pRows: PSRowSet;

const
  RecipTags: TSPropTagArray = (cValues: 1; aulPropTag: (PR_ROWID));

const
PropTagArray:
record cValues: ULONG;
aulPropTag:
array [0 .. 10 - 1] of ULONG;
end
= (cValues: 10; aulPropTag: (PR_SENDER_ADDRTYPE, PR_SENDER_EMAIL_ADDRESS, PR_SENDER_ENTRYID, PR_SENDER_NAME, PR_SENDER_SEARCH_KEY,
  PR_SENT_REPRESENTING_ADDRTYPE, PR_SENT_REPRESENTING_EMAIL_ADDRESS, PR_SENT_REPRESENTING_ENTRYID, PR_SENT_REPRESENTING_NAME,
  PR_SENT_REPRESENTING_SEARCH_KEY));

begin
  if not OpenDialog2.Execute then
    Exit;

  MessageBody.Clear;
  MessageBody.ReadOnly := True;
  sbAttach.Enabled := False;

  MsgName := OpenDialog2.FileName;

  FMAPIMessage := nil;
  FStorage := nil;

  if not Assigned(FMalloc) then
    Pointer(FMalloc) := MAPIGetDefaultMalloc;

  hr := StgOpenStorage(PWideChar(MsgName), nil, STGM_TRANSACTED or
    STGM_SHARE_EXCLUSIVE or STGM_READWRITE, nil, 0, FStorage);
  if not Succeeded(hr) then
    raise Exception.Create(GetMApiError(nil, hr));


  // Open an IMessage interface on an IStorage object

  hr := OpenIMsgOnIStg(nil, @ExtendedMAPI.MAPIAllocateBuffer,
    @ExtendedMAPI.MAPIAllocateMore, @ExtendedMAPI.MAPIFreeBuffer, FMalloc, nil,
    FStorage, nil, 0, IMSG_NO_ISTG_COMMIT or MAPI_UNICODE, FMAPIMessage);

  if not Succeeded(hr) then
  begin
    if (hr <> MAPI_E_UNKNOWN_FLAGS) and (hr <> MAPI_E_CORRUPT_DATA) then
      raise Exception.Create(GetMApiError(nil, hr));
    hr := OpenIMsgOnIStg(nil, @ExtendedMAPI.MAPIAllocateBuffer,
      @ExtendedMAPI.MAPIAllocateMore, @ExtendedMAPI.MAPIFreeBuffer, FMalloc,
      nil, FStorage, nil, 0, IMSG_NO_ISTG_COMMIT, FMAPIMessage);
  end;

  if not Succeeded(hr) then
    raise Exception.Create(GetMApiError(nil, hr));

  hr := FMAPIMessage.CopyTo(0, nil, nil, 0, nil, @IID_IMessage,
    Pointer(MAPIMessage), 0, PSPropProblemArray(nil^));
  if not Succeeded(hr) then
    raise Exception.Create(GetMApiError(nil, hr));

  // delete all old recipients
  if S_OK = MAPIMessage.GetRecipientTable(0, Tbl) then
  begin
    if S_OK = HrQueryAllRows(Tbl, @RecipTags, nil, nil, 0, pRows) then
    begin
      MAPIMessage.ModifyRecipients(MODRECIP_REMOVE, PADRLIST(pRows));
      FreePRows(pRows);
    end;
    Tbl := nil;
  end;

  ebTo.Text := '';
  ebSuubject.Text := 'Fw:' + GetPropString(MAPIMessage, PR_SUBJECT);

  hr := MAPIMessage.DeleteProps(@PropTagArray, PSPropProblemArray(nil^));
  if not Succeeded(hr) then
    raise Exception.Create(GetMApiError(MAPIMessage, hr));

  MessageBody.Text := GetPropString(MAPIMessage, PR_SUBJECT);

end;

end.