滚屏截图

unit Unit1;

interface

uses
  Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,
  Dialogs, StdCtrls, ComCtrls;

const
  TAGCOLOR : TColor = $00FEFEFE;

type
  TForm1 = class(TForm)
    Memo1: TMemo;
    RichEdit1: TRichEdit;
    Button1: TButton;
    RadioButton1: TRadioButton;
    RadioButton2: TRadioButton;
    procedure Button1Click(Sender: TObject);
    procedure FormCreate(Sender: TObject);
  private
    function RectHeight(ARect : TRect) : Integer;
    function IsScrollEnd(AHandle : THandle) : Boolean;
    function NextLineHeight(AHandle : THandle;ARect : TRect) : Integer;
  public
  end;

var
  Form1: TForm1;

implementation

{$R *.dfm}

{ TForm1 }

function TForm1.RectHeight(ARect: TRect): Integer;
begin
  Result := ARect.Bottom - ARect.Top;
end;

procedure TForm1.Button1Click(Sender: TObject);
var
  ABuf : TBitmap;
  ARect : TRect;
  AHandle : THandle;
  ACanvas : TCanvas;
  ALineHeight : Integer;
begin
  if RadioButton1.Checked
     then AHandle := Memo1.Handle
     else AHandle := RichEdit1.Handle;

  Windows.GetClientRect(AHandle,ARect);
  SendMessage(AHandle,WM_VSCROLL,SB_TOP,0);

  ABuf := TBitmap.Create;
  ABuf.Width := ARect.Right - ARect.Left;
  ABuf.Height := RectHeight(ARect) div 2;

  ACanvas := TCanvas.Create;
  ACanvas.Handle := GetDC(AHandle);
  ACanvas.Pen.Color := TAGCOLOR;

  { First Copy }
  BitBlt(ABuf.Canvas.Handle,0,0,ABuf.Width,RectHeight(ARect) div 2,
    ACanvas.Handle,0,0,SRCCOPY);
  ACanvas.MoveTo(0,RectHeight(ARect) div 2);
  ACanvas.LineTo(3,RectHeight(ARect) div 2);
  SendMessage(AHandle,WM_VSCROLL,SB_LINEDOWN,0);

  while not IsScrollEnd(AHandle) do
  begin
    ALineHeight := NextLineHeight(AHandle,ARect) + 1;
    ABuf.Height := ABuf.Height + ALineHeight;
    BitBlt(ABuf.Canvas.Handle,0,ABuf.Height - ALineHeight,ABuf.Width,ALineHeight,
      ACanvas.Handle,0,RectHeight(ARect) div 2- ALineHeight,SRCCOPY);

    ACanvas.MoveTo(0,RectHeight(ARect) div 2);
    ACanvas.LineTo(3,RectHeight(ARect) div 2);
    SendMessage(AHandle,WM_VSCROLL,SB_LINEDOWN,0);
  end;

  { Last Copy }
  ALineHeight := RectHeight(ARect) - RectHeight(ARect) div 2;
  ABuf.Height := ABuf.Height + ALineHeight;
  BitBlt(ABuf.Canvas.Handle,0,ABuf.Height - ALineHeight,ABuf.Width,ALineHeight,
      ACanvas.Handle,0,RectHeight(ARect) div 2 + 1,SRCCOPY);

  ABuf.SaveToFile('C:\ABC.BMP');
  ABuf.Free;
  ReleaseDC(AHandle,ACanvas.Handle);
  ACanvas.Free;

  MessageBox(Handle,'Capture File is SaveTo C:\ABC.BMP.','Info',MB_ICONINFORMATION);
end;

function TForm1.IsScrollEnd(AHandle : THandle): Boolean;
var
  SI : tagSCROLLINFO;
begin
  SI.cbSize := Sizeof(SI);
  SI.fMask := SIF_ALL;
  GetScrollInfo(AHandle,SB_VERT,SI);
  Result := SI.nPos = (SI.nMax - SI.nPage);
end;

function TForm1.NextLineHeight(AHandle: THandle; ARect: TRect): Integer;
var
  i : Integer;
  ABuf : TBitmap;
begin
  ABuf := TBitmap.Create;
  ABuf.Width := 3;
  ABuf.Height := RectHeight(ARect) div 2;

  Result := 0;
  BitBlt(ABuf.Canvas.Handle,0,0,3,RectHeight(ARect),GetDC(AHandle),0,0,SRCCOPY);
  for i := ABuf.Height -1 downto 0 do
  begin
    if ABuf.Canvas.Pixels[2,i] = TAGCOLOR then Break;
    Result := Result + 1;
  end;
  ABuf.Free;
end;

procedure TForm1.FormCreate(Sender: TObject);
begin
  RichEdit1.Lines.LoadFromFile(ExtractFilePath(ParamStr(0))+'unit1.rtf');
end;

end.
改为水平滚动截图:
unit Unit1;

interface

uses
  Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,
  Dialogs, StdCtrls, ComCtrls;

const
  TAGCOLOR : TColor = $00FEFEFE;

type
  TForm1 = class(TForm)
    Memo1: TMemo;
    RichEdit1: TRichEdit;
    Button1: TButton;
    RadioButton1: TRadioButton;
    RadioButton2: TRadioButton;
   
    SaveDialog1: TSaveDialog;
    procedure Button1Click(Sender: TObject);
    procedure FormCreate(Sender: TObject);
  private
    function RectWith(ARect: TRect): Integer;
    function IsScrollEnd(AHandle : THandle) : Boolean;
    function NextLineWith(AHandle: THandle; ARect: TRect): Integer;
  public
  end;

var
  Form1: TForm1;

implementation

{$R *.dfm}

{ TForm1 }

function TForm1.RectWith(ARect: TRect): Integer;
begin
  Result := ARect.Right - ARect.Left;
end;

procedure TForm1.Button1Click(Sender: TObject);
var
  ABuf : TBitmap;
  ARect : TRect;
  AHandle : THandle;
  ACanvas : TCanvas;
  ALineWith : Integer;
begin
  if RadioButton1.Checked
     then AHandle := Memo1.Handle
     else AHandle := RichEdit1.Handle;

  Windows.GetClientRect(AHandle,ARect);


  ABuf := TBitmap.Create;
  ABuf.Width :=    RectWith(ARect) div 2;
  ABuf.Height := ARect.Bottom - ARect.Top;

  ACanvas := TCanvas.Create;
  ACanvas.Handle := GetDC(AHandle);
  ACanvas.Pen.Color := TAGCOLOR;

  { First Copy }
  BitBlt(ABuf.Canvas.Handle,0,0,RectWith(ARect) div 2,ABuf.Height ,
    ACanvas.Handle,0,0,SRCCOPY);
  ACanvas.MoveTo(RectWith(ARect) div 2, 0);
  ACanvas.LineTo(RectWith(ARect) div 2, 3);
  SendMessage(AHandle,WM_HSCROLL,SB_LINEDOWN,0);

  while not IsScrollEnd(AHandle) do
  begin

    ALineWith:= NextLineWith(AHandle,ARect) + 1;
    ABuf.Width:= ABuf.Width +  ALineWith;
    BitBlt(ABuf.Canvas.Handle,ABuf.Width-ALineWith, 0, ALineWith,ABuf.Height,
      ACanvas.Handle,RectWith(ARect) div 2- ALineWith, 0,  SRCCOPY);

    if SaveDialog1.Execute then begin // 我加入这三句是为了每一个循环截得的图是
    ABuf.SaveToFile(SaveDialog1.FileName);//什么样的, 我发现截得的图不行 !!
    end;//                                


    ACanvas.MoveTo(RectWith(ARect) div 2, 0);
    ACanvas.LineTo(RectWith(ARect) div 2, 3);
    SendMessage(AHandle,WM_HSCROLL,SB_LINEDOWN,0);
  end;

  { Last Copy }
  ALineWith := RectWith(ARect) - RectWith(ARect) div 2;
  ABuf.Width := ABuf.Width+ALineWith;
  BitBlt(ABuf.Canvas.Handle,ABuf.Width-ALineWith, 0,ALineWith, ABuf.Height,
      ACanvas.Handle,RectWith(ARect) div 2 + 1, 0, SRCCOPY);

  ABuf.SaveToFile('C:\ABC.BMP');
  ABuf.Free;
  ReleaseDC(AHandle,ACanvas.Handle);
  ACanvas.Free;

  MessageBox(Handle,'Capture File is SaveTo C:\ABC.BMP.','Info',MB_ICONINFORMATION);
end;

function TForm1.IsScrollEnd(AHandle : THandle): Boolean;//这个函数中是否有错 ??
var                                                     滚动条滚到最大值还是出不
                                                        了循环 !! 
  SI : tagSCROLLINFO;
begin
  SI.cbSize := Sizeof(SI);
  SI.fMask := SIF_ALL;
  GetScrollInfo(AHandle,SB_HORZ,  SI );
  Result := SI.nPos = (SI.nMax - SI.nPage);
end;

function TForm1.NextLineWith(AHandle: THandle; ARect: TRect): Integer;
var
  i : integer;
  ABuf : TBitmap;

begin

  ABuf := TBitmap.Create;
  ABuf.Width := RectWith(ARect) div 2;
  ABuf.Height := 3;

  Result := 0;
  BitBlt(ABuf.Canvas.Handle,0,0,RectWith(ARect), 3, GetDC(AHandle),0,0,SRCCOPY);
  for i := ABuf.Width -1   downto 0 do
  begin
    if ABuf.Canvas.Pixels[i,2] = TAGCOLOR then Break;
    Result := Result + 1;
  end;

  ABuf.Free;
end;

procedure TForm1.FormCreate(Sender: TObject);
begin


  RichEdit1.Lines.LoadFromFile(ExtractFilePath(ParamStr(0))+'unit1.rtf');
end;

end.