teamcom.pas

Delphi 7组件与分布式应用开发源码,介绍了基础的组件应用实例

unit TeamCom;

interface

uses
  Windows, Messages, SysUtils, Classes, Controls, StdCtrls, Graphics, Forms;

type

  TEdgeModal = (bvNone, bvLowered, bvRaised);

  TMultiLabel = class;
  TMultiStrings = class(TStrings)
  private
    pCaption: PChar;
    MultiLabel: TMultiLabel;

    function GetBuffText: String;
    procedure SetBuffText(Text: String);
  protected
    function Get(Index: Integer): string; override;
    function GetCount: Integer; override;
    procedure Put(Index: Integer; const S: string); override;
  public
    procedure Clear; override;
    procedure Delete(Index: Integer); override;
    procedure Insert(Index: Integer; const S: string); override;
  end;

  TMultiLabel = class(TCustomLabel)
  private
    { Private declarations }
    FLines : TStrings;
    FBevelOut: TEdgeModal;
    FBevelIn: TEdgeModal;

    procedure SetLines(const Value: TStrings);
    procedure SetBevelOut(const Value: TEdgeModal);
    procedure SetBevelIn(const Value: TEdgeModal);
  protected
    { Protected declarations }
    procedure Paint; virtual;
    procedure WMPaint(var Message: TWMPaint); message WM_PAINT;
  public
    { Public declarations }
    constructor Create(AOwner: TComponent); Override;
    destructor  Destroy; Override;
  published
    { Published declarations }
    property Align;
    property Alignment;
    property Anchors;
    property AutoSize;
    property BevelOut: TEdgeModal read FBevelOut write SetBevelOut;
    property BevelIn: TEdgeModal read FBevelIn write SetBevelIn;
    property BiDiMode;
    property Color;
    property Constraints;
    property DragCursor;
    property DragKind;
    property DragMode;
    property Enabled;
    property FocusControl;
    property Font;
    property ParentBiDiMode;
    property ParentColor;
    property ParentFont;
    property ParentShowHint;
    property PopupMenu;
    property ShowAccelChar;
    property ShowHint;
    property Lines: TStrings read FLines write SetLines;
    property Transparent;
    property Layout;
    property Visible;
    property WordWrap;
    property OnClick;
    property OnContextPopup;
    property OnDblClick;
    property OnDragDrop;
    property OnDragOver;
    property OnEndDock;
    property OnEndDrag;
    property OnMouseDown;
    property OnMouseMove;
    property OnMouseUp;
    property OnMouseEnter;
    property OnMouseLeave;
    property OnStartDock;
    property OnStartDrag;
  end;

procedure Register;

implementation

procedure Register;
begin
  RegisterComponents('TeamCom', [TMultiLabel]);
end;

{ TMultiLabel }

constructor TMultiLabel.Create(AOwner: TComponent);
begin
  inherited Create(AOwner);
  Width := 185;
  Height := 89;
  AutoSize := False;

  FBevelOut := bvLowered;
  FBevelIn := bvRaised;

  FLines := TMultiStrings.Create;
  TMultiStrings(FLines).MultiLabel := self;
end;

destructor TMultiLabel.Destroy;
begin
  if Assigned(FLines) then Flines.Free;
  FLines := nil;
  inherited;
end;


procedure TMultiLabel.Paint;
  procedure DrawEdgeRect(Rise: Boolean; ARect: TRect);
  var
    pDC: HDC;
  begin
    pDC := Canvas.Handle;
    if Rise then
    begin
      DrawEdge(pDC, ARect,BDR_RAISEDINNER, BF_BOTTOMRIGHT);
      DrawEdge(pDC, ARect,BDR_RAISEDINNER, BF_TOPLEFT);
    end
    else
    begin
      DrawEdge(pDC, ARect,BDR_SUNKENOUTER, BF_BOTTOMRIGHT);
      DrawEdge(pDC, ARect,BDR_SUNKENOUTER, BF_TOPLEFT);
    end;
  end;
var
  Rect :TRect;
  I: Integer;
begin
  inherited;
  Rect := GetClientRect;

  case FBevelOut of
    bvLowered: DrawEdgeRect(false, Rect);
    bvRaised: DrawEdgeRect(true, Rect);
  end;
  InflateRect(Rect, -1, -1);
  case FBevelIn of
    bvLowered: DrawEdgeRect(false, Rect);
    bvRaised: DrawEdgeRect(true, Rect);
  end;
end;

procedure TMultiLabel.SetBevelIn(const Value: TEdgeModal);
begin
  FBevelIn := Value;
  Invalidate;
end;

procedure TMultiLabel.SetBevelOut(const Value: TEdgeModal);
begin
  FBevelOut := Value;
  Invalidate;
end;

procedure TMultiLabel.SetLines(const Value: TStrings);
begin
  Lines.Text := Value.Text;
end;


procedure TMultiLabel.WMPaint(var Message: TWMPaint);
begin
  if Message.DC <> 0 then
  begin
    Canvas.Lock;
    try
      Canvas.Handle := Message.DC;
      try
        Paint;
      finally
        Canvas.Handle := 0;
      end;
    finally
      Canvas.Unlock;
    end;
  end;
end;

{ TMultiStrings }

procedure TMultiStrings.Clear;
begin
  inherited;
  SetBuffText('');
end;

procedure TMultiStrings.Delete(Index: Integer);
var
  mLines: TStrings;
begin
  inherited;
  if (Index < 0) or (Index > MultiLabel.Lines.Count) then
  raise Exception.Create('访问字符串下标('+Inttostr(Index)+')溢出');

  try
    mLines := TStringList.Create;
    mLines.Text := GetBuffText;
    mLines.Delete(Index);
    MultiLabel.Lines := mLines;
  finally
    mLines.Free;
  end;
end;

function TMultiStrings.Get(Index: Integer): string;
var
  mLines: TStrings;
begin
  if (Index < 0) or (Index > MultiLabel.Lines.Count) then
  raise Exception.Create('访问字符串下标('+Inttostr(Index)+')溢出');

  try
    mLines := TStringList.Create;
    mLines.Text := GetBuffText;
    Result := mLines.Strings[Index];
  finally
    mLines.Free;
  end;
end;

function TMultiStrings.GetBuffText: String;
begin
  Result := MultiLabel.Caption;
end;

function TMultiStrings.GetCount: Integer;
var
  mLines: TStrings;
begin
  try
    mLines := TStringList.Create;
    mLines.Text := GetBuffText;
    Result := mLines.Count;
  finally
    mLines.Free;
  end;
end;


procedure TMultiStrings.Insert(Index: Integer; const S: string);
var
  mLines: TStrings;
begin
  inherited;
  try
    mLines := TStringList.Create;
    mLines.Text := GetBuffText;
    TStringList(mLines).Insert(Index, S);
    MultiLabel.Caption := mLines.Text;
  finally
    mLines.Free;
  end;
end;

procedure TMultiStrings.Put(Index: Integer; const S: string);
var
  mLines: TStrings;
begin
  inherited;
  try
    mLines := TStringList.Create;
    mLines.Text := GetBuffText;
    mLines.Strings[Index] := S;
    SetBuffText(mLines.Text);
  finally
    mLines.Free;
  end;
end;


procedure TMultiStrings.SetBuffText(Text: String);
begin
  MultiLabel.Caption := Text;
end;


end.