fcprogressbar.pas

一套及时通讯的原码

unit fcProgressBar;
{
//
// Components : TfcProgressBar
//
// Copyright (c) 2003 by Woll2Woll Software
}
interface
{$i fcIfdef.pas}

uses
  SysUtils, Classes, Controls, messages, windows,
  {$ifdef fcDelphi7Up}
  Themes,
  {$endif}
  {$ifdef ThemeManager}
  thememgr, themesrv, uxtheme,
  {$endif}

  graphics, db, dbctrls;

type
  TfcProgressBarOrientation = (fcpbHorizontal, fcpbVertical);
  TfcProgressBar = class(TCustomControl)
  private
    FDisableThemes: boolean;
    FMin: Integer;
    FMax: Integer;
    FPosition: Integer;
    FStep: Integer;
    FOrientation: TfcProgressBarOrientation;
    FSmooth: Boolean;
    FBlockSize: integer;
    FBlockColor: TColor;
    FShowProgressText: boolean;
    FDataLink: TFieldDataLink;
    FOnChange: TNotifyEvent;
    FCanvas: TControlCanvas; // For csPaintCopy State
    FDisplayFormat: string;
    function GetMin: Integer;
    function GetMax: Integer;
    function GetProgress: Integer;
    procedure SetParams(AMin, AMax: Integer);
    procedure SetMin(Value: Integer);
    procedure SetMax(Value: Integer);
    procedure SetProgress(Value: Integer);
    procedure SetStep(Value: Integer);
    procedure SetOrientation(Value: TfcProgressBarOrientation);
    procedure SetSmooth(Value: Boolean);
    procedure SetBlockSize(Value: integer);
    procedure SetBlockColor(Value: TColor);
    procedure SetDisplayFormat(Value: String);
    procedure WMPaint(var Message: TWMPaint); message WM_PAINT;
    procedure WMEraseBkGnd(var Message: TWMEraseBkGnd); message WM_ERASEBKGND;
    procedure CMGetDataLink(var Message: TMessage); message CM_GETDATALINK;

    function GetCanvas: TCanvas;
    function GetDataField: string;
    function GetDataSource: TDataSource;
    procedure SetDataField(const Value: string);
    procedure SetDataSource(Value: TDataSource);
    function GetField: TField;
    procedure PaintAsText(AnImage: TBitmap; PaintRect: TRect);

  protected
    procedure DrawBar(Canvas: TCanvas); virtual;
//    procedure DrawProgressText(Canvas: TCanvas); virtual;
    procedure Changed; virtual;
    procedure UpdateData(Sender: TObject); virtual;
    procedure Notification(AComponent: TComponent; Operation: TOperation); override;
    procedure DataChange(Sender: TObject); virtual;
    procedure CreateParams(var Params: TCreateParams); override;
    procedure Loaded; override;
    procedure PaintProgressBar; virtual;
//    procedure CreateWnd; override;
//    procedure DestroyWnd; override;
  public
    constructor Create(AOwner: TComponent); override;
    destructor Destroy; override;
    procedure StepIt;
    procedure StepBy(Delta: Integer);
    property DataLink: TFieldDataLink read FDataLink;
    property Field: TField read GetField;
    property Canvas: TCanvas read GetCanvas;
  published
    property DisableThemes : boolean read FDisableThemes write FDisableThemes default False;
    property Align;
    property Anchors;
    property BorderWidth;
    property DragCursor;
    property DragKind;
    property DragMode;
    property Enabled;
    property Hint;
    property Constraints;
    property Color;
    property DataField: string read GetDataField write SetDataField;
    property DataSource: TDataSource read GetDataSource write SetDataSource;
    property OnChange: TNotifyEvent read FOnChange write FOnChange;
    property ShowProgressText : boolean read FShowProgressText write FShowProgressText default True;
    property Min: Integer read GetMin write SetMin default 0;
    property Max: Integer read GetMax write SetMax default 100;
    property BlockSize: integer read FBlockSize write SetBlockSize default 10;
    property BlockColor: TColor read FBlockColor write SetBlockColor default clHighlight;
    property Orientation: TfcProgressBarOrientation read FOrientation
      write SetOrientation default fcpbHorizontal;
    property ParentShowHint;
    property PopupMenu;
    property Progress: Integer read GetProgress write SetProgress default 0;
    property Smooth: Boolean read FSmooth write SetSmooth default False;
    property Step: Integer read FStep write SetStep default 10;
    property DisplayFormat: string read FDisplayFormat write SetDisplayFormat;
    property ShowHint;
    property TabOrder;
    property TabStop;
    property Visible;
    property OnContextPopup;
    property OnDragDrop;
    property OnDragOver;
    property OnEndDock;
    property OnEndDrag;
    property OnEnter;
    property OnExit;
    property OnMouseDown;
    property OnMouseMove;
    property OnMouseUp;
    property OnStartDock;
    property OnStartDrag;
  end;

procedure Register;

implementation

uses consts, fccommon;

procedure Register;
begin
  RegisterComponents('1stClass', [TfcProgressBar]);
end;

procedure TfcProgressBar.DrawBar;
var
    {$ifdef fcUseThemeManager}
    Details: TThemedElementDetails;
    {$endif}
    ChunkRect, TempRect: TRect;
    r: TRect;
    current, lastBottom, lastleft: integer;
begin
   if fcUseThemes(self) then
   begin
     {$ifdef fcUseThemeManager}
     if Orientation = fcpbVertical then
     begin
        Details := ThemeServices.GetElementDetails(tpBarVert);
        ThemeServices.DrawElement(Canvas.Handle, Details, ClientRect);
        Details := ThemeServices.GetElementDetails(tpChunkVert);
        ChunkRect:= ClientRect;
        InflateRect(ChunkRect, -3, -3);
        ChunkRect.Top:= ChunkRect.Bottom - Trunc((ChunkRect.Bottom-ChunkRect.top) * (Progress-Min)/(Max-Min));
        ThemeServices.DrawElement(Canvas.Handle, Details, ChunkRect);
     end
     else begin
        Details := ThemeServices.GetElementDetails(tpBar);
        ThemeServices.DrawElement(Canvas.Handle, Details, ClientRect);
        Details := ThemeServices.GetElementDetails(tpChunk);
        ChunkRect:= ClientRect;
        InflateRect(ChunkRect, -3, -3);
        ChunkRect.Right:= ChunkRect.Left + Trunc((ChunkRect.Right-ChunkRect.Left) * (Progress-Min)/(Max-Min));
        ThemeServices.DrawElement(Canvas.Handle, Details, ChunkRect);
     end
     {$endif}
   end
   else begin
     if Orientation = fcpbVertical then
     begin
        Canvas.Brush.Color:= Color;
        Canvas.FillRect(ClientRect);
        r:= ClientRect;
        DrawEdge(Canvas.Handle, r, EDGE_SUNKEN, BF_TOP or BF_LEFT);
        DrawEdge(Canvas.Handle, r, EDGE_SUNKEN, BF_RIGHT or BF_BOTTOM);
        ChunkRect:= ClientRect;
        InflateRect(ChunkRect, -3, -3);

        current:= Min;
        LastBottom:= ChunkRect.bottom;
        current:= current + BlockSize;
        while (current<=Progress) do begin
           Canvas.Brush.Color:= BlockColor;
           TempRect:= ChunkRect;
           TempRect.Top:= ChunkRect.Bottom - Trunc((ChunkRect.Bottom-ChunkRect.top) * (Current-Min)/(Max-Min));
           TempRect.Top:= fcMax(TempRect.Top, ChunkRect.Top);
           TempRect.Bottom:= fcMax(ChunkRect.Top, LastBottom);
           if Smooth then LastBottom:= TempRect.Top
           else LastBottom:= TempRect.Top - 2;
           Canvas.FillRect(TempRect);
           current:= current + BlockSize;
        end;
     end
     else begin
        Canvas.Brush.Color:= Color;
        Canvas.FillRect(ClientRect);
        r:= ClientRect;
        DrawEdge(Canvas.Handle, r, EDGE_SUNKEN, BF_TOP or BF_LEFT);
        DrawEdge(Canvas.Handle, r, EDGE_SUNKEN, BF_RIGHT or BF_BOTTOM);
        ChunkRect:= ClientRect;
        InflateRect(ChunkRect, -3, -3);

        current:= Min;
        LastLeft:= ChunkRect.Left;
        current:= current + BlockSize;
        while (current<=Progress) do begin
           Canvas.Brush.Color:= BlockColor;
           TempRect:= ChunkRect;
           TempRect.Left:= fcMin(ChunkRect.Right, LastLeft);
           TempRect.Right:= ChunkRect.Left + Trunc((ChunkRect.Right-ChunkRect.Left) * (Current-Min)/(Max-Min));
           TempRect.Right:= fcMin(TempRect.Right, ChunkRect.Right);
           if Smooth then
             LastLeft:= TempRect.Right
           else
             LastLeft:= TempRect.Right + 2;

           Canvas.FillRect(TempRect);
           current:= current + BlockSize;
        end;
     end
   end;

end;

(*procedure TfcProgressBar.DrawProgressText;
var DrawFlags: integer;
    percent: integer;
    percentStr: string;
    halfx, halfy: integer;
    r: TRect;
begin
   if ShowProgressText then
   begin
     SetBkMode(Canvas.Handle, windows.TRANSPARENT);
     Drawflags:= DT_NOPREFIX;
     Percent:= Trunc(Progress/(Max-Min)*100);
     PercentStr:= FloatToStr(Percent);
     HalfX:= ClientWidth div 2;
     HalfY:= ClientHeight div 2;
     r:= Rect(HalfX - Canvas.TextWidth(Percentstr) div 2, HalfY - Canvas.TextHeight(PercentStr) div 2,
              HalfX + Canvas.TextWidth(Percentstr) div 2, HalfY + Canvas.TextHeight(PercentStr) div 2);

     DrawText(Canvas.Handle, pchar(PercentStr), length(PercentStr), r, DrawFlags);
   end;
end;
*)

procedure TfcProgressBar.WMPaint(var Message: TWMPaint);
var DC: HDC;
    PS: TPaintStruct;
  procedure CanvasNeeded;
  begin
    if FCanvas = nil then
    begin
      FCanvas := TControlCanvas.Create;
      FCanvas.Control := Self;
    end;
  end;
begin
  if (csPaintCopy in ControlState) then
  begin
      try
         if FCanvas = nil then
         begin
            FCanvas := TControlCanvas.Create;
            FCanvas.Control := Self;
         end;
         CanvasNeeded;

         if Message.DC = 0 then DC := BeginPaint(Handle, PS)
         else DC:= Message.DC;
         FCanvas.Handle := DC;

         PaintProgressBar;
       finally
         FCanvas.Handle := 0;
         if Message.DC = 0 then EndPaint(Handle, PS);
       end;
       exit;
   end;

   PaintProgressBar;
   inherited;
end;

type
  TBltBitmap = class(TBitmap)
    procedure MakeLike(ATemplate: TBitmap);
  end;

{ TBltBitmap }

procedure TBltBitmap.MakeLike(ATemplate: TBitmap);
begin
  Width := ATemplate.Width;
  Height := ATemplate.Height;
  Canvas.Brush.Color := clWindowFrame;
  Canvas.Brush.Style := bsSolid;
  Canvas.FillRect(Rect(0, 0, Width, Height));
end;

procedure TfcProgressBar.PaintProgressBar;
var
  TheImage: TBitmap;
  OverlayImage: TBltBitmap;
  PaintRect: TRect;
begin
    TheImage := TBitmap.Create;
    try
      TheImage.Height := Height;
      TheImage.Width := Width;