做了一个百叶窗小程序
碰到了几个问题,比如说两个用到LoadFromFile函数的地方第一次可以识别相对路径
而如果我更改了其中一个的路径使其变为硬盘上某个绝对路径
那另外一个LoadFromFile就不能识别原先的相对路径了,很奇怪
我采取了加判断绕过这个问题的方法
先上代码,主要的是shutter单元,是作为一个组件来编写的
另外还写了个测试单元。主要针对Shutter的某些属性进行设置从而测试Shutter
unit Shutter;
{ CopyRight@ Swetter }
interface
uses
SysUtils, Windows, Classes, Forms, Controls, Graphics,
Messages, ExtCtrls, Dialogs;
const
{位图344*500,沿Y轴等分成10块
yInc存储了每块的高度
BitMapWid存储了位图的宽度
BitMapHei存储了位图的高度
ShowPixels为随Timer每次递增的行宽度
TimerInterval为Timer的时间间隔}
YInc = 50;
// ShowPixels = 1;
BitMapWid = 344;
BitMapHei = 500;
// TimerInterval = 50;
type
EShutterError = class(Exception);
TShutter = class(TCustomPanel)
private
FMemBitMap: TBitmap;
FMemMskBtMp: TBitmap;
FTimer: TTimer;
FActive: Boolean;
FCurrHei: Integer;
FVRect: TRect;
{FOpen指示百叶窗打开与关闭效果,true则百叶窗打开,false则百叶窗关闭
FDone指示位图是否显示完毕
FViewPic指示是否要查看原图
true为查看原图,此时FCurrHei值直接为yInc而不置0
false为不查看原图,此时在SetActive为false后FCurrHei置0
FNFrstm指示在百叶窗打开模式下(即清空图像)是否已贴上原图
false为未贴上原图,需重新贴一次;true为已贴上原图,可以开始贴屏蔽图}
FOpen: Boolean;
FDone: Boolean;
FViewPic: Boolean;
FOnDone: TNotifyEvent;
FNFrstm: Boolean;
FBkFileName: string;
FFgFileName: string;
ShowPixels: Integer;
TimerInterval: Integer;
procedure IncWid;
procedure SetActive(AValue: Boolean);
procedure ActOnTimer(Sender: TObject);
procedure DoTimer;
protected
procedure Paint; override;
procedure FillBitmap; virtual;
public
procedure CoordinateTimer;
procedure ImageChanged;
property Pixel: Integer read ShowPixels write ShowPixels;
property Interval: Integer read TimerInterval write TimerInterval;
property BkFileName: string read FBkFileName write FBkFileName;
property FgFileName: string read FFgFileName write FFgFileName;
property NFrstm: Boolean read FNFrstm write FNFrstm;
property Open: Boolean read FOpen write FOpen;
property ViewPic: Boolean read FViewPic write FViewPic;
property Active: Boolean read FActive write SetActive;
property Done: Boolean read FDone write FDone;
constructor Create(AOwner: TComponent); override;
destructor Destroy; override;
published
{ Publish inherited properties: }
property OnDone: TNotifyEvent read FOnDone write FOnDone;
property Align;
property Alignment;
property BevelInner;
property BevelOuter;
property BevelWidth;
property BorderWidth;
property BorderStyle;
property Color;
property Ctl3D;
property Font;
property Locked;
property ParentColor;
property ParentCtl3D;
property ParentFont;
property Visible;
property OnClick;
property OnDblClick;
property OnMouseDown;
property OnMouseMove;
property OnMouseUp;
property OnResize;
end;
implementation
{ TShutter }
procedure TShutter.DoTimer;
begin
with FTimer do
begin
Enabled := False;
Interval := TimerInterval;
OnTimer := ActOnTimer;
end;
end;
constructor TShutter.Create(AOwner: TComponent);
begin
inherited Create(AOwner);
TimerInterval := 50;
ShowPixels := 1;
FTimer := TTimer.Create(Self);
DoTimer;
{ 实例初始化的值 }
Width := 344;
Height := 500;
FActive := False;
BevelWidth := 3;
FFgFileName := '.\pics\pic.bmp';
FBkFileName := '.\pics\view.bmp';
end;
destructor TShutter.Destroy;
begin
SetActive(False);
FTimer.Free;
inherited Destroy;
end;
procedure TShutter.ActOnTimer(Sender: TObject);
begin
IncWid;
InvalidateRect(Handle, @FVRect, false);
end;
procedure TShutter.FillBitmap;
begin
//FVRect存储了整张内存位图的区域大小
FVRect := Rect(0, 0, BitMapWid, BitMapHei);
//初始化FMemBitMap的宽度和高度
FMemMskBtMp:= TBitmap.Create;
FMemBitMap := TBitmap.Create;
FMemMskBtMp.Width := BitMapWid;
FMemMskBtMp.Height:= BitMapHei;
FMemBitMap.Width := BitMapWid;
FMemBitMap.Height := BitMapHei;
try
if FBkFileName <> '.\pics\view.bmp' then
FMemMskBtMp.LoadFromFile(FBkFileName);
if FFgFileName <> '.\pics\pic.bmp' then
FMemBitMap.LoadFromFile(FFgFileName);
except
on EFOpenError DO
MessageBox(Handle,'打开文件出错,请重试','提示',MB_OK);
end;
end;
procedure TShutter.IncWid;
begin
if not FOpen and (not FDone) then
begin
if FCurrHei + ShowPixels <= yInc then Inc(FCurrHei, ShowPixels) //为保存位图,不要SetActive(False) else FDone := True; end else if FOpen and(not FDone) then begin if FCurrHei - ShowPixels >= 0 then
Dec(FCurrHei, ShowPixels)
else
FDone := True;
end;
end;
procedure TShutter.Paint;
var
i: Integer;
begin
//如果要查看背景图,直接贴上去
if FViewPic then
BitBlt(Canvas.Handle, 0, 0, BitMapWid, BitMapHei,
FMemBitMap.Canvas.Handle, 0, 0, srcCopy);
if FActive and not FOpen then
for i := 0 to 9 do
BitBlt(Canvas.Handle, 0, i*YInc, BitMapWid, FCurrHei,
FMemBitMap.Canvas.Handle, 0, i*YInc, srcCopy)
else if FActive and FOpen then
begin
if not NFrstm then
begin
for i := 0 to 9 do
BitBlt(Canvas.Handle, 0, i*YInc, BitMapWid, YInc,
FMemBitMap.Canvas.Handle, 0, i*YInc, SRCCOPY);
NFrstm := True;
end
else
for i := 0 to 9 do
BitBlt(Canvas.Handle, 0, i*YInc , BitMapWid, YInc - FCurrHei,
FMemMskBtMp.Canvas.Handle, 0, i*YInc, SRCCOPY);
end
else inherited Paint;
end;
procedure TShutter.SetActive(AValue: Boolean);
begin
if AValue and (not FActive) then
begin
FActive := True;
FillBitmap;
{FViewPic,true则查看位图
FOpen,True则为百叶窗打开模式}
if not FOpen then
FCurrHei := 0
else
FCurrHei := YInc;
try
FTimer.Enabled := True;
except
EShutterError.Create('Timer初始化出错');
end;
end
else if (not AValue) and FActive then
begin
FTimer.Enabled := False; //停止计时
if Assigned(FOnDone) // fire OnDone event,
then FOnDone(Self);
FActive := False; //停止组件
FMemBitMap.Free; //释放内存位图
FMemMskBtMp.Free; //释放屏蔽位图
Invalidate; //清空组件窗口内容
end;
end;
procedure TShutter.ImageChanged;
begin
if (FMemMskBtMp <> nil) and (FMemBitMap <> nil) then
begin
FMemMskBtMp.FreeImage; //释放所占用的位图资源免得重新加载错误
FMemBitMap.FreeImage;
end;
FillBitmap;
end;
procedure TShutter.CoordinateTimer;
begin
DoTimer;
end;
end.
基本上运行效果还是可以的
但是从代码中可以看到很多的boolean值的参数
它们是用来判断功能从而有选择的调用BitBlt函数
设计还是不够好,其实可以用case语句来区分不同功能
我用了太多的boolean来判断导致扩展起来很不方便,容易出BUG