Solved

How to resize a screenshot with proportionality

Posted on 2009-07-11
5
688 Views
Last Modified: 2012-06-27
hi want the screen shot proportionality, i mean the resolution of the screen (Width and Height div 2)
and save it to a disk, this is the code im using:
program ScreenShot;
 

uses Windows, Classes, Graphics, Jpeg;
 

procedure DrawCursor(Bmp: TBitmap);

var

  r: TRect;

  CI: TCursorInfo;

  Icon: TIcon;

  II: TIconInfo;

begin

  r := Bmp.Canvas.ClipRect;

  Icon := TIcon.Create;

  try

    CI.cbSize := SizeOf(CI);

    if GetCursorInfo(CI) then

      if CI.Flags = CURSOR_SHOWING then

      begin

        Icon.Handle := CopyIcon(CI.hCursor);

        if GetIconInfo(Icon.Handle, II) then

        begin

          Bmp.Canvas.Draw(

            ci.ptScreenPos.x - Integer(II.xHotspot) - r.Left,

            ci.ptScreenPos.y - Integer(II.yHotspot) - r.Top,

            Icon

            );

        end;

      end;

  finally

    Icon.Free;

  end;

end;
 

procedure SaveScreenToFile(FileName: String);

var

  Bmp: TBitmap;

  Jpg: TJpegImage;

begin

  Bmp := TBitmap.Create;

  Jpg := TJpegImage.Create;

  try

    Bmp.Width := GetSystemMetrics(SM_CXSCREEN);

    Bmp.Height := GetSystemMetrics(SM_CYSCREEN);

    BitBlt(Bmp.Canvas.Handle, 0, 0, Bmp.Width, Bmp.Height, GetDc(0), 0, 0, SRCCOPY);

    DrawCursor(Bmp);

    Jpg.Assign(Bmp);

    Jpg.CompressionQuality := 60;

    Jpg.Compress;

    Jpg.SaveToFile(FileName);

  finally

    Bmp.free;

    Jpg.free;

  end;

end;
 

begin

 SaveScreenToFile('SHOT.JPG');

end.

Open in new window

0
Comment
Question by:OneDeath
  • 2
  • 2
5 Comments
 

Author Comment

by:OneDeath
ID: 24831885
i mean resize the image WITHOUT QUALITY LOSS, there are some GOOD code around?
thanks
0
 
LVL 11

Assisted Solution

by:dougaug
dougaug earned 62 total points
ID: 24831995
Have you already try the Windows StretchBlt API function?

See the code below (I've made a little change in your code, in the SaveScreenToFile procedure).

Regards


procedure SaveScreenToFile(FileName: String);

var

  Bmp: TBitmap;

  Jpg: TJpegImage;

begin

  Bmp := TBitmap.Create;

  Jpg := TJpegImage.Create;

  try

    Bmp.Width := GetSystemMetrics(SM_CXSCREEN) div 2;

    Bmp.Height := GetSystemMetrics(SM_CYSCREEN) div 2;

    StretchBlt(Bmp.Canvas.Handle, 0, 0, Bmp.Width, Bmp.Height, GetDc(0), 0, 0,

               GetSystemMetrics(SM_CXSCREEN), GetSystemMetrics(SM_CYSCREEN),

               SRCCOPY);

    DrawCursor(Bmp);

    Jpg.Assign(Bmp);

    Jpg.CompressionQuality := 100;

    Jpg.Compress;

    Jpg.SaveToFile(FileName);

  finally

    Bmp.free;

    Jpg.free;

  end;

end;

Open in new window

0
 
LVL 8

Accepted Solution

by:
thiagoblimeira earned 63 total points
ID: 24832003
Hello

Here it is:
procedure DrawCursor(Bmp: TBitmap);

var

  r: TRect;

  CI: TCursorInfo;

  Icon: TIcon;

  II: TIconInfo;

begin

  r := Bmp.Canvas.ClipRect;

  Icon := TIcon.Create;

  try

    CI.cbSize := SizeOf(CI);

    if GetCursorInfo(CI) then

      if CI.Flags = CURSOR_SHOWING then

      begin

        Icon.Handle := CopyIcon(CI.hCursor);

        if GetIconInfo(Icon.Handle, II) then

        begin

          Bmp.Canvas.Draw(

            ci.ptScreenPos.x - Integer(II.xHotspot) - r.Left,

            ci.ptScreenPos.y - Integer(II.yHotspot) - r.Top,

            Icon

            );

        end;

      end;

  finally

    Icon.Free;

  end;

end;
 
 

procedure SaveScreenToFile(FileName: String);

var

  Bmp: TBitmap;

  Jpg: TJpegImage;

  MaxWidth, MaxHeight : integer;

  thumbRect : TRect;

begin

  Bmp := TBitmap.Create;

  Jpg := TJpegImage.Create;

  try

    Bmp.Width := GetSystemMetrics(SM_CXSCREEN);

    Bmp.Height := GetSystemMetrics(SM_CYSCREEN);

    BitBlt(Bmp.Canvas.Handle, 0, 0, Bmp.Width, Bmp.Height, GetDc(0), 0, 0, SRCCOPY);

    DrawCursor(Bmp);
 

    MaxWidth := Bmp.Width div 2;

    MaxHeight := Bmp.Height div 2;
 

    thumbRect.Left := 0;

    thumbRect.Top := 0;
 

    //proportional resize

    if Bmp.Width > MaxHeight then

      begin

      thumbRect.Right := MaxWidth;

      thumbRect.Bottom := (MaxWidth * Bmp.Height) div Bmp.Width;

      end

    else

      begin

      thumbRect.Bottom := MaxHeight;

      thumbRect.Right := (MaxHeight * Bmp.Width) div Bmp.Height;

      end;
 

    Bmp.Canvas.StretchDraw(thumbRect, Bmp) ;
 

    //resize image

    Bmp.Width := thumbRect.Right;

    Bmp.Height := thumbRect.Bottom;
 
 

    Jpg.Assign(Bmp);

    Jpg.CompressionQuality := 60;

    Jpg.Compress;

    Jpg.SaveToFile(FileName);

  finally

    Bmp.free;

    Jpg.free;

  end;

end;
 

begin

 SaveScreenToFile('SHOT.JPG');

end.

Open in new window

0
 
LVL 11

Expert Comment

by:dougaug
ID: 24832065
Hi,

I've improve my code and now you can choose any screen percent (smaller or bigger than the screen resolution). See the code below:



procedure SaveScreenToFile(FileName: String; ScreenPercent: Word);

var

  Bmp, Bmp2: TBitmap;

  Jpg: TJpegImage;

begin

  Bmp := TBitmap.Create;

  Bmp2 := TBitmap.Create;

  Jpg := TJpegImage.Create;

  try

    Bmp.Width := GetSystemMetrics(SM_CXSCREEN);

    Bmp.Height := GetSystemMetrics(SM_CYSCREEN);

    BitBlt(Bmp.Canvas.Handle, 0, 0, Bmp.Width, Bmp.Height, GetDc(0), 0, 0, SRCCOPY);

    DrawCursor(Bmp);
 

    if ScreenPercent > 0 then

    begin

      Bmp2.Width := Bmp.Width * ScreenPercent div 100;

      Bmp2.Height := Bmp.Height * ScreenPercent div 100;

    end;

    StretchBlt(Bmp2.Canvas.Handle, 0, 0, Bmp2.Width,bmp2.Height, bmp.Canvas.Handle,

               0, 0, bmp.Width, Bmp.Height, SRCCOPY);
 

    Jpg.Assign(Bmp2);

    Jpg.CompressionQuality := 100;

    Jpg.Compress;

    Jpg.SaveToFile(FileName);

  finally

    Bmp.free;

    Bmp2.free;

    Jpg.free;

  end;

end;
 

begin

 SaveScreenToFile('SHOT.JPG', 50);

end.

Open in new window

0
 

Author Closing Comment

by:OneDeath
ID: 31602462
just what i need thanks both ^^
0

Featured Post

How to run any project with ease

Manage projects of all sizes how you want. Great for personal to-do lists, project milestones, team priorities and launch plans.
- Combine task lists, docs, spreadsheets, and chat in one
- View and edit from mobile/offline
- Cut down on emails

Join & Write a Comment

This article explains how to create forms/units independent of other forms/units object names in a delphi project. Have you ever created a form for user input in a Delphi project and then had the need to have that same form in a other Delphi proj…
Introduction Raise your hands if you were as upset with FireMonkey as I was when I discovered that there was no TListview.  I use TListView in almost all of my applications I've written, and I was not going to compromise by resorting to TStringGrid…
This demo shows you how to set up the containerized NetScaler CPX with NetScaler Management and Analytics System in a non-routable Mesos/Marathon environment for use with Micro-Services applications.
When you create an app prototype with Adobe XD, you can insert system screens -- sharing or Control Center, for example -- with just a few clicks. This video shows you how. You can take the full course on Experts Exchange at http://bit.ly/XDcourse.

747 members asked questions and received personalized solutions in the past 7 days.

Join the community of 500,000 technology professionals and ask your questions.

Join & Ask a Question

Need Help in Real-Time?

Connect with top rated Experts

11 Experts available now in Live!

Get 1:1 Help Now