Solved

How to resize a screenshot with proportionality

Posted on 2009-07-11
5
698 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
[X]
Welcome to Experts Exchange

Add your voice to the tech community where 5M+ people just like you are talking about what matters.

  • Help others & share knowledge
  • Earn cash & points
  • Learn & ask questions
  • 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

Independent Software Vendors: We Want Your Opinion

We value your feedback.

Take our survey and automatically be enter to win anyone of the following:
Yeti Cooler, Amazon eGift Card, and Movie eGift Card!

Question has a verified solution.

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

The uses clause is one of those things that just tends to grow and grow. Most of the time this is in the main form, as it's from this form that all others are called. If you have a big application (including many forms), the uses clause in the in…
Hello everybody This Article will show you how to validate number with TEdit control, What's the TEdit control? TEdit is a standard Windows edit control on a form, it allows to user to write, read and copy/paste single line of text. Usua…
Finding and deleting duplicate (picture) files can be a time consuming task. My wife and I, our three kids and their families all share one dilemma: Managing our pictures. Between desktops, laptops, phones, tablets, and cameras; over the last decade…

751 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