Programación

Esta sección estará dedicada a la programación en Delphi, versión 3. En ella trataré dos programas simples de utilidad, que son dos controladores del espacio libre en disco duro. La versión sencilla esta disponible directamente en esta Web, y la versión completa se encuentra sólo en código fuente. Con el tiempo añadiré más comentarios en castellano al código, ya que los actuales (por requerimientos varios) están en inglés. Volved cuando queráis.

Código fuente de DiskFree.pas, versión simple:

unit fmain;

interface

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

type
  TForm1 = class(TForm)
    Label1: TLabel;
    Timer1: TTimer;
    procedure FormCreate(Sender: TObject);
    procedure Timer1Timer(Sender: TObject);
  private
    { Private declarations }
  public
    { Public declarations }
  end;

var
  Form1: TForm1;

implementation

{$R *.DFM}

procedure TForm1.FormCreate(Sender: TObject);
begin
  Form1.Width  := Label1.Width;
  Form1.Height := 40;
end;

procedure TForm1.Timer1Timer(Sender: TObject);
begin
  Label1.Caption := 'Espacio libre C: '+
                    IntToStr(DiskFree(3)div 1024)+' k';
end;

end.

Código fuente de DiskFree.pas, versión completa:

unit fMain;

interface

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

{Revision History:
  v5.0   Final new release.
  v5.0a  Display fades to black when program exits added.
  v5.0b  Hint color changed to clLCDGreen and delay added
         before Application.Terminate.
  v5.0c  Display color selection Trackbar added. Remaining time
         bitmap removed, label positioned instead.
  v5.0d  Right click on program title minimizes the program temporarily.
  v5.0e  Harkonnen logo included. Shown with click on free KB labels.
  v5.0f  Timer1 time changed to 2 seconds.
  v5.01  btnDirectCount added.
  v5.01a Right click in program title slides down the form, instead
         of "minimizing" it.
  v5.02  Variable timer interval possible.
  v5.02a Time display on click behaviour changed.
  v5.02b Step inc/decrement changed to 128k for progressive swapfile size update.
  v5.03  Swap file check now can be disabled.
  v5.03a Program exiting bug fixed.
  v5.04  Button TimeClose added.
  v5.05  Auto windows minimizing after option selection added.
  v5.06  Drive buttons now are available through ALT+Drive letter.
  v5.06a No window size change then drive button is activated.
  v5.07  Changes label reset to 0 after 1 minute of no changes.
  v5.07a Changes label reset bug solved.
  v5.07b Changes label reset bug fixed, thousands dot added.
}
const
  APPNAME = 'DiskFree,v5.07';

type
  TfrmMain = class(TForm)
    pnlMain: TPanel;
    pnlBack: TPanel;
    lblTitle: TLabel;
    Timer1: TTimer;
    lblBlink: TLabel;
    lblFree: TLabel;
    lblChange: TLabel;
    lblDisk: TLabel;
    SpeedButton1: TSpeedButton;
    SpeedButton2: TSpeedButton;
    SpeedButton3: TSpeedButton;
    SpeedButton4: TSpeedButton;
    SpeedButton5: TSpeedButton;
    SpeedButton6: TSpeedButton;
    SpeedButton7: TSpeedButton;
    Shape1: TShape;
    btnExit: TSpeedButton;
    btnOnTop: TSpeedButton;
    lblSwap: TLabel;
    lblPlusMinus: TLabel;
    lblSwapSign: TLabel;
    lblFreeSign: TLabel;
    btnOptions: TSpeedButton;
    Timer2: TTimer;
    TrackBar1: TTrackBar;
    lblRemaining: TLabel;
    Image1: TImage;
    btnDirectCount: TSpeedButton;
    SpeedButton8: TSpeedButton;
    SpeedButton9: TSpeedButton;
    btnCheckSwap: TSpeedButton;
    btnTimeClose: TSpeedButton;
    procedure Timer1Timer(Sender: TObject);
    procedure FormCreate(Sender: TObject);
    procedure lblTitleMouseDown(Sender: TObject; Button: TMouseButton;
      Shift: TShiftState; X, Y: Integer);
    procedure lblTitleMouseMove(Sender: TObject; Shift: TShiftState; X,
      Y: Integer);
    procedure lblTitleMouseUp(Sender: TObject; Button: TMouseButton;
      Shift: TShiftState; X, Y: Integer);
    procedure SpeedButton1Click(Sender: TObject);
    procedure SpeedButton2Click(Sender: TObject);
    procedure SpeedButton3Click(Sender: TObject);
    procedure SpeedButton4Click(Sender: TObject);
    procedure SpeedButton5Click(Sender: TObject);
    procedure SpeedButton6Click(Sender: TObject);
    procedure SpeedButton7Click(Sender: TObject);
    procedure btnExitClick(Sender: TObject);
    procedure btnOnTopClick(Sender: TObject);
    procedure btnOptionsClick(Sender: TObject);
    procedure Timer2Timer(Sender: TObject);
    procedure TrackBar1Change(Sender: TObject);
    procedure lblRemainingClick(Sender: TObject);
    procedure lblFreeClick(Sender: TObject);
    procedure btnDirectCountClick(Sender: TObject);
    procedure SpeedButton8Click(Sender: TObject);
    procedure SpeedButton9Click(Sender: TObject);
    procedure btnCheckSwapClick(Sender: TObject);
    procedure btnTimeCloseClick(Sender: TObject);
  private
    { Private declarations }
  public
    { Public declarations }
    procedure SaveOptions;
    procedure LoadOptions;
    procedure ResetChanges;
  end;

var
  frmMain    : TfrmMain;
  DISK2CHECK : Integer;
  TIME2CLOSE : Integer;
  NowFree,
  OldFree    : Integer;
  clLCDGreen : Integer;
  SwapFile   : Integer;
  OldSwap    : Integer;
  WinDir     : AnsiString;
  HasChanged : boolean;
  ChangeTime : Integer;
  ChangeVal  : Integer;
  {Form moving variables}
  MouseIniX,
  MouseIniY  : Integer;
  Pressed    : boolean;


implementation

{$R *.DFM}

procedure Delay(ms: Integer);
var
  Initial : Integer;
begin
  Initial := GetTickCount;
  while (GetTickCount-Initial) < ms do
    Application.ProcessMessages;
end;

procedure TfrmMain.ResetChanges;
var
  i          : Integer;
begin
  if ChangeVal > 0 then begin
    lblChange.Font.Color := clRed;
    for i := ChangeVal downto 0 do begin
      lblChange.Caption := FloatToStrF(i,ffNumber,8,0)+' k';
      Application.ProcessMessages;
    end;
    lblChange.Font.Color := clBlack;
    HasChanged := False;
  end;
  if ChangeVal < 0 then begin
    lblChange.Font.Color := clRed;
    for i := ChangeVal to 0 do begin
      lblChange.Caption := FloatToStrF(i,ffNumber,8,0)+' k';
      Application.ProcessMessages;
    end;
    lblChange.Font.Color := clBlack;
    HasChanged           := False;
    ChangeVal            := 0;
  end;
end;

procedure TfrmMain.SaveOptions;
var
  TheIni  : TIniFile;
  IniName : AnsiString;
begin
  IniName := ExtractFilePath(Application.ExeName)+'DiskFree.ini';
  TheIni  := TIniFile.Create(IniName);
  TheIni.WriteInteger('Coords','X',frmMain.Left);
  TheIni.WriteInteger('Coords','Y',frmMain.Top);
  TheIni.WriteInteger('Color','Display',TrackBar1.Position);
  TheIni.Free;
end;

procedure TfrmMain.LoadOptions;
var
  TheIni  : TIniFile;
  IniName : AnsiString;
begin
  IniName := ExtractFilePath(Application.ExeName)+'DiskFree.ini';
  TheIni  := TIniFile.Create(IniName);
  frmMain.Left := TheIni.ReadInteger('Coords','X',0);
  frmMain.Top  := TheIni.ReadInteger('Coords','Y',0);
  TrackBar1.Position := TheIni.ReadInteger('Color','Display',20);
  TrackBar1Change(Self); {Make color changes efective}
  TheIni.Free;
end;

function GetWindowsDir: AnsiString;
var
  sWindowsDir : string;
  iLen        : Integer;
begin
  SetLength(sWindowsDir, 255);
  iLen   := GetWindowsDirectory(PChar(sWindowsDir), 255);
  Result := Copy(sWindowsDir,1,iLen)+'\';
end;

procedure TfrmMain.Timer1Timer(Sender: TObject);
var
  Found : Integer;
  SRec  : TSearchRec;
begin
  {Make small disk icon blink}
  lblBlink.Visible := not lblBlink.Visible;

  {Update labels}
  NowFree          := DiskFree(DISK2CHECK) div 1024;
  if NowFree <> OldFree then begin
    lblChange.Caption := FloatToStrF(Nowfree-OldFree,ffNumber,8,0)+' k';
    if NowFree > OldFree then lblChange.Caption := '+'+lblChange.Caption;
    ChangeVal  := NowFree-OldFree;
    OldFree    := NowFree;
    HasChanged := True;
    ChangeTime := 0;
  end;
  lblFree.Caption  := FloatToStrF(Nowfree,ffNumber,8,0)+' k';

  {Check swapfile}
  if btnCheckSwap.Down then begin
    Found    := FindFirst(WinDir+'Win386.swp',faAnyFile,SRec);
    SwapFile := SRec.Size div 1024;
    FindClose(SRec);
  end;

  {Check time}
  if btnTimeClose.Down then begin
    if TIME2CLOSE > 0 then begin
      TIME2CLOSE    := TIME2CLOSE -1;
      lblRemaining.Caption := Copy('||||||||||||||||||||',1,TIME2CLOSE div 60)
    end;
    if TIME2CLOSE = 0 then btnExitClick(Self);
  end;

  {Do DirectCount if corresponding button activated}
  if btnDirectCount.Down then begin
    if Abs(SwapFile-OldSwap) < 8 then begin
      OldSwap := SwapFile;
      lblSwapSign.Caption := 'ó'; {Double left-right arrow}
    end;
    while SwapFile > OldSwap do begin
      OldSwap := OldSwap + 8;
      lblSwap.Caption := FloatToStrF(OldSwap,ffNumber,8,0)+' k';
      lblSwapSign.Caption := 'ñ'; {Up arrow}
      lblSwap.Update;
    end;
    while SwapFile < OldSwap do begin
      OldSwap := OldSwap - 8;
      lblSwap.Caption := FloatToStrF(OldSwap,ffNumber,8,0)+' k';
      lblSwapSign.Caption := 'ò'; {Down arrow}
      lblSwap.Update;
    end;
  end;

  {If after a minute there have been no changes on the disk space,
   reset Counter to 0}
  if HasChanged then Inc(ChangeTime);
  if ChangeTime = 60 then ResetChanges;
end;

procedure TfrmMain.FormCreate(Sender: TObject);
begin
  LoadOptions;
  pnlMain.Height    := 69;
  frmMain.Width     := pnlMain.Width;
  frmMain.Height    := pnlMain.Height;
  lblTitle.Caption  := APPNAME;
  DISK2CHECK        := 3;
  TIME2CLOSE        := 20*60;
  clLCDGreen        := $0000D0A2;
  NowFree           := DiskFree(DISK2CHECK) div 1024;
  OldFree           := DiskFree(DISK2CHECK) div 1024;
  WinDir            := GetWindowsDir;
  SwapFile          := 15000;
  OldSwap           := 15000;
  Application.Title := APPNAME;
  HasChanged        := False;
  ChangeTime        := 0;
  ChangeVal         := 0;
  {Init the form move variable}
  Pressed           := False;
end;

procedure TfrmMain.lblTitleMouseDown(Sender: TObject; Button: TMouseButton;
  Shift: TShiftState; X, Y: Integer);
var
  i,
  OldTop : Integer;
begin
  {Set initial values for window drag}
  if Shift = [ssLeft] then begin
    Pressed   := True;
    MouseIniX := X;
    MouseIniY := Y;
  end;

  {Slide the form off the screen during 6 seconds}
  if Shift = [ssRight] then begin
    OldTop := frmMain.Top;
    for i := OldTop to (OldTop+100) do frmMain.Top := i;
    Delay(6000);
    for i := (OldTop+100) downto OldTop do frmMain.Top := i;
  end;
end;

procedure TfrmMain.lblTitleMouseMove(Sender: TObject; Shift: TShiftState;
  X, Y: Integer);
begin
  {Move the form around if button is pressed} 
  if Pressed then begin
    frmMain.Left := frmMain.Left - MouseIniX + X;
    frmMain.Top  := frmMain.Top  - MouseIniY + Y;
  end;
end;

procedure TfrmMain.lblTitleMouseUp(Sender: TObject; Button: TMouseButton;
  Shift: TShiftState; X, Y: Integer);
begin
  {The mouse button is no longer pressed (for window drag)}
  Pressed := False;
end;

procedure TfrmMain.SpeedButton1Click(Sender: TObject);
begin
  DISK2CHECK      := 3;
  lblDisk.Caption := 'C:';
end;

procedure TfrmMain.SpeedButton2Click(Sender: TObject);
begin
  DISK2CHECK      := 4;
  lblDisk.Caption := 'D:';
end;

procedure TfrmMain.SpeedButton3Click(Sender: TObject);
begin
  DISK2CHECK      := 5;
  lblDisk.Caption := 'E:';
end;

procedure TfrmMain.SpeedButton4Click(Sender: TObject);
begin
  DISK2CHECK      := 6;
  lblDisk.Caption := 'F:';
end;

procedure TfrmMain.SpeedButton5Click(Sender: TObject);
begin
  DISK2CHECK      := 7;
  lblDisk.Caption := 'G:';
end;

procedure TfrmMain.SpeedButton6Click(Sender: TObject);
begin
  DISK2CHECK      := 8;
  lblDisk.Caption := 'H:';
end;

procedure TfrmMain.SpeedButton7Click(Sender: TObject);
begin
  DISK2CHECK      := 9;
  lblDisk.Caption := 'I:';
end;

procedure TfrmMain.btnExitClick(Sender: TObject);
var
  i,
  TheGray : Integer;
begin
  Timer1.Enabled := False;
  {Fade the display to black}
  for i := TrackBar1.Position downto 0 do begin
    TheGray                 := Trunc(6.4*i);
    pnlBack.Color           := RGB(Trunc(8.1*i),Trunc(10.4*i),0);
    lblBlink.Font.Color     := RGB(TheGray, TheGray, TheGray);
    lblPlusMinus.Font.Color := RGB(TheGray, TheGray, TheGray);
    lblFreeSign.Font.Color  := RGB(TheGray, TheGray, TheGray);
    lblSwapSign.Font.Color  := RGB(TheGray, TheGray, TheGray);
    pnlBack.Update;
  end;
  {Save and exit}
  SaveOptions;
  Delay(400);
  Application.Terminate;
end;

procedure TfrmMain.btnOnTopClick(Sender: TObject);
begin
  if btnOnTop.Down then
    frmMain.FormStyle := fsStayOnTop
  else
    frmMain.FormStyle := fsNormal;
end;

procedure TfrmMain.btnOptionsClick(Sender: TObject);
var
  i : Integer;
begin
  if pnlMain.Height = 69 then
    begin
      for i := 69 to 110 do begin
        pnlMain.Height := i;
        frmMain.Top    := frmMain.Top -1;
        frmMain.Height := pnlMain.Height;
      end;
    end
  else
    begin
      for i := 110 downto 69 do begin
        pnlMain.Height := i;
        frmMain.Top    := frmMain.Top +1;
        frmMain.Height := pnlMain.Height;
      end;
    end;
end;

procedure TfrmMain.Timer2Timer(Sender: TObject);
begin
  if btnCheckSwap.Down then begin
    if Abs(SwapFile-OldSwap) < 128 then begin
      OldSwap := SwapFile;
      lblSwap.Caption := FloatToStrF(OldSwap,ffNumber,8,0)+' k';
      lblSwapSign.Caption := 'ó'; {Double left-right arrow}
      lblSwap.Font.Color := clBlack;
    end;

    if SwapFile > OldSwap then begin
      OldSwap := OldSwap + 128;
      lblSwap.Caption := FloatToStrF(OldSwap,ffNumber,8,0)+' k';
      lblSwapSign.Caption := 'ñ'; {Up arrow}
      lblSwap.Font.Color := clRed;
    end;

    if SwapFile < OldSwap then begin
      OldSwap := OldSwap - 128;
      lblSwap.Caption := FloatToStrF(OldSwap,ffNumber,8,0)+' k';
      lblSwapSign.Caption := 'ò'; {Down arrow}
      lblSwap.Font.Color := clRed;
    end;
  end;
end;

procedure TfrmMain.TrackBar1Change(Sender: TObject);
var
  i,
  TheGray : Integer;
begin
    i := TrackBar1.Position;
    TheGray                 := Trunc(6.4*i);
    pnlBack.Color           := RGB(Trunc(8.1*i),Trunc(10.4*i),0);
    Application.HintColor   := pnlBack.Color;
    lblBlink.Font.Color     := RGB(TheGray, TheGray, TheGray);
    lblPlusMinus.Font.Color := RGB(TheGray, TheGray, TheGray);
    lblFreeSign.Font.Color  := RGB(TheGray, TheGray, TheGray);
    lblSwapSign.Font.Color  := RGB(TheGray, TheGray, TheGray);
    pnlBack.Update;
end;


procedure TfrmMain.lblRemainingClick(Sender: TObject);
var
  i : Integer;
begin
  for i := 1 to 20 do begin
    lblRemaining.Caption := Copy('||||||||||||||||||||',1,i);
    Delay(50);
  end;
  TIME2CLOSE := 20 * 60;
end;

procedure TfrmMain.lblFreeClick(Sender: TObject);
begin
  pnlBack.Visible := False;
  Delay(5000);
  pnlBack.Visible := True;
end;

procedure TfrmMain.btnDirectCountClick(Sender: TObject);
begin
  Timer2.Enabled := not btnDirectCount.Down;
  btnOptionsClick(Self);
end;

procedure TfrmMain.SpeedButton8Click(Sender: TObject);
begin
  Timer1.Interval := 1000;
  btnOptionsClick(Self);
end;

procedure TfrmMain.SpeedButton9Click(Sender: TObject);
begin
  Timer1.Interval := 2000;
  btnOptionsClick(Self);
end;

procedure TfrmMain.btnCheckSwapClick(Sender: TObject);
begin
  if not btnCheckSwap.Down then lblSwap.Caption := 'n/a';
  btnOptionsClick(Self);
end;

procedure TfrmMain.btnTimeCloseClick(Sender: TObject);
begin
  if btnTimeClose.Down then
    lblRemaining.Font.Color := clBlack
  else
    lblRemaining.Font.Color := clGray;
  btnOptionsClick(Self);
end;

end.

                   

Por si quieres contactar escanea el codigo QR....