Development

Request # 29

How to spy for incoming messages where Subject contains „xxxxx“ and move them to specific folder?

This example requires you to use a Microsoft Exchange account.

Code snip:

procedure TfrmMain.ProcessConditions;
var
  Subject: string;
  FolderName: string;
  Restriction: TRestrictionAnd;
  MessageCount: ULONG;
  MsgList: TMsgHeadList;
  EntryIDMsgList: array of TBytes;
  iCount: Integer;
  MAPIProgrs: IMAPIProgress;

  // Advise (spy)
  AdviseSink, AdviseSinkReal: IMAPIAdviseSink;

  ForceTagArray: PSPropTagArray;
  cValues: ULONG;
  PropValue: PSPropValue;
const
   BindingProperties: record
     cValues: ULONG;
     aulPropTag: array [0 .. 1] of ULONG
   end = (cValues: 2;
          aulPropTag: (PR_ENTRYID, PR_SUBJECT););
begin
  MsgList := nil;
  EntryIDMsgList := nil;
  MAPIProgrs := nil;
  fInboxUID := nil;

  Subject := Trim(ebSubject.Text);
  if Subject = '' then
    raise Exception.Create('Subject field is Empty!');

  FolderName := Trim(ebFolderName.Text);

  if (FolderName = '') then
    raise Exception.Create('Folder Name field is Empty!');

  // "Top Of"  folder
  fTopFolder := GetTopFolder(fMailbox);
  if not Assigned(fTopFolder) then
    raise EMAPIError.Create('Cannot get "Top Of"  folder');

  // Create/Open   "Where" Folder
  hr := fTopFolder.CreateFolder(FOLDER_GENERIC,
                                PChar(@FolderName[1]),
                                nil,
                                @IID_IMAPIFolder,
                                fMAPIUnicode or OPEN_IF_EXISTS,
                                fFolderTo);
  if failed(hr) then
    raise EMAPIError.CreateMAPI(fTopFolder, hr);

  if Assigned(fFolderTo) and (GetPropString(fFolderTo, PR_CONTAINER_CLASS)='') then
    SetPropString(fFolderTo, PR_CONTAINER_CLASS, 'IPF.Note');

  // We have chosen to locate and move those messages
  if (rgFindAndSpy.ItemIndex = 0) or (rgFindAndSpy.ItemIndex = 2) then
  begin
    // Set mandatory properies
    // PR_ENTRYID - Message Unique ID
    // PR_SUBJECT - That which we look
    hr := fContentTable.SetColumns(@BindingProperties, TBL_BATCH);
    if failed(hr) then
      raise EMAPIError.CreateMAPI(fContentTable, hr);

    // Create AND Restriction
    Restriction := TRestrictionAnd.Create(fContentTable);

    // We will look for PT_SUBJECT existence
    with Restriction.Add(resEXIST) as TRestrictionExist do
    begin
      PropTag := PR_SUBJECT;
    end;

    // Set looking subject
    with Restriction.Add(resCONTENT) as TRestrictionContent do
    begin
      PropTag := PR_SUBJECT;
      Prefix := rbStart.Checked;
      FullString := rbIsEqual.Checked;
      SubString := rbContains.Checked;
      IgnoreCase := True;
      Loose := True;
      Value := Subject;
    end;

    // Apply restriction
    Restriction.Apply;

    MessageCount := 0;
    // Get Count of messages
    hr := fContentTable.GetRowCount(0, MessageCount);
    if failed(hr) then
      raise EMAPIError.CreateMAPI(fContentTable, hr);

    memoLog.lines.Add(IntToStr(MessageCount) + ' messages satisfy the restriction');

    // if the number of messages that meet this criterion is greater than zero
    if MessageCount > 0 then
    begin
      // Get restricted message list
      MsgList := GetMessageList(fContentTable);
      // Set EntryID List Length
      SetLength(EntryIDMsgList, Length(MsgList));

      for iCount := 0 to Length(MsgList) - 1 do
      begin
        SetLength(EntryIDMsgList[iCount], Length(MsgList[iCount].ID));
        Move(MsgList[iCount].ID[0], EntryIDMsgList[iCount][0], Length(MsgList[iCount].ID));
        memoLog.lines.Add('Message with subject ' + MsgList[iCount].Subject + ' found');
      end;

      MAPIProgrs := TMAPIProgress.Create(Self, ' Copying messages ');

      Try
        CopyOrMoveMapiMessages(fInbox,
                               fFolderTo,
                               EntryIDMsgList,
                               True,
                               MAPIProgrs,
                               Self.Handle);
        memoLog.lines.Add('Messages are moved...');
      Finally
        MAPIProgrs := nil;
        for iCount := 0 to Length(EntryIDMsgList) - 1 do
          EntryIDMsgList[iCount] := nil;

        for iCount := 0 to Length(MsgList) - 1 do
          MsgList[iCount].ID := nil;

        EntryIDMsgList := nil;
        MsgList := nil;
      End;
    end; // if MessageCount>0 then
  end; // if (rgFindAndSpy.ItemIndex=0) or (rgFindAndSpy.ItemIndex=2) then

  // Advise
  if (rgFindAndSpy.ItemIndex <> 0) then
  begin
    // AdviseSink already exists ?
    if (fConnectionID <> 0) then
      Exit;

    // Create our Advise Sink Object
    AdviseSink := TStoreAdvise.Create(Self);

    // Creates an advise sink that wraps the existing advise sink for thread safety.
    // http://msdn.microsoft.com/en-us/library/office/cc765675.aspx
    hr := HrThisThreadAdviseSink(AdviseSink, AdviseSinkReal);
    If failed(hr) Then
      AdviseSinkReal := AdviseSink;

    AdviseSink := nil;

    // Get Inbox Unique ID
    // We will "spy" only Inbox folder
    fInboxUID := GetPropBinaryAsBytes(fInbox, PR_ENTRYID);

    // Register for notification
    // we will look only for - fnevNewMail -> Registers for notifications about the arrival of new messages.
    // http://msdn.microsoft.com/en-us/library/office/cc842238.aspx
    hr := fMailbox.Advise(ULONG(Length(fInboxUID)),
                          PENTRYID(@fInboxUID[0]),
                          fnevNewMail,
                          AdviseSinkReal,
                          fConnectionID);
    AdviseSinkReal := nil;

    If failed(hr) Then
    begin
      fConnectionID := 0;
      raise EMAPIError.CreateMAPI(fMailbox, hr);
    end;

    (*
     In order to "wake up" the MAPI Subsystem, and ignore the caching,
     we will again force RPC traffic, this time a little more intensely.
     All this is necessary when our MsgStore is on an Exchange Server.
     When we have a local MsgStore, it will suffice to only take some property
     through the function
     HrGetOneProp(lpMapiProp: IMAPIPROP; ulPropTag: ULONG; out lppProp: PSPropValue): HResult
     that generates the necessary RPC traffic
    *)

    ForceTagArray := nil;
    PropValue := nil;
    try
      hr := fInbox.GetPropList(0, ForceTagArray);
      if failed(hr) then
        ForceTagArray := nil;

      hr := fInbox.GetProps(ForceTagArray, 0, cValues, PropValue);
      if failed(hr) then
        MAPIFreeBuffer(PropValue);

      cValues := 0;
      fContentTable := nil;

      fContentTable := GetMsgTable(fInbox);
      fContentTable.GetRowCount(0, MessageCount);
      // end "wake up"
      memoLog.lines.Add('Inbox folder is monitored...');
    finally
      if Assigned(ForceTagArray) then
        MAPIFreeBuffer(ForceTagArray);
      if Assigned(PropValue) then
        MAPIFreeBuffer(PropValue);
    end;
  end;

  if (rgFindAndSpy.ItemIndex <> 0) then
  begin
   btStart.Tag := -1;
   btStart.Caption := 'Stop';
   gbSubjectConditions.Enabled := False;
   gbMoveTo.Enabled := False;
   rgFindAndSpy.Enabled := False;
  end
  else
  begin
   memoLog.lines.Add(' No more actions...')
  end;
end;


function TfrmMain.OnNotify(cNotif: ULONG; Notifications: PNOTIFICATION): ULONG;
var
  iCount: Integer;
  NOTIFICATION: TNOTIFICATION;
begin
  Result := S_OK;
  for iCount := 0 to cNotif - 1 do
  begin
    NOTIFICATION := PNOTIFICATIONArray(Notifications)[iCount];
    case NOTIFICATION.ulEventType of
      // Registers for notifications about severe errors, such as insufficient memory.
      fnevCriticalError:
        begin
         // Nothing
        end;
      // Registers for notifications about the arrival of new messages.
      fnevNewMail:
        begin
          DoNewMail(NOTIFICATION);
        end;
      // Registers for notifications about events specific to the particular message store provider.
      fnevExtended:
        begin
         // Nothing
        end;
      // Registers for notifications about the creation of a new folder or message.
      fnevObjectCreated,
      // Registers for notifications about a folder or message being copied.
      fnevObjectCopied,
      // Registers for notifications about a folder or message being deleted.
      fnevObjectDeleted,
      // Registers for notifications about a folder or message being modified.
      fnevObjectModified,
      // Registers for notifications about a folder or message being moved.
      fnevObjectMoved,
      // Registers for notifications about the completion of a search operation.
      fnevSearchComplete:
        begin
          // Nothing
        end;
    end;
  end;
end;