Development

unit unNewMess;

interface

{$I IMI.INC}

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

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;
    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);
  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, MAPIUtils, EDK, MainUnit, MAPIMacros;

{$R *.DFM}

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(MsgStore, 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;
    OleCheck(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;

    OleCheck(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;

    OleCheck(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;
    OleCheck(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);
    OleCheck(Attachment.SaveChanges(KEEP_OPEN_READWRITE));

    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
      OleCheck(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;

      // The IAddrBook.ResolveName method performs name resolution,
      // assigning entry identifiers to recipients in a recipient list

      hr := AddressBook.ResolveName(Self.Handle, MAPI_DIALOG or AB_UNICODEUI or
        fMAPIUnicode, '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;

      // The HrMAPICreateSizedAddressList function creates a sized address list

      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[iCoun.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;

end.