Prevent clipping and draw caption

[w2m]

I have your very nice ThumbnailDraw method almost working perfect.

Everything is good except sometimes depending on thumbnail width the thumbnails are clipped on the right edge of the page. The clipped images do not move to the next row until they are completely off the page right margin. See attached image of clipping.

I also modified ThumbnailDraw to optionally draw a thumbnail caption:

Code: Select all

    ThumbnailDraw ( BMP.Canvas, BMP.Canvas.ClipRect, fImageWidth, fImageHeight, fBorder, GraphicsArray, CaptionArray );


Here is the modified method. Do I have it correct?

Code: Select all



function ThumbnailDraw ( Canvas: TCanvas;const Rect: TRect;
  ThumbWidth, ThumbHeight, Margin: Integer;
  Graphics: array of TGraphic;Caption: array of string ): Integer;

  function ShrinkRect ( const R: TRect;G: TGraphic ): TRect;
  var
    iW, iH: Integer;
    rW, rH: Integer;
  begin
    iW := G.Width;
    iH := G.Height;
    rW := R.Right - R.Left;
    rH := R.Bottom - R.Top;
    if ( iW > rW ) or ( iH > rH ) then // Shrink only
    begin
      if ( rW / iW ) < ( rH / iH ) then
      begin
        iH := MulDiv ( iH, rW, iW );
        iW := rW;
      end
      else
      begin
        iW := MulDiv ( iW, rH, iH );
        iH := rH;
      end;
    end;
    SetRect ( Result, 0, 0, iW, iH );
    OffsetRect ( Result, R.Left + ( rW - iW ) div 2, R.Top + ( rH - iH ) div 2 );
  end;

var
  ThumbRect: TRect;
  ClipRgn: THandle;
  I: Integer;
begin
  Result := 0;
  ClipRgn := CreateRectRgnIndirect ( Rect );
  try
    SelectClipRgn ( Canvas.Handle, ClipRgn );
  finally
    SelectClipRgn ( Canvas.Handle, 0 );
  end;
  SetRect ( ThumbRect, 0, 0, ThumbWidth, ThumbHeight );
  OffsetRect ( ThumbRect, Rect.Left, Rect.Top );
  for I := Low ( Graphics ) to High ( Graphics ) do
  begin
    Canvas.StretchDraw ( ShrinkRect ( ThumbRect, Graphics[I] ), Graphics[I] );
    Canvas.Font.Name := 'Arial';
    Canvas.Font.Size := 8;
    Canvas.TextOut ( ThumbRect.Left + Canvas.Font.Size, ThumbRect.Bottom + 1, Caption[I] );
    OffsetRect ( ThumbRect, ThumbWidth + Margin, 0 );
    Inc ( Result );
    if ThumbRect.Left >= Rect.Right then
    begin
      OffsetRect ( ThumbRect, Rect.Left - ThumbRect.Left, ThumbWidth + Margin );
      if ThumbRect.Top > Rect.Bottom then Break;
    end;
  end;
  SelectClipRgn ( Canvas.Handle, 0 );
end;


I am using ThumbnailDraw in a CreateContactSheet procedure:

Code: Select all

procedure TForm1.CreateContactSheet;
var
  BMP: TBitmap;
  TempBMP: TBitmap;
  I: integer;
  GraphicsArray: array of TGraphic;
  CaptionArray: array of string;
  PageWidth: integer;
  PageHeight: integer;
  MarginLeft: integer;
  MarginRight: integer;
  MarginTop: integer;
  MarginBottom: integer;
  PageClientWidth: integer;
  PageClientHeight: integer;
  BMPWidth: integer;
  BMPHeight: integer;
begin
  BMP := TBitmap.Create;
  try
    PageWidth := PageSetupDialog1.PageWidth;
    PageHeight := PageSetupDialog1.PageHeight;
    MarginLeft := PageSetupDialog1.MarginLeft;
    MarginRight := PageSetupDialog1.MarginRight;
    MarginTop := PageSetupDialog1.MarginTop;
    MarginBottom := PageSetupDialog1.MarginBottom;
    PageClientWidth := PageWidth - ( MarginLeft + MarginRight );
    PageClientHeight := PageHeight - ( MarginTop + MarginBottom );
    BMPWidth := ConvertUnits ( PageClientWidth, Screen.PixelsPerInch, mmHiEnglish, mmPixel );
    BMPHeight := ConvertUnits ( PageClientHeight, Screen.PixelsPerInch, mmHiEnglish, mmPixel );
    BMP.Width := BMPWidth;
    BMP.Height := BMPHeight;
    BMP.PixelFormat := pf24bit;
    TempBMP := TBitmap.Create;
    SetLength ( GraphicsArray, ImageEnMView1.ImageCount );
    SetLength ( CaptionArray, ImageEnMView1.ImageCount );
    for i := 0 to ImageEnMView1.ImageCount - 1 do begin
      TempBMP := ImageEnMView1.GetBitmap ( I );
      GraphicsArray[I] := TempBMP;
      CaptionArray[I] := ImageEnMView1.ImageTopText[I].Caption;
    end;
    fBorder := UpDown7.Position;
    fImageWidth := UpDown1.Position;
    fImageHeight := UpDown6.Position;
    ThumbnailDraw ( BMP.Canvas, BMP.Canvas.ClipRect, fImageWidth, fImageHeight, fBorder, GraphicsArray, CaptionArray );
    frmContactSheet.ImageEnView1.Blank;
    frmContactSheet.ImageEnView1.IEBitmap.Assign ( BMP );
    frmContactSheet.ImageEnView1.Update;
  finally BMP.Free; end;
  ImageEnMView1.ReleaseBitmap ( 0 );
end;


Questions:
1. Is the revised ThumbnailDraw function correct?
2. Can you fix the ThumbnailDraw method to prevent clipping?
3. Is there an easier way to set the bitmap width and height in the CreateContactSheet method?;

BMPWidth := ConvertUnits ( PageClientWidth, Screen.PixelsPerInch, mmHiEnglish, mmPixel );
BMPHeight := ConvertUnits ( PageClientHeight, Screen.PixelsPerInch, mmHiEnglish, mmPixel );

Thanks for the help.

[Kambiz]

I made the function a bit complicated.

1. Instead of the Margin parameter, you have the HorzGap and VertGap parameters.
2. Using the Options parameter you can control the function's behavior.

I think for your case, you should use [tdoNoClip, tdoPartialOK] for the options.

Code: Select all

type
  TThumbnailDrawOptions = set of (tdoNoClip, tdoPartialOK, tdoNoCaption);

function ThumbnailDraw(Canvas: TCanvas; const Rect: TRect;
  ThumbWidth, ThumbHeight, HorzGap, VertGap: Integer;
  Graphics: array of TGraphic; Captions: array of String;
  Options: TThumbnailDrawOptions): Integer;

  function ShrinkRect(const R: TRect; G: TGraphic): TRect;
  var
    iW, iH: Integer;
    rW, rH: Integer;
  begin
    iW := G.Width;
    iH := G.Height;
    rW := R.Right - R.Left;
    rH := R.Bottom - R.Top;
    if (iW > rW) or (iH > rH) then // Shrink only
    begin
      if (rW / iW) < (rH / iH) then
      begin
        iH := MulDiv(iH, rW, iW);
        iW := rW;
      end
      else
      begin
        iW := MulDiv(iW, rH, iH);
        iH := rH;
      end;
    end;
    SetRect(Result, 0, 0, iW, iH);
    OffsetRect(Result, R.Left + (rW - iW) div 2, R.Top + (rH - iH) div 2);
  end;

var
  TextHeight: Integer;
  TextAlign: Integer;
  ThumbRect: TRect;
  ClipRgn: THandle;
  I: Integer;
begin
  Result := 0;
  if not (tdoNoClip in Options) then
  begin
    ClipRgn := CreateRectRgnIndirect(Rect);
    try
      SelectClipRgn(Canvas.Handle, ClipRgn);
    finally
      SelectClipRgn(Canvas.Handle, 0);
    end;
  end;
  TextAlign := SetTextAlign(Canvas.Handle, TA_TOP or TA_CENTER);
  try
    if not (tdoNoCaption in Options) then
      TextHeight := Canvas.TextHeight('H') + 2
    else
      TextHeight := 0;
    SetRect(ThumbRect, 0, 0, ThumbWidth, ThumbHeight);
    OffsetRect(ThumbRect, Rect.Left, Rect.Top);
    if (tdoPartialOK in Options) or
       ((ThumbRect.Right <= Rect.Right) and (ThumbRect.Bottom <= Rect.Bottom)) then
    begin
      for I := Low(Graphics) to High(Graphics) do
      begin
        Canvas.StretchDraw(ShrinkRect(ThumbRect, Graphics[I]), Graphics[I]);
        if TextHeight > 0 then
          Canvas.TextOut((ThumbRect.Left + ThumbRect.Right) div 2, ThumbRect.Bottom + 1, Captions[I]);
        OffsetRect(ThumbRect, ThumbWidth + HorzGap, 0);
        Inc(Result);
        if (ThumbRect.Left >= Rect.Right) or
           (not (tdoPartialOK in Options) and (ThumbRect.Right > Rect.Right))  then
        begin
          OffsetRect(ThumbRect, Rect.Left - ThumbRect.Left, ThumbHeight + VertGap + TextHeight);
          if (ThumbRect.Top >= Rect.Bottom) or
             (not (tdoPartialOK in Options) and (ThumbRect.Bottom > Rect.Bottom))
          then
            Break;
        end;
      end;
    end;
  finally
    SetTextAlign(Canvas.Handle, TextAlign);
    if not (tdoNoClip in Options) then
      SelectClipRgn(Canvas.Handle, 0);
  end;
end;

By the way, in my point of view, the bitmap size cannot be evaluated in an easier way.

Good luck,
Kambiz

[w2m]

The improved ThumbnailDraw code works well, especially to eliminate most clipping (sometimes the captions are still clipped). Unfortunately I am still having trouble setting the size of area that the images are painted to. I seem to get the best results when I pass the ClientRect of the image component that contains the bitmap of thumbnails. When I pass the BMP.ClientRect as Rect then area for area to paint the images is only about 1/5th of the page in the print preview dialog. It's lind of clunky right now that you have to adjust the width and height of the form with the ContactSheet containing the thumbnails, but it works ok.

Boy this printing stuff always drive me nuts. I guess I have got to do some more reading and study.

Thanks for your help!

[Kambiz]

I know what you mean anout printing problems. Seems there's no way to get rid of them.

Maybe instead of screen's resolution you should consider the printer's resolution to calculate then bitmap dimensions.

Please try the following code:

Code: Select all

BMPWidth := ConvertUnits ( PageClientWidth, GetDeviceCaps ( Printer.Handle, LOGPIXELSX ), mmHiEnglish, mmPixel );
BMPHeight := ConvertUnits ( PageClientHeight, GetDeviceCaps ( Printer.Handle, LOGPIXELSY ), mmHiEnglish, mmPixel );

[w2m]

I tried using both:

Code: Select all

// Printer
PageWidth := PageSetupDialog1.PageWidth;
PageHeight := PageSetupDialog1.PageHeight;
MarginLeft := PageSetupDialog1.MarginLeft;
MarginRight := PageSetupDialog1.MarginRight;
MarginTop := PageSetupDialog1.MarginTop;
MarginBottom := PageSetupDialog1.MarginBottom;
PageClientWidth := PageWidth - ( MarginLeft + MarginRight );
PageClientHeight := PageHeight - ( MarginTop + MarginBottom );
BMPWidth := ConvertUnits ( PageClientWidth, GetDeviceCaps ( Printer.Handle, LOGPIXELSX ), mmHiEnglish, mmPixel );
BMPHeight := ConvertUnits ( PageClientHeight, GetDeviceCaps ( Printer.Handle, LOGPIXELSY ), mmHiEnglish, mmPixel );

with Rect do begin
  Left := 0;
  Right := BMPWidth;
  Top := 0;
  Bottom := BMPHeight;
end;

BMP.PixelFormat := pf24bit;
SetLength ( GraphicsArray, ImageEnMView1.ImageCount );
SetLength ( CaptionArray, ImageEnMView1.ImageCount );
fVertGap := fProperties.UpDown9.Position;
fHorzGap := fProperties.UpDown13.Position;
fImageWidth := fProperties.UpDown10.Position;
fImageHeight := fProperties.UpDown11.Position;

case fProperties.ComboBox1.ItemIndex of
  0: fThumbOptions := [tdoNoClip]; // No Clipping
  1: fThumbOptions := [tdoNoClip, tdoNoCaption]; // No Clipping & No Caption
  2: fThumbOptions := [tdoPartialOK]; // Partial Clip OK
  3: fThumbOptions := [tdoNoCaption]; // No Caption
  4: fThumbOptions := [tdoNoClip, tdoPartialOK]; // No Clip & Partial Clip OK
  5: fThumbOptions := [tdoNoClip, tdoPartialOK, tdoNoCaption] // No Clip, Partial Clip OK, No Caption
end; // case

for i := 0 to ImageEnMView1.ImageCount - 1 do begin
  TempBMP := ImageEnMView1.GetBitmap ( I );
   GraphicsArray[I] := TempBMP;
   CaptionArray[I] := ImageEnMView1.ImageBottomText[I].Caption;
end;

fContactSheet.ContactSheet1.Blank;

ThumbnailDraw ( BMP.Canvas, Rect, fImageWidth, fImageHeight, fHorzGap, fVertGap, GraphicsArray, CaptionArray, fThumbOptions );

fContactSheet.ContactSheet1.IEBitmap.Assign ( BMP );
fContactSheet.ContactSheet1.Update;
for i := 0 to ImageEnMView1.ImageCount - 1 do
  ImageEnMView1.ReleaseBitmap ( i );

//Printer Result
BMPWidth: 1950
BMPHeight: 2700


Printer Result
BMPWidth: 1950
BMPHeight: 2700

Code: Select all

// Screen
PageWidth := PageSetupDialog1.PageWidth;
PageHeight := PageSetupDialog1.PageHeight;
MarginLeft := PageSetupDialog1.MarginLeft;
MarginRight := PageSetupDialog1.MarginRight;
MarginTop := PageSetupDialog1.MarginTop;
MarginBottom := PageSetupDialog1.MarginBottom;
PageClientWidth := PageWidth - ( MarginLeft + MarginRight );
PageClientHeight := PageHeight - ( MarginTop + MarginBottom );
BMP.Width := BMPWidth;
BMP.Height := BMPHeight;
with Rect do begin
  Left := 0;
  Right := BMPWidth;
  Top := 0;
  Bottom := BMPHeight;
end;
BMPWidth := ConvertUnits ( PageClientWidth, Screen.PixelsPerInch, mmHiEnglish, mmPixel );
BMPHeight := ConvertUnits ( PageClientHeight, Screen.PixelsPerInch, mmHiEnglish, mmPixel );

with Rect do begin
  Left := 0;
  Right := BMPWidth;
  Top := 0;
  Bottom := BMPHeight;
end;

BMP.PixelFormat := pf24bit;
SetLength ( GraphicsArray, ImageEnMView1.ImageCount );
SetLength ( CaptionArray, ImageEnMView1.ImageCount );
fVertGap := fProperties.UpDown9.Position;
fHorzGap := fProperties.UpDown13.Position;
fImageWidth := fProperties.UpDown10.Position;
fImageHeight := fProperties.UpDown11.Position;

case fProperties.ComboBox1.ItemIndex of
  0: fThumbOptions := [tdoNoClip]; // No Clipping
  1: fThumbOptions := [tdoNoClip, tdoNoCaption]; // No Clipping & No Caption
  2: fThumbOptions := [tdoPartialOK]; // Partial Clip OK
  3: fThumbOptions := [tdoNoCaption]; // No Caption
  4: fThumbOptions := [tdoNoClip, tdoPartialOK]; // No Clip & Partial Clip OK
  5: fThumbOptions := [tdoNoClip, tdoPartialOK, tdoNoCaption] // No Clip, Partial Clip OK, No Caption
end; // case

for i := 0 to ImageEnMView1.ImageCount - 1 do begin
  TempBMP := ImageEnMView1.GetBitmap ( I );
   GraphicsArray[I] := TempBMP;
   CaptionArray[I] := ImageEnMView1.ImageBottomText[I].Caption;
end;

fContactSheet.ContactSheet1.Blank;

ThumbnailDraw ( BMP.Canvas, Rect, fImageWidth, fImageHeight, fHorzGap, fVertGap, GraphicsArray, CaptionArray, fThumbOptions );

fContactSheet.ContactSheet1.IEBitmap.Assign ( BMP );
fContactSheet.ContactSheet1.Update;
for i := 0 to ImageEnMView1.ImageCount - 1 do
  ImageEnMView1.ReleaseBitmap ( i );

//Screen Result
BMPWidth: 624
BMPHeight: 864



Screen Result
BMPWidth: 624
BMPHeight: 864

the Screen:
BMPWidth := ConvertUnits ( PageClientWidth, Screen.PixelsPerInch, mmHiEnglish, mmPixel );
BMPHeight := ConvertUnits ( PageClientHeight, Screen.PixelsPerInch, mmHiEnglish, mmPixel );
seems to give the best results.

The printer is a HP 2000 deskjet with letter lize page (8.5x11 inch) page in portrait mode.

When I pass the BMP to the ImageEN Print Preview Dialog the results match the printers page size the best when using the Screen, but when the image prints on my printer the top inch and a half gets cut off. I am beginning to wonder if the ImageEN Print Preview Dialog has a bug.

Do you own the ImageEN Library? If so I'd be glad to send you the source. Only VCL components and ImageEn are used in the source. The source is an icon editing application.

Thanks

[Kambiz]

I don't have the component.