1: 2: 3: 4: 5: 6: 7: 8: 9: 10: 11: 12: 13: 14: 15: 16: 17: 18: 19: 20: 21: 22: 23: 24: 25: 26: 27: 28: 29: 30: 31: 32: 33: 34: 35: 36: 37: 38: 39: 40: 41: 42: 43: 44: 45: 46: 47: 48: 49: 50: 51: 52: 53: 54: 55: 56: 57: 58: 59: 60: 61: 62: 63: 64: 65: 66: 67: 68: 69: 70: 71: 72: 73: 74: 75: 76: 77: 78: 79: 80: 81: 82: 83: 84: 85: 86: 87: 88: 89: 90: 91: 92: 93: 94: 95: 96: 97: 98: 99: 100: 101: 102: 103: 104: 105: 106: 107: 108: 109: 110: 111: 112: 113: 114: 115: 116: 117: 118: 119: 120: 121: 122: 123: 124: 125: 126: 127: 128: 129: 130: 131: 132: 133: 134: 135: 136: 137: 138: 139: 140: 141: 142: 143: 144: 145: 146: 147: 148: 149: 150: 151: 152: 153: 154: 155: 156: 157: 158: 159: 160: 161: 162: 163: 164: 165: 166: 167: 168: 169: 170: 171: 172: 173: 174: 175: 176: 177: 178: 179: 180: 181: 182: 183: 184: 185: 186: 187: 188: 189: 190: 191: 192: 193: 194: 195: 196: 197: 198: 199: 200: 201: 202: 203: 204: 205: 206: 207: 208: 209: 210: 211: 212: 213:
| unit ExProgressbar;
interface
uses SysUtils, Classes, Controls, Graphics, Messages, Forms;
type TSmallPoint = packed record x: SmallInt; y: SmallInt; end;
type TWMButtonEvent = packed record Msg: Cardinal; Keys: Longint; case Integer of 0: ( XPos: Smallint; YPos: Smallint); 1: ( Pos: TSmallPoint; Result: Longint); end;
type TMouseEvent = procedure(Sender: TObject; Button: TMouseButton; Shift: TShiftState; X, Y: Integer) of object;
type TExProgressbar = class(TCustomControl) private cBackColor: TColor; cForeColor: TColor; iValue: integer; iMaxVal: integer; Position: integer; FOnMouseDown: TMouseEvent; FOnMouseUp: TMouseEvent; procedure SetForeColor(SColor: TColor); procedure SetBackColor(SColor: TColor); Function GetForeColor: TColor; Function GetBackColor: TColor; procedure WMLButtonDown(var Message: TWMLButtonDown); message WM_LBUTTONDOWN; procedure WMLButtonUp(var Message: TWMLButtonUp); message WM_LBUTTONUP; procedure WMRButtonDown(var Message: TWMRButtonDown); message WM_RBUTTONDOWN; procedure WMRButtonUp(var Message: TWMRButtonUp); message WM_RBUTTONUP; procedure WMMButtonDown(var Message: TWMMButtonDown); message WM_MBUTTONDOWN; procedure WMMButtonUp(var Message: TWMMButtonUp); message WM_MBUTTONUP; procedure SetValue(SValue: Integer); procedure SetMaxVal(SValue: Integer); procedure SetPosition(Pos: Integer); protected procedure Paint; override; public constructor Create(AOwner: TComponent); override; published property Value: Integer read iValue write SetValue; property MaxValue: Integer read iMaxVal write SetMaxVal default 1; property ForeColor: TColor read GetForeColor write SetForeColor; property BackColor: TColor read GetBackColor write SetBackColor; property OnMouseDown: TMouseEvent read FOnMouseDown write FOnMouseDown; property OnMouseUp: TMouseEvent read FOnMouseUp write FOnMouseUp; property Hint; property OnClick; property ParentShowHint; property PopupMenu; property ShowHint; property Visible; end;
procedure Register;
implementation
procedure Register; begin RegisterComponents('ExComponents', [TExProgressbar]); end;
constructor TExProgressbar.Create(AOwner: TComponent); begin inherited; Height:=16; Width:=150; iMaxVal := 100; iValue:=1; Position:=1; cBackColor:=clBlack; cForeColor:=clRed; end;
procedure TExProgressbar.Paint; begin inherited; if csDesigning in ComponentState then begin Canvas.Brush.Style:= bsSolid; Canvas.Pen.style := psClear; Canvas.Brush.Color:=cBackColor; Canvas.Rectangle(0,0,width,height); Canvas.Brush.Color:=cForeColor; Canvas.Rectangle(2,2,Position-2,height-2); exit; end; Canvas.Brush.Style:=bsSolid; Canvas.Brush.Color:=cBackColor; Canvas.Pen.Style:=psClear; Canvas.Rectangle(0,0,width,height); Canvas.Brush.color:=cForeColor; Canvas.Pen.Style:=psClear; Canvas.Brush.Style:=bsSolid; Canvas.Rectangle(2,2,Position-2,height-2); end;
procedure TExProgressbar.SetForeColor(SColor: TColor); begin cForeColor:=SColor; Paint; end;
procedure TExProgressbar.SetBackColor(SColor: TColor); begin cBackColor:=SColor; Paint; end;
function TExProgressbar.GetForeColor: TColor; begin result:=cForeColor; end;
function TExProgressbar.GetBackColor: TColor; begin result:=cBackColor; end;
procedure TExProgressbar.WMLButtonDown(var Message: TWMLButtonDown); begin inherited; if Assigned(FOnMouseDown) then with Message do FOnMouseDown(Self, mbLeft, KeysToShiftState(Keys), XPos, YPos); end;
procedure TExProgressbar.WMLButtonUp(var Message: TWMLButtonUp); begin inherited; if Assigned(FOnMouseUp) then with Message do FOnMouseUp(Self, mbLeft, KeysToShiftState(Keys), XPos, YPos); end;
procedure TExProgressbar.WMRButtonDown(var Message: TWMRButtonDown); begin inherited; if Assigned(FOnMouseDown) then with Message do FOnMouseDown(Self, mbRight, KeysToShiftState(Keys), XPos, YPos); end;
procedure TExProgressbar.WMRButtonUp(var Message: TWMRButtonUp); begin inherited; if Assigned(FOnMouseUp) then with Message do FOnMouseUp(Self, mbRight, KeysToShiftState(Keys), XPos, YPos); end;
procedure TExProgressbar.WMMButtonDown(var Message: TWMMButtonDown); begin inherited; if Assigned(FOnMouseDown) then with Message do FOnMouseDown(Self, mbMiddle, KeysToShiftState(Keys), XPos, YPos); end;
procedure TExProgressbar.WMMButtonUp(var Message: TWMMButtonUp); begin inherited; if Assigned(FOnMouseUp) then with Message do FOnMouseUp(Self, mbMiddle, KeysToShiftState(Keys), XPos, YPos); end;
procedure TExProgressbar.SetValue(SValue: Integer); begin if SValue<=iMaxVal then begin SetPosition(SValue); iValue:=position; Paint; end; end; procedure TExProgressbar.SetMaxVal(SValue: Integer); begin if SValue=0 then iMaxVal:=1 else iMaxVal:=SValue; SetValue(iValue); end;
procedure TExProgressbar.SetPosition(Pos: Integer); var ePosition: Extended; begin eposition:=((Width-2)/iMaxVal)*Pos; position:=trunc(ePosition); end;
end. |