procedure TMain.Button1Click(Sender: TObject);

var

  rLeft, rTop, rRigth, rBottom, rMinH, rMinW: Integer;

  glBitMap: Vcl.Graphics.TBitmap;

  rRestsList: string;

begin  // запуск процесса поиска

  glBitMap := TBitmap.Create;

  try

    if FindRects(glBitMap, rRestsList) then

      Memo1.Lines.Add(rRestsList);

  finally

    FreeAndNil(glBitMap);

  end;

end;

 

(* 2024.12.21 to find all exseptable rectigies coordinates in bmp *)

function FindRects(const aBitmap: Vcl.Graphics.TBitmap; var aRestsList: string): Boolean;

var

  H, W, hStart, wStart: Integer;

  stFlg: Boolean;

  Clr, aLeft, aTop, aRigth, aBottom: Integer;

  RestsList: string;

begin

  Result := false;

  hStart := 0;  // установка поиска в начало координат файл.БМП

  wStart := 0;

 

  repeat // повтор поиска

    stFlg := false;

    

    // функция DefineRectCoo возвращает ДА и координаты лево-верх-справа-низ ПЕРВОГО! найденного прямоугольника в файл.БМП

    if DefineRectCoo(aBitmap, hStart, wStart, aLeft, aTop, aRigth, aBottom) then  

    begin

      (* send data to output *)  //сбор координат найденных прямоугольников

      Insert((IntToStr(aLeft) + ':' + IntToStr(aTop) + ':' + IntToStr(aRigth) + ':' + IntToStr(aBottom) +

        sLineBreak), aRestsList, (aRestsList.Length + 1));

      (* ---------------------- *)

 

      stFlg := true; //запуск повторного поиска

    end;

 

    (* next rigth-top rect *)

    hStart := aTop; wStart := aRigth + 1;  //поиск из новой начальной точки: верх-справа от найденного прямоугольника

 

  until (stFlg = false);

 

  if (aRestsList.Length > 0) then

    Result := true;

end;

(* -------------------------------------------- *)