unit ScreenShot;

interface

uses
  Windows, SysUtils, Classes, Controls, Graphics, Forms, Messages, ScrView,gdiputil,gdipobj,gdipapi;

type
  TWaterMarkPos=(wpTopLeft, wpTopRight, wpBottomLeft, wpBottomRight);

type
  TWaterMark=class(TPersistent)
  private
    FEnabled: Boolean;
    FText: string;
    FCircuitColor: TColor;
    FFont: TFont;
    FCircuitWidth: Integer;
    FPosition: TWaterMarkPos;
    procedure SetCircuitColor(const Value: TColor);
    procedure SetEnabled(const Value: Boolean);
    procedure SetFont(const Value: TFont);
    procedure SetText(const Value: string);
    procedure SetCircuitWidth(const Value: Integer);
    procedure SetPosition(const Value: TWaterMarkPos);
  public
  published
  property Enabled:Boolean read FEnabled write SetEnabled default False;
  property Text:string read FText write SetText;
  property Font:TFont read FFont write SetFont;
  property CircuitColor:TColor read FCircuitColor write SetCircuitColor default clNone;
  property CircuitWidth:Integer read FCircuitWidth write SetCircuitWidth default 2;
  property Position:TWaterMarkPos read FPosition write SetPosition default wpBottomRight;
  constructor Create;
  destructor Destroy; override;
  end;

  TScreenShot = class(TComponent)
  private
    FFrm:TForm;
    FOldWndProc:TWNDMethod;
    FID:WORD;
    FBitmap: TBitMap;
    FClientOnly: Boolean;
    FWinH: HWnd;
    FShowAfterMake: Boolean;
    FTimeStamp: TWaterMark;
    FWaterMark: TWaterMark;
    procedure SetBitmap(const Value: TBitMap);
    procedure SetClientOnly(const Value: Boolean);
    procedure SetShowAfterMake(const Value: Boolean);
    procedure SetTimeStamp(const Value: TWaterMark);
    procedure SetWaterMark(const Value: TWaterMark);
    { Private declarations }
  protected
    procedure GetWindowBmp;
    procedure GetClientBmp;
    procedure NewWndProc(var MSG:TMessage);
    procedure DrawWaterMark;
  public
    constructor Create(AOwner:TComponent); override;
    destructor Destroy; override;
    procedure Make;
    property Bitmap:TBitMap read FBitmap write SetBitmap;
  published
    property WaterMark:TWaterMark read FWaterMark write SetWaterMark;
    property TimeStamp:TWaterMark read FTimeStamp write SetTimeStamp;
    property ClientOnly:Boolean read FClientOnly write SetClientOnly default True;
    property ShowAfterMake:Boolean read FShowAfterMake write SetShowAfterMake default True;
  end;

procedure Register;

implementation

{$R *.res}

var
  ScrViewFrm:TScrViewFrm=nil;

function ScrView:TScrViewFrm;
begin
  if Assigned(ScrViewFrm) then
  Result:=ScrViewFrm
  else
  begin
    ScrViewFrm:=TScrViewFrm.Create(Application);
    Result:=ScrViewFrm;
  end;
end;

procedure Register;
begin
  RegisterComponents('ScrShot', [TScreenShot]);
end;

{ TScreenShot }

constructor TScreenShot.Create(AOwner: TComponent);
begin
  inherited Create(AOwner);
  FBitMap:=TBitMap.Create;
  FClientOnly:=True;
  FShowAfterMake:=True;
  FWaterMark:=TWaterMark.Create;
  with FWaterMark do
  begin
    with Font do
    begin
      Name:='Tahoma';
      Size:=19;
      Style:=[fsBold];
      Color:=clWhite;
    end;
    CircuitColor:=RGB(253,38,9);
  end;
  FTimeStamp:=TWaterMark.Create;
  FID:=0;
  FWinH:=0;
  if (AOwner is TForm) then
  begin
    FFrm:=TForm(AOwner);
    FWinH:=TForm(AOwner).Handle;
    if not (csDesigning in ComponentState) then
    begin
      FOldWndProc:=FFrm.WindowProc;
      FFrm.WindowProc:=NewWndProc;
      //FID := GlobalAddAtom('~Hotkey');
      //RegisterHotKey(FFrm.Handle, 0, MOD_CONTROL, VK_SNAPSHOT);
    end;
  end;
end;

destructor TScreenShot.Destroy;
begin
  if Assigned(OWner) then
  begin
    if not (csDesigning in ComponentState) then
    begin
      UnregisterHotKey((Owner as TWinControl).Handle, FID);
      GlobalDeleteAtom(FID);
      (Owner as TWinControl).WindowProc:=FOldWndProc;
    end;
  end;
  FBitMap.Free;
  FTimeStamp.Free;
  FWaterMark.Free;
  inherited;
end;

procedure TScreenShot.DrawWaterMark;
var
 DPen: TGPPen;
 Drawer: TGPGraphics;
 DBrush: TGPSolidBrush;
 DFntFam: TGPFontFamily;
 DPath: TGPGraphicsPath;
 IC,BC:Integer;
 ICL, BCL:TGPColor;
 W:WideString;
 rt:TGPRectF;
 GP:TGPPoint;
begin
  W:=FWaterMark.Text;
  IC:=ColortoRGB(FWaterMark.Font.Color);
  BC:=ColorToRGB(FWaterMark.CircuitColor);
  ICl:=MakeColor(GetRValue(IC), GetGValue(IC), GetBValue(IC));
  BCL:=MakeColor(GetRValue(BC), GetGValue(BC), GetBValue(BC));
  Drawer:=TGPGraphics.Create(FBitMap.Canvas.Handle);
  Drawer.SetCompositingQuality(CompositingQualityHighQuality);
  Drawer.SetSmoothingMode(SmoothingModeAntiAlias);
  Drawer.SetTextRenderingHint(TextRenderingHintAntiAlias);
  DPath:=TGPGraphicsPath.Create;
  DPen:=TGPPen.Create(BCL, FWaterMark.FCircuitWidth);
  DBrush:=TGPSolidBrush.Create(ICL);
  DFntFam:=TGPFontFamily.Create(FWaterMark.Font.Name);

  RT.X:=0;
  RT.Y:=0;
  RT.Width:=FBitMap.Width;
  RT.Height:=FBitMap.Height;

  GP.X:=0;
  GP.Y:=0;
  messagebox(0,'','',0);
  DPath.AddString(W, Length(W), DFntFam, FontStyleBold, FWaterMark.Font.Size, GP, TGPStringFormat.Create());
  DPath.GetBounds(RT, nil, DPen);
  DPath.Reset;
  case FWaterMark.Position of
    wpBottomRight:
    begin
      RT.Y:=FBitMap.Height-RT.Height;
      RT.X:=FBitMap.Width-RT.Width;
    end;
    wpBottomLeft:
    begin
      RT.Y:=FBitMap.Height-RT.Height;
      RT.X:=0;
    end;
    wpTopLeft:
    begin
      RT.Y:=0;
      RT.X:=0;
    end;
    wpTopRight:
    begin
      RT.Y:=0;
      RT.X:=FBitMap.Width-RT.Width;
    end;
  end;
  DPath.AddString(W, Length(W), DFntFam, FontStyleBold, FWaterMark.Font.Size, RT, TGPStringFormat.GenericDefault);
  Drawer.DrawPath(DPen, DPath);
  Drawer.FillPath(DBrush, DPath);
  DFntFam.Free;
  DBrush.Free;
  DPen.Free;
  DPath.Free;
  Drawer.Free;
end;

procedure TScreenShot.GetClientBmp;
var
  DC:HDC;
  WW, WH:Integer;
  R:TRect;
begin
  DC:=GetDC(FWinH);
  Windows.GetClientRect(FWinH, R);
  WW:=R.Right-R.Left;
  WH:=R.Bottom-R.Top;
  FBitMap.Width:=WW;
  FBitMap.Height:=WH;
  BitBlt(FBitMap.Canvas.Handle,0,0,WW,WH,DC,0,0,SRCCOPY);
end;

procedure TScreenShot.GetWindowBmp;
var
  DC:HDC;
  WW, WH:Integer;
  R:TRect;
begin
  DC:=GetWindowDC(FWinH);
  Windows.GetWindowRect(FWinH, R);
  WW:=R.Right-R.Left;
  WH:=R.Bottom-R.Top;
  FBitMap.Width:=WW;
  FBitMap.Height:=WH;
  BitBlt(FBitMap.Canvas.Handle,0,0,WW,WH,DC,0,0,SRCCOPY);
end;

procedure TScreenShot.Make;
begin
  if IsWindow(FWinH) then
  begin
    if FClientOnly then
    GetClientBmp
    else
    GetWindowBmp;
    DrawWaterMark;
    if FShowAfterMake then
    begin
      with ScrView do
      begin
        ImgView.Picture.Assign(FBitMap);
        ScrlBox.VertScrollBar.Range:=ImgView.Height;
        ScrlBox.HorzScrollBar.Range:=ImgView.Width;
        if not Visible then
        ShowModal;
      end;
    end;
  end
  else
  MessageBox(0, 'Cannot make a screenshot','Something is bad',48);
end;

procedure TScreenShot.NewWndProc(var MSG: TMessage);
begin
  if MSG.Msg=WM_HOTKEY then
  begin
    Make;
  end;
  FOldWndProc(MSG);
end;

procedure TScreenShot.SetBitmap(const Value: TBitMap);
begin
  FBitmap := Value;
end;

procedure TScreenShot.SetClientOnly(const Value: Boolean);
begin
  FClientOnly := Value;
end;

procedure TScreenShot.SetShowAfterMake(const Value: Boolean);
begin
  FShowAfterMake := Value;
end;

procedure TScreenShot.SetTimeStamp(const Value: TWaterMark);
begin
  FTimeStamp := Value;
end;

procedure TScreenShot.SetWaterMark(const Value: TWaterMark);
begin
  FWaterMark := Value;
end;

{ TWaterMark }

constructor TWaterMark.Create;
begin
  FEnabled:=False;
  FCircuitWidth:=2;
  FFont:=TFont.Create;
  with FFont do
  begin
    Style:=[];
    Color:=clRed;
    Name:='Arial';
  end;
  FPosition:=wpBottomRight;
end;

destructor TWaterMark.Destroy;
begin
  inherited;
end;

procedure TWaterMark.SetCircuitColor(const Value: TColor);
begin
  FCircuitColor := Value;
end;

procedure TWaterMark.SetCircuitWidth(const Value: Integer);
begin
  FCircuitWidth := Value;
end;

procedure TWaterMark.SetEnabled(const Value: Boolean);
begin
  FEnabled := Value;
end;

procedure TWaterMark.SetFont(const Value: TFont);
begin
  FFont.Assign(Value);
end;

procedure TWaterMark.SetPosition(const Value: TWaterMarkPos);
begin
  FPosition := Value;
end;

procedure TWaterMark.SetText(const Value: string);
begin
  FText := Value;
end;

end.



/////Код формы


unit ScrView;

interface

uses
  Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,
  Dialogs, ExtCtrls, PngImage, Menus, ExtDlgs;

type
  TScrViewFrm = class(TForm)
    ScrlBox: TScrollBox;
    ImgView: TImage;
    ImgPop: TPopupMenu;
    Savetofile1: TMenuItem;
    SaveDlg: TSaveDialog;
    procedure FormMouseWheel(Sender: TObject; Shift: TShiftState;
      WheelDelta: Integer; MousePos: TPoint; var Handled: Boolean);
    procedure Savetofile1Click(Sender: TObject);
  private
    { Private declarations }
  public
    { Public declarations }
  end;

implementation

{$R *.dfm}

procedure TScrViewFrm.FormMouseWheel(Sender: TObject; Shift: TShiftState;
  WheelDelta: Integer; MousePos: TPoint; var Handled: Boolean);
var
  I: Integer;
begin
  Handled := PtInRect(ScrlBox.ClientRect, ScrlBox.ScreenToClient(MousePos));
  if Handled then
    for I := 1 to Mouse.WheelScrollLines do
    try
      if WheelDelta > 0 then
        ScrlBox.Perform(WM_VSCROLL, SB_LINEUP, 0)
      else
        ScrlBox.Perform(WM_VSCROLL, SB_LINEDOWN, 0);
    finally
      ScrlBox.Perform(WM_VSCROLL, SB_ENDSCROLL, 0);
    end;
end;

procedure TScrViewFrm.Savetofile1Click(Sender: TObject);
var
  Png:TPngObject;
begin
  if SaveDlg.Execute then
  begin
    Png:=TPngObject.Create;
    try
      Png.Assign(ImgView.Picture.Graphic);
      Png.SaveToFile(SaveDlg.FileName);
    finally
      Png.Free;
    end;
  end;
end;

end.