Leere Seite (blank page) filtern bei DelphiTwain

[Schwedenbitter]

Zitat von Sir Rufo:

So als Verbesserungsvorschlag:

Verkleinere die Bitmaps ...

Auch das hört sich überzeugend an,
ABER
manchmal schreibt auch ein Staatsanwalt nur mit sehr dünnem und spitzen Bleistift. Dann müsste ich vor dem Verkleinern am Kontrast schrauben, weil mir sonst die Striche durch die Lappen gehen und das Bild als leer identifiziert wird. Ich hatte irgendwo mal angemerkt, dass ich schon umfangreiche Tests gerade mit Bleistift gemacht hatte.
Das wiederum (erst Kontrast, dann BitBlt, dann Pixelsuche) führt am Ende vermutlich nicht mehr zu einer weiteren Beschleunigung. Ich fürchte, das macht es eher fehleranfällig.

Außerdem arbeiten wir im Moment mit Singlecore Celerons. Da läuft das schon flott. Wir stellen aber auf Windows 10 und zugleich auf Quadcore-Rechner um. Die sollen mal schön rechnen. Die Mitarbeiter müssen sich ja auch mal einen Kaffee holen können. Das schaffen die sowieso schon nicht mehr

[Jens01]

"Staatsanwalt"

Vielleicht solltest Du die "leeren" Seiten nicht verwerfen, sondern nur extra ablegen.

[hanvas]

Eines vorweg, die meisten besseren Dokumentenscanner unterstützen dieses Feature in der Hardware oder im Treiber.

Falls ein solcher zum Einsatz kommt wäre es klüger die dort implementierten Verfahren zu verwenden. Das entsprechende Feature nennt sich ICAP_AUTODISCARDBLANKPAGES und ist ab der Revision 2.1 des Standards vorhanden, die meisten TWAIN Delphi Implementierungen basieren aber auf TWAIN 2.0 und haben deswegen die entsprechenden Konstanten nicht definiert.

Zitat von Schwedenbitter:

Auch das hört sich überzeugend an,

ABER

manchmal schreibt auch ein Staatsanwalt nur mit sehr dünnem und spitzen Bleistift.

Der in diesem Fall einfachste - und dennch relativ zuverlässigste Weg wäre - ein leistungsfähiges globales oder lokales Verfahren zur Wandlung des Graustufenbildes in ein Schwarzweissbild zu verwenden. Das hat den Vorteil das der Vordergrund und der Hintergrund des Bildes relativ sauber getrennt wird, selbst dann wenn es über die Seite verteilt Unterschiede in der Helligkeit gibt. Normalerweise sollte auch der dünne Strich Deines Staatsanwaltes erhalten bleiben.

Ich habe Dir ein paar Beispiele dazu hingeschrieben.

Die Verwendung meiner Beispiele wäre :

Code:

 var x : Integer;

 x := TreshXXXX(Image);
 newImage := BinarizeThrsh(Image,x);

Aber Du kannst den Code ohnehin nicht 1:1 verwenden. ThreshOtuDisc wäre der Klassiker, ThreshEntropy ist aber schneller ich verwende in einer ähnlichen Situation :

Code:

     t := TOcrImage.CreateFromBitmap(Image.Bitmap);
     case isBW of
      0 : o := t; // wir sind sw ->
      1 : try
           thrsh := ThreshEntropy(t);
           if ( thrsh < 0 ) then
               thrsh := ThrshOptimum(t);
           if ((thrsh) < 0) then
             begin
             result := False;
             exit;
            end;
           o     := BinarizeThresh(t, thrsh);
          finally
           t.free;
          end; 
     ......
     end;

Da Du anschließend ein Schwarweißbild hast führst Du eine Analyse der verbundenen Regionen durch - mit anderen Worten du arbeitest dich rekursiv bei einem Pixel in Schwarz zum nächsten Pixel vor das an das erste Pixel angrenzt dann zum nächsten usw. bis Du eine komplette zusammenhängende Region hast und speicherst diese Regionen und deren Eigenschaften in einer Liste.

Du kannst davon ausgehen das einzelne Pixel, oder Verbunde von Pixeln unterhalb eines gewissen Größe Dreck, Staub etc. sind. Diese Elemente kannst Du löschen. Anschließend stellt Du fest ob Du große zusammenhängende Regionen hast deren Bounding Box sehr schmal ist aber dafür nahezu die gesamte Höhe des gescannten Blattes einimmst. Dabei handelt es sich um horizontale Linien die normalerweise durch Dreck oder Kratzer auf dem Scannerglas entstanden sind. Auch die kannst Du löschen (aber nur wenn die Box wirklich relativ schmal ist)

Wenn Du auf diese Art alle unerwünschten Einflüsse eleminiert hast rekonstriest Du das Bild anhand der noch vorhandenen Elemente in der Liste. Anschließend bildest Du die Bounding Box über das gesamte Bild - ich würde übrigens beim Scannen den Rand in einer Breite von 5 - 15 Pixel noch vor der Erstellung der Liste löschen bzw. auf Weiss setzen.

Nun betrachtest Du nur den Inhalt in der Box und nimmst einen Wert zwischen 1% und 5% an - ist die Anzahl der gesetzten Pixel darunter kannst Du von einem leeren Bild ausgehen. Anpassungen an spezielle Problemstellungen sind natürlich möglich.

Im nachfolgenden Beispiel habe ich die Klasse TOcrImage nicht definiert - die einzelnen Zeilen eines Bildes sind aber nichts anderes als Arrays bzw. Zeiger auf Arrays deren einzelne Elemente Bytes sind - im Fall eines Graustufenbildes von 0-255 im S/W Fall eben 0/1.

Die Implementierungen sind entweder eine Umsetzung bekannter Verfahren oder ich habe Sie dem Buch "Practical Algorithms for Image Analysis" entnommen und von C nach Pascal umgesetzt.

Code:

type     TOcrIntegerHistogram = array of Integer;
         TOcrDoubleHistogram  = array of Double;

procedure TOcrImage.Histogram  ( var Hist : TOcrIntegerHistogram );
var i   : Integer;
    y,x : Integer;
begin
 SetLength ( Hist, 256 );
 for i := 0 to 255 do Hist[i] := 0;
 for y := 0 to pred ( Nr ) do
     for x := 0 to pred ( Nc ) do
               inc ( Hist[Data[y,x]] );
end;

procedure  TOcrImage.RelativeHistogramm ( var hist : TOcrDoubleHistogram );
var histI   : TOcrIntegerHistogram;
    pixels  : LongInt;
    counter : Integer;
begin
 pixels := Nr * Nc;
 SetLength ( hist, 256 );
 if ( pixels <= 0 ) then
 begin
  for counter := 0 to 255 do
      hist[counter] := 0;
  exit;
 end;
 Histogram ( histI );
 for counter := 0 to 255 do
     hist[counter] := histI[counter] / pixels;
 SetLength ( histI, 0 );
end;

function BinarizeThresh ( const ImgIn : TOcrImage; Thresh : Integer ) : TOcrImage;
var i,j   : Integer;
    pS,pT : pByte;
begin
  result := TOcrImage.Create ( ImgIn.Nr, ImgIn.Nc );
  for j := 0 to pred ( imgIn.Nr ) do
  begin
   i  := 0;
   pS := imgIn.GetLinePointer ( j, 0 );
   pT := result.GetLinePointer ( j, 0 );
   while (i < imgIn.Nc ) do
    begin
       if ( pS^ < thresh ) then pT^ := _ON
                           else pT^ := _OFF;
       inc(pS);
       inc(pT);
       inc(i);
    end;
  end;
end;


function ThreshEntropy ( const ImgIn : TOcrImage ) : Integer;
var  width, height : Integer;           (* image size *)
     Hn, Ps, Hs    : Double;
     psi, psiMax   : Double;
     x, y,                    (* image coordinates *)
     i, j, n       : Integer;
     iHist : array [0..NHIST-1] of integer;            (* hist. of intensities *)
     prob  : array [0..NHIST-1] of Double;
begin
 result  := -1;
(* allocate input and output image memory *)
  height := imgIn.Nr;
  width  := imgIn.Nc;
(* compile histogram *)
  for i := 0 to pred ( NHIST ) do iHist[i] := 0;

  n := 0;
  for y := 0 to pred ( height ) do
    for x := 0 to pred ( width ) do
     begin
      inc(iHist[imgIn.Data[y,x]]);
      inc(n);
     end;

  if ( n <= 0 ) then begin
                       result := -1;
                       exit;
                     end;
  (* compute probabilities *)
  for i := 0 to pred ( NHIST ) do
      prob[i] := iHist[i] / n;

(* find threshold *)
  hn := 0;
  for i := 0 to pred ( NHIST ) do
    if (prob[i] <> 0.0) then
      Hn := hn - ( prob[i] * ln (prob[i]) );
  psiMax := 0.0;
  for i := 1 to pred ( NHIST ) do
   begin
     ps := 0;
     hs := 0;
     for j := 0 to pred ( i ) do
       begin
        Ps := ps + prob[j];
        if (prob[j] > 0.0) then
          Hs := hs - ( prob[j] * ln (prob[j]) );
    end;
    if (Ps > 0.0) and (Ps < 1.0) then
    begin
      psi := ln (Ps - Ps * Ps) + Hs / Ps + (Hn - Hs) / (1.0 - Ps);
      if (psi > psiMax) then
      begin
       psiMax := psi;
       result := i;
     end;
    end;
  end;
end;

function ThrshOptimum         ( const ImgIn : TOcrImage ) : Integer;
var x,y,Flag,j : Integer;
    hist       : TOcrDoubleHistogram;
    Sum        : Double;
begin
 ImgIn.RelativeHistogramm ( hist );
 for y := 0 to 255 do
  begin
   sum := 0;
   for x := -15 to 15 do
    begin
     j := y-x;
     if  ( ( j ) >= 0  ) and
         ( ( j < 255 ) ) then Sum := Sum + Hist[j];
    end;
   Hist[y] := SUM / 31 ; 
  end;
  Y      := 2;
  FLAG   := 0;
  result := 0;
  while ( Flag = 0 ) and ( y < 254 ) do
   begin
    if ( ( HIST [Y-1] >= HIST[y  ] )   and
         ( HIST [Y]   <  HIST[y+1] ) ) then
           begin
            Flag   := 1;
            result := Y;
           end;
    inc ( y );
   end;
 SetLength ( hist, 0 );
end;

function ThrshMovingAvarage (const imgIn : TOcrImage ) : TOcrImage;
var    NC, row, col, _inc : Integer ;
       mean, s, sum       : Double;
       N, i               : Integer;
      im                 : TOcrImage;
begin
  im   := TOcrImage.CopyCreate ( imgIn ); 
   N   := im.nc * im.nr;
   NC  := im.nc;
   s   := (NC/Navg);
   sum := 127*s;
   row := 0;
  col := 0;
   _inc := 1;

   for i:= 0 to pred ( N-1 ) do
   begin
     if (col >= NC) then   begin
       col := NC-1;
      inc(row);
       _inc := -1;
      end
    else
     if (col < 0) then
      begin
         col := 0;
        inc(row);
        _inc := 1;
       end;

   // Estimate the mean of the last NC/8 pixels.
     sum  := sum - sum/s + im.Data[row,col];
     mean := sum/s;
     if ( im.Data[row,col] < mean*(100-pct)/100.0) then im.Data[row,col] := 0
                                                  else im.Data[row,col] := 255;
     col := col + _inc;
   end;
  im.Invert;
  result := im;
end;

function ThreshOtuDisc ( const ImgIn : TOcrImage ) : Integer;
var
  width, height,           (* image size *)
  nHistM1,
  x, y,                    (* image coordinates *)
  i, j, n : Integer;
  m0Low, m0High, m1Low, m1High, varLow, varHigh,
  varWithin, varWMin : Double;
  prob  : array [0..NHIST-1] of double;
  iHist : array [0..NHIST-1] of integer;      (* hist. of intensities *)
begin
 (* allocate input and output image memory *)
  height := imgIn.Nr;
  width  := imgIn.Nc;
 (* compile histogram *)
 FillChar ( iHist[0], NHIST * SizeOf(Integer), 0 );
 // for i := 0 to pred ( NHIST ) do iHist[i] := 0;
  n := 0;
  for y := 0 to pred ( height ) do
    for x := 0 to pred ( width ) do
     begin
      inc(iHist[imgIn.Data[y,x]]);
      inc(n);
     end;
(* compute probabilities *)
  for i := 0 to pred ( NHIST ) do prob[i] := iHist[i] / n;

(* find best threshold by computing moments for all thresholds *)
  nHistM1 := NHIST - 1;
  result  := 0;
  varWMin := 100000000.0;
  for   i := 1 to pred ( nHistM1 ) do
   begin
    m0Low   := 0.0;
    m0High  := 0.0;
    m1Low   := 0.0;
    m1High  := 0.0;
    varLow  := 0.0;
    varHigh := 0.0;
    for j := 0 to i do
     begin
      m0Low := m0Low + prob[j];
      m1Low := m1Low + j * prob[j];
     end;
    if ( m0Low <> 0.0 ) then m1Low := m1Low / m0Low
                        else m1Low := i;
    for j := i + 1 to pred ( NHIST ) do
     begin
      m0High := m0High + prob[j];
      m1High := m1High + j * prob[j];
     end;
    if ( m0High <> 0 ) then m1High := m1High / m0High
                       else m1High := 1;
    for j := 0 to i do
        varLow := varLow + ( (j - m1Low) * (j - m1Low) * prob[j] );
    for j := i + 1 to pred ( NHIST ) do
        varHigh := varHigh + ( (j - m1High) * (j - m1High) * prob[j] );

    varWithin := m0Low * varLow + m0High * varHigh;
    if (varWithin < varWMin) then
     begin
      varWMin := varWithin;
      result  := i;
    end;
  end;
end;

cu Ha-Jö