代码哪里错 ??? ( 积分: 75 )

高手们 : 大家好!

delphibox 上有一垂直滚屏截图的例子, 能正常编译运行, 我把它改为水平滚屏截图,
编译通过, 运行却不能正确截图, 请大家指正, 谢谢 !!
原代码: http://www.2ccc.com/article.asp?articleid=725

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.

请高手们试试 !!