Go Premium for a chance to win a PS4. Enter to Win

x
  • Status: Solved
  • Priority: Medium
  • Security: Public
  • Views: 711
  • Last Modified:

How to resize a screenshot with proportionality

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
OneDeath
Asked:
OneDeath
  • 2
  • 2
2 Solutions
 
OneDeathAuthor Commented:
i mean resize the image WITHOUT QUALITY LOSS, there are some GOOD code around?
thanks
0
 
dougaugCommented:
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
 
thiagoblimeiraCommented:
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
 
dougaugCommented:
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
 
OneDeathAuthor Commented:
just what i need thanks both ^^
0

Featured Post

Free Tool: IP Lookup

Get more info about an IP address or domain name, such as organization, abuse contacts and geolocation.

One of a set of tools we are providing to everyone as a way of saying thank you for being a part of the community.

  • 2
  • 2
Tackle projects and never again get stuck behind a technical roadblock.
Join Now