?? ugsimage.pas
字號:
if AInterval>0 then
begin
if SetTimer(FWindowHandle, 1, AInterval, nil) = 0 then
raise EOutOfResources.Create('播放動畫失敗!');
end;
end;
function TGSImage.getImageCount:Integer;
begin
Result:=0;
end;
procedure TGSImage.setImageCount(const value:Integer);
begin
end;
(******************************************************************************)
procedure TGSImage.set_show_border(const value:Boolean);
begin
FShowBorder:=value;
Repaint;
end;
procedure TGSImage.set_borders(const value:TBoxBorders);
begin
FBoxBorders:=value;
Repaint;
end;
procedure TGSImage.set_border_width(const value:integer);
begin
if (value<0) or (value>400) then
raise Exception.Create('非法數值!');
FBorderWidth:=value;
Repaint;
end;
procedure TGSImage.set_border_color(const value:TColor);
begin
FBorderColor:=value;
Repaint;
end;
procedure TGSImage.DrawBorder();
begin
//給制邊框
FCanvas.Pen.Color:=FBorderColor;
FCanvas.Brush.Color:=FBorderColor;
if bbleft in FBoxBorders then
begin
//繪制左邊框
FCanvas.FillRect(Rect(0,0,FBorderWidth,Height));
end;
if bbtop in FBoxBorders then
begin
//繪制頂邊框
FCanvas.FillRect(Rect(0,0,Width,FBorderWidth));
end;
if bbbottom in FBoxBorders then
begin
//繪制底邊框
FCanvas.FillRect(Rect(0,Height-FBorderWidth,Width,Height));
end;
if bbright in FBoxBorders then
begin
//繪制右邊框
FCanvas.FillRect(Rect(Width-FBorderWidth,0,Width,Height));
end;
end;
procedure TGSImage.DrawClientRect();
begin
//重新繪制客戶區
FCanvas.Brush.Style:=FBrushStyle;
FCanvas.Brush.Color:=Color;
FCanvas.FillRect(GetClientRect);
end;
procedure TGSImage.DrawPicture();
var
Rct,Tmp:TRect;
X,H,I:Integer;
begin
//繪制圖像
if not Assigned(FPicture) then Exit;
if (not Assigned(FPicture.Graphic)) or FPicture.Graphic.Empty then Exit;
Rct:=GetClientRect;
if FSmall then
begin
H:=FSmallHeight;
I:=FSmallWidth;
end else begin
H:=FPicture.Height;
I:=FPicture.Width;
end;
SetStretchBltMode(FCanvas.Handle,HalfTone);
if FAutoSize then
begin
X:=0;
if FShowBorder then x:=FBorderWidth;
if ((Self.ClientHeight<>H) and (not (Align in [alClient,alLeft,alRight]))) or
((Self.ClientWidth<>I) and (not (Align in [alTop,alBottom,alClient]))) then
begin
ClientWidth:=I;
ClientHeight:=H;
Exit;
end;
end else if not (FStyle in [isRepeat]) then begin
case FHAlign of
iaHLeft :begin
if FStyle<>isStretch then
Rct.Right:=I;
end;
iaHCenter :begin
Rct.Left:=(ClientWidth div 2)-(I div 2);
Rct.Right:=(ClientWidth div 2)+(I div 2);
if I mod 2<>0 then Rct.Right:=Rct.Right+1;
end;
iaHRight :begin
Rct.Left:=(ClientWidth-I);
if FStyle<>isStretch then
Rct.Right:=ClientWidth;
end;
end;
case FVAlign of
iaVTop :begin
if FStyle<>isStretch then
Rct.Bottom:=H;
end;
iaVCenter :begin
Rct.Top:=(ClientHeight div 2)-(H div 2);
Rct.Bottom:=(ClientHeight div 2)+(H div 2);
if H mod 2<>0 then Rct.Bottom:=Rct.Bottom+1;
end;
iaVBottom :begin
Rct.Top:=ClientHeight-H;
if FStyle<>isStretch then
Rct.Bottom:=ClientHeight;
end;
end;
end;
case FStyle of
isNone :begin
if Rct.Right-Rct.Left>FPicture.Width then
Rct.Right:=Rct.Left+fpicture.Width;
if Rct.Bottom-rct.Top>FPicture.Height then
Rct.Bottom:=Rct.Top+FPicture.Height;
FCanvas.StretchDraw(Rct,FPicture.Graphic);
end;
isStretch :begin
FCanvas.StretchDraw(Rct,FPicture.Graphic);
end;
isRepeat :begin
H:=Rct.Top;
I:=Rct.Left;
while True do
begin
if (I>=Rct.Right) then
begin
if FSmall then
H:=FSmallHeight+H
else
H:=FPicture.Height+H;
I:=Rct.Left;
end;
if FSmall then
begin
Tmp:=Rect(I,H,FSmallWidth+I,FSmallHeight+H);
I:=FSmallWidth+I;
FCanvas.StretchDraw(Tmp,FPicture.Graphic);
end else begin
Tmp:=Rect(I,H,FPicture.Width+I,FPicture.Height+H);
I:=FPicture.Width+I;
FCanvas.StretchDraw(Tmp,FPicture.Graphic);
end;
if (H>=Rct.Bottom) then Break;
end;
end;
end;
end;
procedure TGSImage.DrawGif();
begin
end;
procedure TGSImage.Paint;
begin
ClearCanvas;
inherited;
DrawClientRect();
if FPlayGif and (FImageType=itGif) then
begin
end else begin
DrawPicture();
end;
if ShowBorder and (FBorderWidth>0) then DrawBorder;
end;
procedure TGSImage.ClearCanvas;
var
BS:TBrushStyle;
begin
BS:=FCanvas.Brush.Style;
FCanvas.Brush.Color:=Color;
FCanvas.Brush.Style:=bsClear;
FCanvas.Rectangle(0, 0, Width, Height);
FCanvas.Brush.Style:=BS;
end;
function TGSImage.GetClientRect: TRect;
begin
if FShowBorder then
begin
Result:=Rect(FBorderWidth,FBorderWidth,Width-FBorderWidth,height-FBorderWidth);
end else begin
Result:=inherited GetClientRect();
end;
end;
procedure TGSImage.SetPicture(const value:TPicture);
begin
if Assigned(value) then
begin
FPicture.Assign(value);
Repaint;
end;
end;
procedure TGSImage.DoTimer;
begin
//
end;
(******************************************************************************)
constructor TGSImage.Create(AOwner:TComponent);
begin
ControlStyle := ControlStyle + [csReplicatable,csAcceptsControls];
inherited Create(AOwner);
FFirstEnter:=True;
FWindowHandle:=0;
FImageType:=itUnknow;
FPicture:=TPicture.Create;
FPicture.OnChange:=DoChange;
FCanvas:=TControlCanvas.Create;
TControlCanvas(FCanvas).Control:=Self;
set_show_border(False);
set_border_width(1);
set_border_color(clBlack);
set_borders([bbLeft,bbTop,bbRight,bbBottom]);
SetBrushStyle(bsSolid);
SetStyle(isNone);
setHAlign(iaHCenter);
setVAlign(iaVCenter);
SetAutoSize(True);
SetSmall(False);
SetSmallHeight(150);
SetSmallWidth(150);
SetSmallBackColor(clWhite);
{$IFDEF MSWINDOWS}
FWindowHandle := Classes.AllocateHWnd(WndProc);
{$ENDIF}
{$IFDEF LINUX}
FWindowHandle := WinUtils.AllocateHWnd(WndProc);
{$ENDIF}
end;
destructor TGSImage.Destroy;
begin
UpdateTimer(0);
if FWindowHandle>0 then
begin
{$IFDEF MSWINDOWS}
Classes.DeallocateHWnd(FWindowHandle);
{$ENDIF}
{$IFDEF LINUX}
WinUtils.DeallocateHWnd(FWindowHandle);
{$ENDIF}
end;
FreeAndNil(FPicture);
FreeAndNil(FCanvas);
inherited;
end;
function TGSImage.Jpg2BMP(const filename:string):TBitmap;
Var
mybmp: TBitmap;
AJpeg: TJpegImage;
S:string;
begin
Result:=nil;
S:=Trim(filename);
if (S='') or (not FileExists(S)) then Exit;
AJpeg := TJpegImage.Create;
try AJpeg.LoadFromFile(S);except AJpeg:=nil;end;
if Assigned(AJpeg) then
begin
Result:=Jpg2BMP(AJpeg);
end;//根據長寬比例實現縮略圖
end;
function TGSImage.Jpg2BMP(const AJpeg:TJpegImage):TBitmap;
Var
mybmp: TBitmap;
begin
Result:=nil;
if not Assigned(AJpeg) then Exit;
Result:= TBitmap.Create;
try
AJpeg.DIBNeeded;
Result.Assign(AJpeg);
except
FreeAndNil(Result);
end;
end;
function TGSImage.GetSmallImage(const ABmp:TBitmap;const width,height:integer;const BaclgroundColor:TColor=clBlack):TBitmap;
Var
mybmp: TBitmap;
r:Double;
a,b:Double;
Rct1,Rct2:TRect;
begin
//生成一幅縮略圖
Result:=nil;
if not Assigned(ABmp) then Exit;
Result:= TBitmap.Create;
try
mybmp:=ABmp;
a:=mybmp.Width;
b:=mybmp.Height;
r:=a/b;
result.Width:=width;
result.Height:=height;
result.Canvas.Brush.Color:=BaclgroundColor;
result.Canvas.FillRect(rect(0,0,width,height));
SetStretchBltMode(result.Canvas.Handle,HalfTone);//SetStretchBltMode函數可以設置指定設備環境中的位圖拉伸模式
if r<1.25 then
begin
Rct1:=rect(round(result.Width/2)-round(result.Height*r/2),0,round(result.Width/2)-round(result.Height*r/2)+round(result.Height*r),result.Height);
Rct2:=rect(0,0,mybmp.Width,mybmp.Height);
end else begin
Rct1:=rect(0,round(result.Height/2)-round(result.width/r/2),result.Width,round(result.Height/2)-round(result.width/r/2)+round(result.width/r));
Rct2:=rect(0,0,mybmp.Width,mybmp.Height);
end;
Result.Canvas.CopyRect(Rct1,mybmp.Canvas,Rct2);
except
FreeAndNil(Result);
end;
end;
procedure TGSImage.Reset;
begin
FreeAndNil(FPicture);
FPicture:=TPicture.Create;
end;
end.
?? 快捷鍵說明
復制代碼
Ctrl + C
搜索代碼
Ctrl + F
全屏模式
F11
切換主題
Ctrl + Shift + D
顯示快捷鍵
?
增大字號
Ctrl + =
減小字號
Ctrl + -