home *** CD-ROM | disk | FTP | other *** search
/ Delphi 2 - Developers' Solutions / Delphi 2 Developers' Solutions.iso / dds / chap06 / howto02 / delphi10 / drwsutl6.pas < prev    next >
Encoding:
Pascal/Delphi Source File  |  1996-01-04  |  6.5 KB  |  170 lines
  1. unit Drwsutl6;
  2.  
  3. interface
  4. uses
  5.   SysUtils, WinTypes, WinProcs, Messages, Classes, Graphics, Controls,
  6.   Forms, Dialogs, StdCtrls, Buttons, ExtCtrls, ShellAPI, FileCtrl;
  7.  
  8. function CreateBitmapThumbNailFromBitmap( SourceBMP: TBitmap;
  9.                                           TargetWidth ,
  10.                                           TargetHeight : Integer ) : TBitmap;
  11.  
  12. implementation
  13.  
  14. function CreateBitmapThumbNailFromBitmap( SourceBMP: TBitmap;
  15.                                           TargetWidth ,
  16.                                           TargetHeight : Integer ) : TBitmap;
  17. var OutputBMP : TBitmap;
  18.     HoldingBMP : TBitmap;
  19.     TotalSourceColsPerOutputCol,
  20.     TotalSourceRowsPerOutputRow,
  21.     Counter_1 ,
  22.     Counter_2 ,
  23.     Counter_3 : Integer;
  24.     CurrentColor : Longint;
  25.     CurrentRowPointer,
  26.     CurrentColPointer,
  27.     BestLineSoFar ,
  28.     TotalColorsInWork : Integer;
  29.     MaxColorsSoFar    : Integer;
  30. begin
  31.   { if source smaller than or equal to thumbnail, stretchdraw and leave }
  32.   if (( SourceBMP.Width <= TargetWidth ) and
  33.       ( SourceBMP.Height <= TargetHeight )) then
  34.   begin
  35.     OutputBMP := TBitmap.Create;
  36.     OutputBMP.Height := TargetHeight;
  37.     OutputBMP.Width := TargetWidth;
  38.     OutputBMP.Canvas.StretchDraw( Rect( 0 , 0 , TargetWidth , TargetHeight ) ,
  39.      SourceBMP );
  40.     CreateBitmapThumbNailFromBitmap := OutputBMP;
  41.     exit;
  42.   end;
  43.   { Otherwise do thumbnail algorithm }
  44.   { Create the interim holding bitmap; it will hold full width but resized # rows }
  45.   HoldingBMP := TBitmap.Create;
  46.   HoldingBMP.Width := SourceBMP.Width;
  47.   HoldingBMP.Height := TargetHeight;
  48.   { Create the final output bitmap; it will hold the resized values in both h & w }
  49.   OutputBMP := TBitmap.Create;
  50.   OutputBMP.Width := TargetWidth;
  51.   OutputBMP.Height := TargetHeight;
  52.   { Determine the total source rows and cols per output row and col }
  53.   TotalSourceRowsPerOutputRow := ( SourceBMP.Height div TargetHeight );
  54.   if ( SourceBMP.Height mod TargetHeight ) <> 0 then
  55.    Inc( TotalSourceRowsPerOutputRow );
  56.   TotalSourceColsPerOutputCol := ( SourceBMP.Width div TargetWidth );
  57.   if ( SourceBMP.Width mod TargetWidth ) <> 0 then
  58.    Inc( TotalSourceColsPerOutputCol );
  59.   { Start resizing by setting initial row pointer }
  60.   CurrentRowPointer := 0;
  61.   { Loop through desired number of output rows                       }
  62.   { Result will add row per group with highest color density to dest }
  63.   for Counter_1 := 1 to TargetHeight do
  64.   begin
  65.     { Reset colors per line, best cols per line, and best line pointers }
  66.     { Check all the lines in a group against each other }
  67.     TotalColorsInWork := 0;
  68.     MaxColorsSoFar := 0;
  69.     BestLineSoFar := 0;
  70.     for Counter_2 := 1 to TotalSourceRowsPerOutputRow do
  71.     begin
  72.       { Keep moving down the image }
  73.       Inc( CurrentRowPointer );
  74.       if CurrentRowPointer > SourceBMP.Height then break;
  75.       { Start with no color }
  76.       CurrentColor := -1;
  77.       TotalColorsInWork := 0;
  78.       { Actually scan the pixels }
  79.       for Counter_3 := 1 to SourceBMP.Width do
  80.       begin
  81.         { if the current pixel value is different than the stored one }
  82.         If SourceBMP.Canvas.Pixels[ Counter_3 - 1 , CurrentRowPointer - 1 ] <>
  83.          CurrentColor then
  84.         begin
  85.           { Make the new color the stored one }
  86.           CurrentColor := SourceBMP.Canvas.Pixels[ Counter_3 - 1 ,
  87.            CurrentRowPointer - 1 ];
  88.           { Increment total colors in the line }
  89.           Inc( TotalColorsInWork );
  90.         end;
  91.       end;
  92.       { At the end of the line, if there are more colors in the }
  93.       { current line than the previous best line, then }
  94.       if TotalColorsInWork > MaxColorsSoFar then
  95.       begin
  96.         { Set the new max to the current value }
  97.         MaxColorsSoFar := TotalColorsInWork;
  98.         { Set the new best line to the current pointer }
  99.         BestLineSoFar := CurrentRowPointer;
  100.       end;
  101.       { Reset the total colors being checked }
  102.       TotalColorsInWork := 0;
  103.     end;
  104.     MaxColorsSoFar := 0;
  105.     { Once best line is determined, copy all its pixels to the holding bmp }
  106.     for Counter_3 := 1 to SourceBMP.Width do
  107.     begin
  108.       HoldingBMP.Canvas.Pixels[ Counter_3 - 1 , Counter_1 - 1 ] :=
  109.        SourceBMP.Canvas.Pixels[ Counter_3 - 1 , BestLineSoFar - 1 ];
  110.     end;
  111.   end;
  112.   { Then resize by setting initial col pointer }
  113.   CurrentColPointer := 0;
  114.   { Loop through desired number of output cols                       }
  115.   { Result will add col per group with highest color density to dest }
  116.   for Counter_1 := 1 to TargetWidth do
  117.   begin
  118.     { Reset colors per line, best cols per line, and best line pointers }
  119.     TotalColorsInWork := 0;
  120.     MaxColorsSoFar := 0;
  121.     BestLineSoFar := 0;
  122.     { Check all the lines in a group against each other }
  123.     for Counter_2 := 1 to TotalSourceColsPerOutputCol do
  124.     begin
  125.       { Keep moving down the image }
  126.       Inc( CurrentColPointer );
  127.       if CurrentColPointer > HoldingBMP.Width then break;
  128.       { Start with no color }
  129.       CurrentColor := -1;
  130.       { Actually scan the pixels }
  131.       for Counter_3 := 1 to HoldingBMP.Height do
  132.       begin
  133.         { if the current pixel value is different than the stored one }
  134.         If HoldingBMP.Canvas.Pixels[ CurrentColPointer - 1 , Counter_3 - 1 ] <>
  135.          CurrentColor then
  136.         begin
  137.           { Make the new color the stored one }
  138.           CurrentColor := HoldingBMP.Canvas.Pixels[ CurrentColPointer - 1 ,
  139.            Counter_3 - 1 ];
  140.           { Increment total colors in the line }
  141.           Inc( TotalColorsInWork );
  142.         end;
  143.       end;
  144.       { At the end of the line, if there are more colors in the }
  145.       { current line than the previous best line, then }
  146.       if TotalColorsInWork > MaxColorsSoFar then
  147.       begin
  148.         { Set the new max to the current value }
  149.         MaxColorsSoFar := TotalColorsInWork;
  150.         { Set the new best line to the current pointer }
  151.         BestLineSoFar := CurrentColPointer;
  152.       end;
  153.       { Reset the total colors being checked }
  154.       TotalColorsInWork := 0;
  155.     end;
  156.     { Once best line is determined, copy all its pixels to the holding bmp }
  157.     for Counter_3 := 1 to HoldingBMP.Height do
  158.     begin
  159.       OutputBMP.Canvas.Pixels[ Counter_1 - 1 , Counter_3 - 1 ] :=
  160.        HoldingBMP.Canvas.Pixels[ BestLineSoFar - 1 , Counter_3 - 1 ];
  161.     end;
  162.   end;
  163.   { Finally, output the thumbnail image }
  164.   CreateBitmapThumbNailFromBitmap := OutputBMP;
  165.   { And free the working copy }
  166.   HoldingBMP.Free;
  167. end;
  168.  
  169. end.
  170.