ugsimage.pas

[原创]这是我写的一个图像组件!组件中使用了GraphicEx库

  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.