Solved

How to resize a screenshot with proportionality

Posted on 2009-07-11
5
695 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

NAS Cloud Backup Strategies

This article explains backup scenarios when using network storage. We review the so-called “3-2-1 strategy” and summarize the methods you can use to send NAS data to the cloud

Question has a verified solution.

If you are experiencing a similar issue, please ask a related question

Suggested Solutions

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…
In my programming career I have only very rarely run into situations where operator overloading would be of any use in my work.  Normally those situations involved math with either overly large numbers (hundreds of thousands of digits or accuracy re…
Along with being a a promotional video for my three-day Annielytics Dashboard Seminor, this Micro Tutorial is an intro to Google Analytics API data.
Email security requires an ever evolving service that stays up to date with counter-evolving threats. The Email Laundry perform Research and Development to ensure their email security service evolves faster than cyber criminals. We apply our Threat…

777 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