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.