Recull Components Delphi

ColorButton i ColorSpeedButton

Aquests components són una modificació sobre els components Button i SpeedButton per poder canviar-los de color.

unit TtButton;

interface

uses
  Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs, DsgnIntf,
  ShellAPI, StdCtrls, Buttons;

type
  TColorButton = class(TCustomControl)
  private
    { Private declarations }
    FCaption: string;
    FFont: TFont;
    FColor: TColor;
    FWidthTop,FWidthDown: integer;
    FGlyph: TBitmap;
    FParentColor: boolean;
    FBitmap: TBitmap;
    procedure SetCaption(Value: string);
    procedure SetFont(Value: TFont);
    procedure SetColor(Value: TColor);
    procedure SetParentColor(AParentColor: boolean);
  protected
    { Protected declarations }
    procedure SetGlyph(Value: TBitmap);
    procedure Paint; override;
    procedure MouseDown(Button: TMouseButton; Shift: TShiftState; X, Y: Integer); override;
    procedure MouseUp(Button: TMouseButton; Shift: TShiftState; X, Y: Integer); override;
    procedure KeyPress(var Key: Char); override;
    procedure DoExit; override;
    procedure DoEnter; override;
    procedure Click; override;
  public
    { Public declarations }
    constructor Create(AOwner: TComponent); override;
    destructor Destroy; override;
  published
    { Published declarations }
    property Caption: string read FCaption write SetCaption;
    property Font: TFont read FFont write SetFont;
    property Color: TColor read FColor write SetColor;
    property Glyph: TBitmap read FGlyph write SetGlyph;
    property Action;
    property Anchors;
    property BidiMode;
    property Constraints;
    property DragCursor;
    property DragKind;
    property DragMode;
    property Enabled;
    property ParentBiDiMode;
    property ParentColor: boolean read FParentColor write SetParentColor;
    property ParentFont;
    property ParentShowHint;
    property PopupMenu;
    property ShowHint;
    property TabOrder;
    property TabStop;
    property Visible;
    property OnClick;
    property OnEnter;
    property OnExit;
    property OnKeyDown;
    property OnKeyUp;
    property OnKeyPress;
    property OnMouseDown;
    property OnMouseMove;
    property OnMouseUp;
  end;

type
  TColorSpeedButton = class(TGraphicControl)
  private
    { Private declarations }
    FCaption: string;
    FFont: TFont;
    FColor: TColor;
    FTopColor,FBottomColor: integer;
    FGlyph: TBitmap;
    FParentColor: boolean;
    FBitmap: TBitmap;
    procedure SetCaption(Value: string);
    procedure SetFont(Value: TFont);
    procedure SetColor(Value: TColor);
    procedure SetParentColor(AParentColor: boolean);
  protected
    { Protected declarations }
    procedure SetGlyph(Value: TBitmap);
    procedure Paint; override;
    procedure MouseDown(Button: TMouseButton; Shift: TShiftState; X, Y: Integer); override;
    procedure MouseUp(Button: TMouseButton; Shift: TShiftState; X, Y: Integer); override;
  public
    { Public declarations }
    constructor Create(AOwner: TComponent); override;
    destructor Destroy; override;
  published
    { Published declarations }
    property Caption: string read FCaption write SetCaption;
    property Font: TFont read FFont write SetFont;
    property Color: TColor read FColor write SetColor;
    property Glyph: TBitmap read FGlyph write SetGlyph;
    property Action;
    property Anchors;
    property BidiMode;
    property Constraints;
    property DragCursor;
    property DragKind;
    property DragMode;
    property Enabled;
    property ParentBiDiMode;
    property ParentColor: boolean read FParentColor write SetParentColor;
    property ParentFont;
    property ParentShowHint;
    property PopupMenu;
    property ShowHint;
    property Visible;
    property OnClick;
    property OnDblClick;
    property OnMouseDown;
    property OnMouseMove;
    property OnMouseUp;
  end;

procedure Register;

implementation

constructor TColorButton.Create(AOwner: TComponent);
begin
  inherited Create(AOwner);
  FColor := clSilver;
  FFont := TFont.Create;
  FFont.Assign(Canvas.Font);
  TabStop := True;
  FWidthTop := 2;
  FWidthDown := 4;
  Width := 75;
  Height := 25;
  FGlyph := TBitmap.Create;
  FParentColor := False;
  FBitmap := TBitmap.Create;
end;

destructor TColorButton.Destroy;
begin
  FFont.Free;
  FGlyph.Free;
  FBitmap.Free;
  inherited Destroy;
end;

procedure TColorButton.SetGlyph(Value: TBitmap);
begin
  FGlyph.Assign(Value);
  Invalidate;
end;

procedure TColorButton.SetParentColor(AParentColor: boolean);
begin
  FParentColor := AParentColor;
  Paint;
end;

const
  BORDER_FOCUS = 4;

procedure TColorButton.Paint;
var
  i: integer;
begin
  FBitmap.Width:=Width;
  FBitmap.Height:=Height;
  with FBitmap.Canvas do
  begin
    Font.Assign(FFont);
    if FParentColor=False then
      Brush.Color := FColor
    else
      Brush.Color := Parent.Brush.Color;
    FBitmap.Canvas.FillRect(ClientRect);
    if Focused then
    begin
      //external border
      Pen.Style := psSolid;
Pen.Color := clWhite;
      Pen.Width := 1;
   FBitmap.Canvas.MoveTo(1,1);
     FBitmap.Canvas.LineTo(Width-3,1);
FBitmap.Canvas.MoveTo(1,1);
   FBitmap.Canvas.LineTo(1,Height-1);
      Pen.Style := psSolid;
      Pen.Width := FWidthTop;
Pen.Color := clBlack;
   FBitmap.Canvas.MoveTo(0,0);
     FBitmap.Canvas.LineTo(Width,0);
FBitmap.Canvas.MoveTo(0,0);
   FBitmap.Canvas.LineTo(0,Height);
      Pen.Width := FWidthDown;
FBitmap.Canvas.MoveTo(0,Height);
   FBitmap.Canvas.LineTo(Width,Height);
     FBitmap.Canvas.MoveTo(Width,0);
FBitmap.Canvas.LineTo(Width,Height);
      //internal line
Pen.Color := clBlack;
      Pen.Width := 1;
      Pen.Style := psSolid;
      for i:=BORDER_FOCUS to Width-BORDER_FOCUS do
      begin
FBitmap.Canvas.MoveTo(i,BORDER_FOCUS);
      if (i mod 2)=0 then
        FBitmap.Canvas.LineTo(i+1,BORDER_FOCUS);
      end;
      for i:=BORDER_FOCUS to Height-BORDER_FOCUS do
      begin
FBitmap.Canvas.MoveTo(BORDER_FOCUS,i);
      if (i mod 2)=0 then
        FBitmap.Canvas.LineTo(BORDER_FOCUS,i+1);
      end;
      for i:=BORDER_FOCUS to Width-BORDER_FOCUS do
      begin
FBitmap.Canvas.MoveTo(i,Height-BORDER_FOCUS);
      if (i mod 2)=0 then
        FBitmap.Canvas.LineTo(i+1,Height-BORDER_FOCUS);
      end;
      for i:=BORDER_FOCUS to Height-BORDER_FOCUS do
      begin
FBitmap.Canvas.MoveTo(Width-BORDER_FOCUS,i);
      if (i mod 2)=0 then
        FBitmap.Canvas.LineTo(Width-BORDER_FOCUS,i+1);
      end;
    end
    else
    begin
      Pen.Width := 2;
Pen.Color := clWhite;
   FBitmap.Canvas.MoveTo(0,0);
     FBitmap.Canvas.LineTo(Width,0);
FBitmap.Canvas.MoveTo(0,0);
   FBitmap.Canvas.LineTo(0,Height);
     Pen.Color := clBlack;
      Pen.Width := 4;
FBitmap.Canvas.MoveTo(0,Height);
   FBitmap.Canvas.LineTo(Width,Height);
     FBitmap.Canvas.MoveTo(Width,0);
FBitmap.Canvas.LineTo(Width,Height);
    end;
    Brush.Style := bsClear;
    FGlyph.Transparent := True;
    if (FGlyph.Width<>0) and (FCaption<>'') then
    begin
      FBitmap.Canvas.TextOut((width - TextWidth(FCaption) - FGlyph.Width) div 2 + FGlyph.Width + 5, (height - TextHeight(FCaption)) div 2 , FCaption);
      FBitmap.Canvas.Draw((width - TextWidth(FCaption) - FGlyph.Width) div 2, (height - FGlyph.Height) div 2,FGlyph);
    end
    else
    if FGlyph.Width=0 then
    begin
      FBitmap.Canvas.TextOut((width - TextWidth(FCaption)) div 2, (height - TextHeight(FCaption)) div 2 , FCaption);
    end
    else
    begin
      FBitmap.Canvas.Draw((width - FGlyph.Width) div 2, (height - FGlyph.Height) div 2,FGlyph);
    end;
  end;
  Canvas.Draw(0,0,FBitmap);
end;

procedure TColorButton.SetCaption(Value: string);
begin
  FCaption := Value;
  Paint;
end;

procedure TColorButton.SetFont(Value: TFont);
begin
  FFont.Assign(Value);
  Paint;
end;

procedure TColorButton.SetColor(Value: TColor);
begin
  FColor := Value;
  Paint;
end;

procedure TColorButton.DoExit;
begin
  Paint;
end;

procedure TColorButton.DoEnter;
begin
  Paint;
end;

procedure TColorButton.MouseDown(Button: TMouseButton; Shift: TShiftState; X, Y: Integer);
begin
  FWidthTop := 4;
  FWidthDown := 2;
  SetFocus;
  Paint;
end;

procedure TColorButton.MouseUp(Button: TMouseButton; Shift: TShiftState; X, Y: Integer);
begin
  FWidthTop := 2;
  FWidthDown := 4;
  Paint;
end;

procedure TColorButton.Click;
begin
  inherited;
end;

procedure TColorButton.KeyPress(var Key: Char);
begin
  FWidthTop := 4;
  FWidthDown := 2;
  Paint;
  if (Key=#13) or (Key=' ') then
     Click;
  FWidthTop := 2;
  FWidthDown := 4;
  Paint;
end;

constructor TColorSpeedButton.Create(AOwner: TComponent);
begin
  inherited Create(AOwner);
  FColor := clSilver;
  FFont := TFont.Create;
  FFont.Assign(Canvas.Font);
FTopColor := clWhite;
  FBottomColor := clBlack;
  Width := 22;
  Height := 22;
  FGlyph := TBitmap.Create;
  ParentFont := True;
  FCaption := '';
  FParentColor := False;
  FBitmap := TBitmap.Create;
end;

destructor TColorSpeedButton.Destroy;
begin
  FFont.Free;
  FGlyph.Free;
  FBitmap.Free;
  inherited Destroy;
end;

procedure TColorSpeedButton.SetGlyph(Value: TBitmap);
begin
  FGlyph.Assign(Value);
  Invalidate;
end;

procedure TColorSpeedButton.Paint;
begin
  FBitmap.Width:=Width; {Ajustamos nuestro bitmap}
  FBitmap.Height:=Height;
  with FBitmap.Canvas do
  begin
    Font.Assign(FFont);
    if FParentColor=False then
      Brush.Color := FColor
    else
      Brush.Color := Parent.Brush.Color;
    FBitmap.Canvas.FillRect(ClientRect);
    Pen.Width := 2;
    Pen.Color := FTopColor;
  FBitmap.Canvas.MoveTo(0,0);
    FBitmap.Canvas.LineTo(Width,0);
    FBitmap.Canvas.MoveTo(0,0);
  FBitmap.Canvas.LineTo(0,Height);
    Pen.Color := FBottomColor;
    Pen.Width := 4;
    FBitmap.Canvas.MoveTo(0,Height);
  FBitmap.Canvas.LineTo(Width,Height);
    FBitmap.Canvas.MoveTo(Width,0);
    FBitmap.Canvas.LineTo(Width,Height);
    FGlyph.Transparent := True;
    if (FGlyph.Width<>0) and (FCaption<>'') then
    begin
      FBitmap.Canvas.TextOut((width - TextWidth(FCaption) - FGlyph.Width) div 2 + FGlyph.Width + 5, (height - TextHeight(FCaption)) div 2 , FCaption);
      FBitmap.Canvas.Draw((width - TextWidth(FCaption) - FGlyph.Width) div 2, (height - FGlyph.Height) div 2,FGlyph);
    end
    else
    if FGlyph.Width=0 then
    begin
      FBitmap.Canvas.TextOut((width - TextWidth(FCaption)) div 2, (height - TextHeight(FCaption)) div 2 , FCaption);
    end
    else
    begin
      FBitmap.Canvas.Draw((width - FGlyph.Width) div 2, (height - FGlyph.Height) div 2,FGlyph);
    end;
  end;
  Canvas.Draw(0,0,FBitmap);
end;

procedure TColorSpeedButton.SetCaption(Value: string);
begin
  FCaption := Value;
  Paint;
end;

procedure TColorSpeedButton.SetFont(Value: TFont);
begin
  FFont.Assign(Value);
  Paint;
end;

procedure TColorSpeedButton.SetColor(Value: TColor);
begin
  FColor := Value;
  Paint;
end;

procedure TColorSpeedButton.SetParentColor(AParentColor: boolean);
begin
  FParentColor := AParentColor;
  Paint;
end;

procedure TColorSpeedButton.MouseDown(Button: TMouseButton; Shift: TShiftState; X, Y: Integer);
begin
  FTopColor := clBlack;
  FBottomColor := clWhite;
  Paint;
end;

procedure TColorSpeedButton.MouseUp(Button: TMouseButton; Shift: TShiftState; X, Y: Integer);
begin
  FTopColor := clWhite;
  FBottomColor := clBlack;
  Paint;
end;

procedure Register;
begin
  RegisterComponents('Components Delphi', [TColorButton]);
  RegisterComponents('Components Delphi', [TColorSpeedButton]);
end;

end.

La propietat Color fa que el botó canvïi de color.

# posted by jpuigpelat : 12:13 AM  0 comments

WinLinks

Aquest component incorpora una sèrie de mètodes que ens permeten crear accesos directes a l'aplicació que el conté.

unit WinLinks;

interface

uses
  Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
  ShlObj, ActiveX, ComObj;

const
  CSIDL_DESKTOP = 0;
  CSIDL_PROGRAMS = 2;
  CSIDL_STARTUP = 7;
  CSIDL_STARTMENU = 11;

type
  TWinLinks = class(TComponent)
  private
    { Private declarations }
    Path: string;
    Handle: HWnd;
    function CreateLink(appname: string; apppath: string): boolean;
  protected
    { Protected declarations }
    procedure CreateLinkType(linktype: integer);
  public
    { Public declarations }
    procedure CreateDesktopLink;
    procedure CreateStartMenuLink;
    procedure CreateStartUpLink;
    procedure CreateProgramsLink;
  published
    { Published declarations }
  end;

procedure Register;

function SHGetSpecialFolderPath(Handle: HWND; Path: PChar; Folder: Integer; Create: Bool): HRESULT; StdCall;

implementation

function SHGetSpecialFolderPath; External 'Shell32.DLL' Name 'SHGetSpecialFolderPathA';

function TWinLinks.CreateLink(appname: string; apppath: string): boolean;
var
  IShellLinkInterface: IShellLink;
  IPersistFileInterface: IPersistFile;
  ResultCode: HResult;
  WidePath: Array[0..1024] Of WideChar;
begin

  apppath := PChar(apppath);
  
  IShellLinkInterface := IShellLink(CreateCOMObject(CLSID_ShellLink));
  With IShellLinkInterface Do
  begin
    SetPath(pchar(appname));
    SetDescription(PChar(ChangeFileExt(ExtractFileName(appname),'')));
  end;

  StringToWideChar(apppath+'\'+ChangeFileExt(ExtractFileName(appname),'.lnk'), WidePath, 1024);
  ResultCode := IShellLinkInterface.QueryInterface(IPersistFile, IPersistFileInterface);

  If ResultCode <> S_OK Then // Si no fue posible
  begin
    Result := False;
    Exit;
  end;

  ResultCode := IPersistFileInterface.Save(WidePath, True);

end;

procedure TWinLinks.CreateLinkType(linktype: integer);
begin
  SetLength(Path, MAX_PATH+1);
  SHGetSpecialFolderPath(Handle, PChar(Path), linktype, False);
  CreateLink(Application.ExeName,Path);
end;

procedure TWinLinks.CreateDesktopLink;
begin
  CreateLinkType(CSIDL_DESKTOP);
end;

procedure TWinLinks.CreateStartMenuLink;
begin
  CreateLinkType(CSIDL_STARTMENU);
end;

procedure TWinLinks.CreateStartUpLink;
begin
  CreateLinkType(CSIDL_STARTUP);
end;

procedure TWinLinks.CreateProgramsLink;
begin
  CreateLinkType(CSIDL_PROGRAMS);
end;

procedure Register;
begin
  RegisterComponents('Components Delphi', [TWinLinks]);
end;

end.

Els mètodes són CreateDesktopLink, CreateStartMenuLink, CreateStartUpLink i CreateProgramsLink, que ens permeten crear respectivament un accés directe a l'escriptori, al menú Inici, al menú que fa que l'aplicació s'inicïi amb windows i a la secció programes del menú Inici.

FloatEdit

Caixa d'edició que només permet l'entrada de números reals.

unit FloatEdit;

interface

uses
  Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
  StdCtrls, DsgnIntf, ShellAPI;

type TFloatEditEd = class(TDefaultEditor)
  procedure ExecuteVerb(Index: integer); override;
  function GetVerb(Index: integer): string; override;
  function GetVerbCount: integer; override;
  end;

type
  TFloatEdit = class(TCustomEdit)
  private
    { Private declarations }
    FAlignment: TAlignment;
    FValue: double;
    lDelPressed: boolean;
    FVersion: string;
    FMaxIntValue: integer;
    FPrecission: integer;
    FSeparator: char;
    procedure SetAlignment(AAlignment: TAlignment);
    function GetValue: double;
    procedure SetValue(iNewVal: double);
    function GetAsFloat: double;
    procedure SetAsFloat(lnVal: double);
    function GetAsString: string;
    procedure SetAsString(strVal: string);
    procedure SetVersion(strVersion: string);
    procedure CMEnter(var Message: TCMEnter); message CM_ENTER;
  protected
    { Protected declarations }
    procedure KeyPress(var Key: Char); override;
    procedure KeyDown(var Key: Word; Shift: TShiftState); override;
    procedure KeyUp(var Key: Word; Shift: TShiftState); override;
    procedure CreateParams(var Params: TCreateParams); override;
  public
    { Public declarations }
    constructor Create(AOwner: TComponent); override;
    property AsFloat: double read GetAsFloat write SetAsFloat;
    property AsString: string read GetAsString write SetAsString;
  published
    { Published declarations }
    property MaxIntValue: integer read FMaxIntValue write FMaxIntValue;
    property Precission: integer read FPrecission write FPrecission;
    property Value: double read GetValue write SetValue;
    property Alignment: TAlignment read FAlignment write SetAlignment default taRightJustify;
    property Anchors;
    property AutoSelect;
    property AutoSize default True;
    property BorderStyle;
    property Color;
    property Ctl3D;
    property DragCursor;
    property DragMode;
    property Enabled;
    property Font;
    property HideSelection;
    property ParentColor;
    property ParentCtl3D;
    property ParentFont;
    property ParentShowHint;
    property PopupMenu;
    property ReadOnly;
    property ShowHint;
    property TabOrder;
    property Visible;
    (* General events properties *)
    property OnChange;
    property OnClick;
    property OnDblClick;
    property OnDragDrop;
    property OnDragOver;
    property OnEndDrag;
    property OnEnter;
    property OnExit;
    property OnKeyDown;
    property OnKeyPress;
    property OnKeyUp;
    property OnMouseDown;
    property OnMouseMove;
    property OnMouseUp;
    property Version: string read FVersion write SetVersion;
  end;

procedure Register;

implementation

procedure Register;
begin
  RegisterComponents('Components Delphi', [TFloatEdit]);
end;

constructor TFloatEdit.Create(AOwner: TComponent);
begin
  inherited Create(AOwner);
  FAlignment := taRightJustify;
  FValue := 0;
  Text := '0';
  FSeparator := ',';
  FMaxIntValue := 2147483647;
  FPrecission := 2;
  lDelPressed := False;
  FVersion := '1.1';
end;

procedure TFloatEdit.SetAlignment(AAlignment: TAlignment);
begin
  if FAlignment <> AAlignment then
  begin
    FAlignment := AAlignment;
    if not (csDesigning in ComponentState) then
      RecreateWnd;
    if Focused then
      SelectAll;
  end;
end;

function TFloatEdit.GetValue: double;
begin
  Result := FValue;
end;

procedure TFloatEdit.SetValue(iNewVal: double);
begin
    Text := FloatToStr(iNewVal);
    FValue := iNewVal;
    if Focused then
    begin
      SelStart := Length(Text);
      SelectAll;
    end;
end;

procedure TFloatEdit.SetAsFloat(lnVal: double);
begin
  Value := lnVal;
end;

function TFloatEdit.GetAsFloat: double;
begin
  Result := Value;
end;

procedure TFloatEdit.SetAsString(strVal: string);
begin
  Value := StrToFloat(strVal);
end;

function TFloatEdit.GetAsString: string;
begin
  Result := FloatToStr(Value);
end;

procedure TFloatEdit.KeyPress(var Key: Char);
begin
  if not (Key in [#27, '0'..'9', #8, ',']) then begin
    Key := #0;
    MessageBeep(0);
    Exit;
  end
  else if (Key in ['0'..'9']) then
  begin
    if (Length(Copy(Text,Pos(',',Text)+1,Length(Text)-Pos(',',Text)+1))>FPrecission-1) and (Pos(',',Text)<>0) then
    begin
      Key := #0;
      MessageBeep(0);
      Exit;
    end
    else if Int(StrToFloat(Text+key))>FMaxIntValue then
    begin
      Key := #0;
      MessageBeep(0);
      Exit;
    end;
  end;
  inherited;
end;

procedure TFloatEdit.KeyDown(var Key: Word; Shift: TShiftState);
begin
  ClearSelection;
  inherited KeyDown(Key,Shift);
end;

procedure TFloatEdit.KeyUp(var Key: Word; Shift: TShiftState);
begin
  inherited KeyUp(Key,Shift);
  if Text='' then
  begin
    Text := '0';
    SelStart := Length(Text);
    SelectAll;
  end;
  FValue := StrToFloat(Text);
end;

procedure TFloatEdit.CreateParams(var Params: TCreateParams);
var
{$ifdef VER120}
  lnStyle: LongWord;
{$else}
  lnStyle: LongInt;
{$endif}
begin
  inherited CreateParams(Params);
  case Alignment of
    taLeftJustify:
      lnStyle := ES_LEFT;
    taRightJustify:
      lnStyle := ES_RIGHT
    else
      lnStyle := ES_CENTER;
  end (*case*);
  with Params do
    Style := Style or DWORD(lnStyle);
end;

procedure TFloatEdit.SetVersion(strVersion: string);
begin

end;

procedure TFloatEdit.CMEnter(var Message: TCMEnter);
begin
  if AutoSelect and not ReadOnly then
    SelectAll
  else
    if not ReadOnly then
    begin
      SelStart := Length(Text);
    end (*if*);
  Refresh;
  inherited;
end;

end.

La propietat Value conté el número introduït. MaxIntValue conté el màxim valor enter que és possible introduïr. Amb Precission determinem el màxim número de decimals permesos. Alignment permet alinear el text a la dreta o a l'esquerra.

SytemInfo

Mostra algunes propietats de sistema operatiu.

unit SystemInfo;

interface

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

type
  TSystemInfo = class(TComponent)
  private
    { Private declarations }
    FShortDate: string;
    FLongDate: string;
    FTime: string;
    FComputerName: string;
    FUserName: string;
    FCDRomDrive: string;
    function GetFirstCdRomDrive: string;
  protected
    { Protected declarations }
  public
    { Public declarations }
    constructor Create(AOwner:TComponent); override;
  published
    { Published declarations }
    property ShortDate: string read FShortDate write FShortDate;
    property LongDate: string read FLongDate write FLongDate;
    property Time: string read FTime write FTime;
    property ComputerName: string read FComputerName write FComputerName;
    property UserName: string read FUserName write FUserName;
    property CDRomDrive: string read FCDRomDrive write FCDRomDrive;
  end;

procedure Register;

implementation

function TSystemInfo.GetFirstCdRomDrive: string;
var
  r: LongWord;
  Unidades: array[0..128] of char;
  pUnidad: pchar;
begin
  Result := '';
  r := GetLogicalDriveStrings(sizeof(Unidades), Unidades);
  if r = 0 then exit;
  if r > sizeof(Unidades) then
    raise Exception.Create(SysErrorMessage(ERROR_OUTOFMEMORY));
  pUnidad := Unidades; // Apunta a la primera unidad
  while pUnidad^ <> #0 do begin
    if GetDriveType(pUnidad) = DRIVE_CDROM then begin
      Result := pUnidad;
      exit;
    end;
    inc(pUnidad, 4); // Apunta a la siguiente unidad
  end;
end;

constructor TSystemInfo.Create(AOwner:TComponent);
var
  Buf: array[0..99] of char;
  size: dword;
begin
  inherited;
  GetLocaleInfo(LOCALE_USER_DEFAULT,LOCALE_SSHORTDATE,@Buf,100);
  FShortDate := Buf;
  GetLocaleInfo(LOCALE_USER_DEFAULT,LOCALE_SLONGDATE,@Buf,100);
  FLongDate := Buf;
  GetLocaleInfo(LOCALE_USER_DEFAULT,LOCALE_STIMEFORMAT,@Buf,100);
  FTime := Buf;
  size := 100;
  GetComputerName(Buf, size);
  FComputerName := Buf;
  GetUserName(Buf, size);
  FUserName := Buf;
  FCDRomDrive := GetFirstCdRomDrive;
end;

procedure Register;
begin
  RegisterComponents('Components Delphi', [TSystemInfo]);
end;

end.
 
La propietat CDRomDrive ens indica la unitat del CD. ComputerName ens dona el nom de la màquina. LongData i ShortDate els formats de data del sistam. Time el format de temps del sistema. Finalment, User, l'usuari actual del sistema operatiu. Lògicament es poden anar afegint tantes propietats com es vulgui per obtenir dades del sistema.

BlinkingLabel

Descendent del TLabel que canvia de color intermitentment

unit BlinkingLabel;

interface

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

type
  TBlinkingLabel = class(TCustomLabel)
  private
    { Private declarations }
    Timer: TTimer;
    FBlinkingEnabled: boolean;
    FBlinkingInterval: integer;
    FBlinkingFirstColor: TColor;
    FBlinkingSecondColor: TColor;
    procedure RefreshLabel;
  protected
    { Protected declarations }
    procedure SetBlinkingEnabled(ABlinkingEnabled: boolean);
    procedure SetBlinkingInterval(ABlinkingInterval: integer);
    procedure OnTimer(Sender: TObject); virtual;
  public
    { Public declarations }
    constructor Create(AOwner: TComponent); override;
    destructor Destroy; override;
  published
    { Published declarations }
    property BlinkingEnabled: boolean read FBlinkingEnabled write SetBlinkingEnabled default True;
    property BlinkingInterval: integer read FBlinkingInterval write SetBlinkingInterval default 500;
    property BlinkingFirstColor: TColor read FBlinkingFirstColor write FBlinkingFirstColor;
    property BlinkingSecondColor: TColor read FBlinkingSecondColor write FBlinkingSecondColor;
    property Align;
    property Alignment;
    property Anchors;
    property AutoSize;
    property BiDiMode;
    property Caption;
    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 Transparent;
    property Layout;
    property WordWrap;
    property Visible;
    property OnClick;
    property OnDblClick;
    property OnDragOver;
    property OnDragDrop;
    property OnEndDock;
    property OnEndDrag;
    property OnMouseDown;
    property OnMouseUp;
    property OnStartDock;
    property OnStartDrag;
  end;

procedure Register;

implementation

constructor TBlinkingLabel.Create(AOwner: TComponent);
begin
  FBlinkingEnabled := False;
  FBlinkingInterval := 500;
  FBlinkingFirstColor := clBlue;
  FBlinkingSecondColor := clRed;
  Timer := TTimer.Create(Self);
  Timer.Enabled := FBlinkingEnabled;
  Timer.Interval := FBlinkingInterval;
  Timer.OnTimer := OnTimer;
  inherited;
  RefreshLabel;
end;

destructor TBlinkingLabel.Destroy;
begin
  Timer.Free;
  inherited;
end;

procedure TBlinkingLabel.SetBlinkingEnabled(ABlinkingEnabled: boolean);
begin
  FBlinkingEnabled := ABlinkingEnabled;
  Timer.Enabled := ABlinkingEnabled;
end;

procedure TBlinkingLabel.SetBlinkingInterval(ABlinkingInterval: integer);
begin
  FBlinkingInterval := ABlinkingInterval;
  Timer.Interval := ABlinkingInterval;
end;

procedure TBlinkingLabel.OnTimer(Sender: TObject);
begin
  RefreshLabel;
end;

procedure TBlinkingLabel.RefreshLabel;
begin
  if Font.Color=FBlinkingFirstColor then
    Font.Color := FBlinkingSecondColor
  else
    Font.Color := FBlinkingFirstColor;
end;

procedure Register;
begin
  RegisterComponents('Components Delphi', [TBlinkingLabel]);
end;

end.

Les propietats BlinkingFirstColor i BlinkingSecondColor indiquen els dos colors entre els quals s'alterna. La propietat BlinkingInterval indica el període de canvi en milisegons. Amb la propietat BlinkingEnabled activem o desactivem el canvi.

FormMemoryReg

Guarda en el registre la posició i tamany del formulari, per recuperar-les al tornar-lo a crear.

unit FormMemoryReg;

interface

uses
  Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
  Registry, Menus;

type
  //save dimensions by form name
  TFormMemoryReg = class(TComponent)
  private
    { Private declarations }
    RegIniFile: TRegIniFile;
    FOwner: TForm;
    AN: string;
  protected
    { Protected declarations }
  public
    { Public declarations }
    constructor Create(AOwner: TComponent); override;
    destructor Destroy; override;
    procedure Loaded; override;
  published
    { Published declarations }
  end;

procedure Register;

implementation

constructor TFormMemoryReg.Create(AOwner: TComponent);
var
  filename: string;
  fl: TStringList;
begin
  inherited Create(AOwner);
  FOwner := TForm(AOwner);
end;

procedure TFormMemoryReg.Loaded;
var
  fl: TStringList;
begin
  inherited Loaded;
  AN := ExtractFileName(Application.ExeName);
  AN := ChangeFileExt(AN,'');
  if not (csDesigning in ComponentState) then
  begin
    RegIniFile := TRegIniFile.Create('');
    RegIniFile.RootKey := HKey_Local_Machine;
    if not RegIniFile.OpenKey('Software\CompDelphi\'+AN+'\FormsMem',False) then
    begin
      RegIniFile.CreateKey('Software\CompDelphi\'+AN+'\FormsMem');
    end;
    FOwner.Top := RegIniFile.ReadInteger('',FOwner.Name+'t',FOwner.Top);
    FOwner.Left := RegIniFile.ReadInteger('',FOwner.Name+'l',FOwner.Left);
    FOwner.Height := RegIniFile.ReadInteger('',FOwner.Name+'h',FOwner.Height);
    FOwner.Width := RegIniFile.ReadInteger('',FOwner.Name+'w',FOwner.Width);
    RegIniFile.Free;
  end;

end;

destructor TFormMemoryReg.Destroy;
begin
  if not (csDesigning in ComponentState) then
  begin
    if FOwner.WindowState=wsNormal then
    begin
      RegIniFile := TRegIniFile.Create('');
      RegIniFile.RootKey := HKey_Local_Machine;
      RegIniFile.OpenKey('Software\CompDelphi\'+AN+'\FormsMem',False);
      RegIniFile.WriteInteger('',FOwner.Name+'t',FOwner.Top);
      RegIniFile.WriteInteger('',FOwner.Name+'w',FOwner.Width);
      RegIniFile.WriteInteger('',FOwner.Name+'l',FOwner.Left);
      RegIniFile.WriteInteger('',FOwner.Name+'h',FOwner.Height) ;
    end;
    RegIniFile.Free;
  end;
  inherited;
end;

procedure Register;
begin
  RegisterComponents('Components Delphi', [TFormMemoryReg]);
end;

end.

Clock

Aquest component hereta les propietats de TCustomLabel per mostrar en el Caption l'hora i la data.

unit Clock;

interface

uses
  Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
  StdCtrls, ExtCtrls, DsgnIntf, ShellAPI;

type
  TClock = class(TCustomLabel)
  private
    { Private declarations }
    Timer: TTimer;
    FClockEnabled: boolean;
    FHour: Word;
    FMinute: Word;
    FSecond: Word;
    FMSecond: Word;
    FYear: Word;
    FMonth: Word;
    FDay: Word;
    FShowSeconds: boolean;
    FShowDate: boolean;
    FShowTime: boolean;
    FTime: string;
    FDate: string;
    procedure RefreshDate;
protected
    { Protected declarations }
    procedure SetClockEnabled(AClockEnabled: boolean);
    procedure SetShowSeconds(AShowSeconds: boolean);
    procedure SetShowTime(AShowTime: boolean);
    procedure SetShowDate(AShowDate: boolean);
    procedure OnTimer(Sender: TObject); virtual;
  public
    { Public declarations }
    constructor Create(AOwner: TComponent); override;
    destructor Destroy; override;
  published
    { Published declarations }
    property ClockEnabled: boolean read FClockEnabled write SetClockEnabled default True;
    property ShowSeconds: boolean read FShowSeconds write SetShowSeconds default True;
    property ShowTime: boolean read FShowTime write SetShowTime default True;
    property ShowDate: boolean read FShowDate write SetShowDate default True;
    property Align;
    property Alignment;
    property Anchors;
    property AutoSize;
    property BiDiMode;
    property Caption;
    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 Transparent;
    property Layout;
    property WordWrap;
    property Visible;
    property OnClick;
    property OnDblClick;
    property OnDragOver;
    property OnDragDrop;
    property OnEndDock;
    property OnEndDrag;
    property OnMouseDown;
    property OnMouseUp;
    property OnStartDock;
    property OnStartDrag;
  end;

procedure Register;

implementation

constructor TClock.Create(AOwner: TComponent);
begin
  FClockEnabled := True;
  FShowSeconds := True;
  FShowTime := True;
  FShowDate := True;
  Timer := TTimer.Create(Self);
  Timer.Enabled := FClockEnabled;
  Timer.Interval := 1000;
  Timer.OnTimer := OnTimer;
  inherited;
  RefreshDate;
end;

destructor TClock.Destroy;
begin
  Timer.Free;
  inherited;
end;

procedure TClock.SetClockEnabled(AClockEnabled: boolean);
begin
  FClockEnabled := AClockEnabled;
  Timer.Enabled := AClockEnabled;
end;

procedure TClock.SetShowSeconds(AShowSeconds: boolean);
begin
  FShowSeconds := AShowSeconds;
  if FShowSeconds then
  begin
    FTime := Format('%.2d',[FHour])+':'+Format('%.2d',[FMinute])+':'+Format('%.2d',[FSecond]);
    Timer.Interval := 1000;
  end
  else
  begin
    FTime := Format('%.2d',[FHour])+':'+Format('%.2d',[FMinute]);
    Timer.Interval := 60000;
  end;
  Caption := FTime + ' ' + FDate;
end;

procedure TClock.SetShowTime(AShowTime: boolean);
begin
  FShowTime := AShowTime;
  if FShowTime then
  begin
    if FShowSeconds then
    begin
      FTime := Format('%.2d',[FHour])+':'+Format('%.2d',[FMinute])+':'+Format('%.2d',[FSecond]);
    end
    else
    begin
      FTime := Format('%.2d',[FHour])+':'+Format('%.2d',[FMinute]);
    end;
  end
  else
  begin
    FTime := '';
  end;
  Caption := FTime + ' ' + FDate;
end;

procedure TClock.SetShowDate(AShowDate: boolean);
begin
  FShowDate := AShowDate;
  if FShowDate then
  begin
    FDate := Format('%.2d',[FDay])+'/'+Format('%.2d',[FMonth])+'/'+Format('%.4d',[FYear]);
  end
  else
  begin
    FDate := '';
  end;
  Caption := FTime + ' ' + FDate;
end;

procedure TClock.OnTimer(Sender: TObject);
begin
  RefreshDate;
end;

procedure TClock.RefreshDate;
begin
  DecodeTime(Time,FHour,FMinute,FSecond,FMSecond);
  DecodeDate(Date,FYear,FMonth,FDay);
  //seconds
  if FShowSeconds then
  begin
    FTime := Format('%.2d',[FHour])+':'+Format('%.2d',[FMinute])+':'+Format('%.2d',[FSecond]);
    Timer.Interval := 1000;
  end
  else
  begin
    FTime := Format('%.2d',[FHour])+':'+Format('%.2d',[FMinute]);
    Timer.Interval := 60000;
  end;
  //time
  if FShowTime then
  begin
    if FShowSeconds then
    begin
      FTime := Format('%.2d',[FHour])+':'+Format('%.2d',[FMinute])+':'+Format('%.2d',[FSecond]);
    end
    else
    begin
      FTime := Format('%.2d',[FHour])+':'+Format('%.2d',[FMinute]);
    end;
  end
  else
  begin
    FTime := '';
  end;
  //date
  if FShowDate then
  begin
    FDate := Format('%.2d',[FDay])+'/'+Format('%.2d',[FMonth])+'/'+Format('%.4d',[FYear]);
  end
  else
  begin
    FDate := '';
  end;
  Caption := FTime + ' ' + FDate;
end;

procedure Register;
begin
  RegisterComponents('Components Delphi', [TClock]);
end;

end.

La propietat ClockEnabled activa i desactiva l'actualització de data i hora. La propietat ShowSeconds ens permet mostrar o ocultar els segons. Les propietats ShowTime i ShowDate, fan, respectivamente, el mateix amb l'hora i la data.

LogFile

Permet generar traces amb informació durant l'execució d'un programa.

unit LogFile;

interface

uses Windows, Classes, SysUtils, DsgnIntf, ShellAPI, Forms;


type TLogFileEd = class(TDefaultEditor)
  procedure ExecuteVerb(Index: integer); override;
  function GetVerb(Index: integer): string; override;
  function GetVerbCount: integer; override;
  end;

type TLogFile = class(TComponent)
  private
    FFileName: string;
    FFileStream: TFileStream;
    FSaveDate: boolean;
    FSaveHour: boolean;
    FActive: boolean;
    FLineHeader: string;
    FDailyFileName: boolean; //adds yyyymmdd before filename
    FCurrentDay: string;
  public
    constructor Create(AOwner: TComponent); override;
    destructor Destroy; override;
    procedure SaveToFile(str: string);
    procedure Delete;
  published
    property Active: boolean read FActive write FActive;
    property FileName: string read FFileName write FFileName;
    property SaveDate: boolean read FSaveDate write FSaveDate;
    property SaveHour: boolean read FSaveHour write FSaveHour;
    property DailyFileName: boolean read FDailyFileName write FDailyFileName;
    property LineHeader: string read FLineHeader write FLineHeader;
  end;

procedure Register;

implementation

procedure Register;
begin
  RegisterComponents('Components Delphi', [TLogFile]);
end;

constructor TLogFile.Create(AOwner: TComponent);
begin
  FFileName := 'noname.log';
  FSaveHour := True;
  FSaveDate := True;
  FActive := True;
  inherited Create(AOwner);
end;

destructor TLogFile.Destroy;
begin
  inherited Destroy;
end;

procedure TLogFile.Delete;
begin
  DeleteFile(FFileName);
end;

procedure TLogFile.SaveToFile(str: string);
var
  aux: string;
  y,m,d: word;
  fl: string;
begin
  if FActive=False then
    Exit;
  if FDailyFileName then
  begin
    DecodeDate(Now,y,m,d);
    FCurrentDay := Format('%.04d%.02d%.02d',[y,m,d]);
  end
  else
  begin
    FCurrentDay := '';
  end;
  fl := ExtractFilePath(FFileName)+FCurrentDay+ExtractFileName(FFileName);
  try
    FFileStream := TFileStream.Create(fl,fmOpenWrite);
  except
    try
      FFileStream := TFileStream.Create(fl,fmCreate);
    except
    end
  end;
  if (FSaveDate) and (FSaveHour) then
    aux := '<'+DateToStr(Date)+','+TimeToStr(Time)+'>'
  else
  if FSaveDate then
    aux := '<'+DateToStr(Date)+'>'
  else
  if FSaveHour then
    aux := '<'+TimeToStr(Time)+'>';
  aux := aux + #32 + FLineHeader + str + #13#10;
  try
    FFileStream.Seek(FFileStream.Size,soFromBeginning);
    FFileStream.Write(Pointer(aux)^, Length(aux));
  except
  end;
  FFileStream.Free;
end;

end.

Amb la propietat Active activem i desactivem la generació de traces. Les propietats SaveDate i SaveHour fan que en cada traça es guardi la data i l'hora respectivament de generació. A LineHeader podem posar un text que es generi a cada línea. Si activem DailyFileName, al nom del fitxer, FileName, s'afegeix la data del dia. Així, cada dia tenim un nom de fitxer difere nt. Finalment, una vegada tenim assignats a les propietats els valor que ens interessen, amb el métode SaveToFile, amb un text com a paràmetre, generem el text que volem que es guardi.