Adding CheckBox to a TShellTreeView

unit Unit1;

interface

uses
  Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms, Dialogs, ShellCtrls,
  ComCtrls;

type
  TCheckBoxShellTreeView = class(TShellTreeView)
  public
    procedure CreateParams(var Params: TCreateParams); override;
  end;

  TForm1 = class(TForm)
    procedure FormCreate(Sender: TObject);
    procedure FormDestroy(Sender: TObject);
  private
    { Private declarations }
    FShellTreeView: TCheckBoxShellTreeView;
  public
    { Public declarations }
  end;

var
  Form1: TForm1;

implementation

{$R *.dfm}

const
  TVS_CHECKBOXES = $00000100;

procedure TCheckBoxShellTreeView.CreateParams(var Params: TCreateParams);
begin
  inherited;
  Params.Style := Params.Style or TVS_CHECKBOXES;
end;

procedure TForm1.FormCreate(Sender: TObject);
begin
  FShellTreeView := TCheckBoxShellTreeView.Create(Self);
  with FShellTreeView do
  begin
    Name := 'FShellTreeView';
    Parent := Self;
    Root := 'rfDesktop';
    UseShellImages := True;
    Align := alClient;
    AutoRefresh := False;
    BorderStyle := bsNone;
    Indent := 19;
    ParentColor := False;
    RightClickSelect := True;
    ShowRoot := False;
    TabOrder := 0;
  end;
end;

procedure TForm1.FormDestroy(Sender: TObject);
begin
  FShellTreeView.Free;
end;

end.

Paint Dock Frame

procedure TDockTree.PaintDockFrame(Canvas: TCanvas; Control: TControl; const ARect: TRect);

  procedure DrawCloseButton(Left, Top: Integer);
  begin
    DrawFrameControl(Canvas.Handle, Rect(Left, Top, Left+FGrabberSize-2,
      Top+FGrabberSize-2), DFC_CAPTION, DFCS_CAPTIONCLOSE);
  end;

  procedure DrawGrabberLine(Left, Top, Right, Bottom: Integer);
  begin
    with Canvas do
    begin
      Pen.Color := clBtnHighlight;
      MoveTo(Right, Top);
      LineTo(Left, Top);
      LineTo(Left, Bottom);
      Pen.Color := clBtnShadow;
      LineTo(Right, Bottom);
      LineTo(Right, Top-1);
    end;
  end;

begin
  with ARect do
    if FDockSite.Align in [alTop, alBottom] then
    begin
      DrawCloseButton(Left+1, Top+1);
      DrawGrabberLine(Left+3, Top+FGrabberSize+1, Left+5, Bottom-2);
      DrawGrabberLine(Left+6, Top+FGrabberSize+1, Left+8, Bottom-2);
    end
    else
    begin
      DrawCloseButton(Right-FGrabberSize+1, Top+1);
      DrawGrabberLine(Left+2, Top+3, Right-FGrabberSize-2, Top+5);
      DrawGrabberLine(Left+2, Top+6, Right-FGrabberSize-2, Top+8);
    end;
end;

Customise your Message Dialog

procedure TForm1.Button2Click(Sender: TObject);
var
 Dlg: TForm;
 Rslt: Integer;
begin
 Dlg := CreateMessageDialog('Customised MessageBox, hope this is helpful', mtConfirmation, [mbYes, mbNo, mbNoToAll]);

 { change the messagedlg caption }
 Dlg.Caption := 'Please Confirm';

 {change the button texts }
 TButton(Dlg.FindComponent('Yes')).Caption := 'Indeed!';
 TButton(Dlg.FindComponent('No')).Caption := 'Surely Not!';
 TButton(Dlg.FindComponent('NoToAll')).Caption := 'None please!';

 { change the button fonts }
 TButton(Dlg.FindComponent('Yes')).Font.Name := 'C4 Text';
 TButton(Dlg.FindComponent('No')).Font.Name := 'C4 TextMedium' ;
 TButton(Dlg.FindComponent('NoToAll')).Font.Name := 'Tahoma';
 //this sets the buttons font to Bold & Underlined
 TButton(Dlg.FindComponent('NoToAll')).Font.Style:=[fsBold];

 { change the Message's appearance }
 TLabel(Dlg.FindComponent('Message')).Font.Name := 'Courier New';
 TLabel(Dlg.FindComponent('Message')).Font.Size := 12;
 TLabel(Dlg.FindComponent('Message')).Font.Color := clRed;

 Rslt := Dlg.ShowModal;

 case Rslt of
   mrYes:     { do "Yes" stuff };
   mrNo:      { do "No" stuff };
   mrNoToAll: { do "No to All" stuff };
 end;
end;

Calculate estimated Download time of a File

{ Add this under your type declaration }

type
  TDRec = record
  H, M, S: Integer;
  end;

const
  Count = 6;
  BpsArray: array [0..Count] of Integer = (14400, 28800, 33600, 56000, 64000, 128000, 512000);

function CalculateDLTime(const Value, Units, Connection: Integer): TDRec;
var
  i, size_bits, filedltimesec, hourmod, HH, MM, SS: Integer;
  Rec: TDRec;

function pow(a, b: Integer): Integer;
    function sl(nr, times: Integer): Integer;
    var
      i: Integer;
    begin
      Result := nr * nr;
      for i := 0 to times do Result := Result + nr * nr;
    end;
  begin
    if a > b then 
      Result := sl(a, b)
    else 
      Result := sl(b, a);
  end;
begin
  case Units of
    1: size_bits := (8 div 1) * Value;                 // bytes
    2: size_bits := (8 div 1) * ((pow(2,10)) div 1) * Value;     // kilobytes
    3: size_bits := (8 div 1) * ((pow(2,20)) div 1) * Value;     // Megabytes
  end;

  // Calculate
  filedltimesec := Round(size_bits) div BpsArray[Connection];

  hourmod := filedltimesec mod (60 * 60);  // Modulus.
  HH      := Floor(filedltimesec / (60 * 60));
  MM      := Floor(hourmod / 60);
  SS      := Floor(filedltimesec mod 60);  // Modulus.

  if SS > 0 then Inc(SS);

  with Rec do
  begin
    H := HH;
    M := MM;
    S := SS;
  end;

  Result := Rec;
end;

procedure TForm1.Button1Click(Sender: TObject);
var
  i: Integer;
  Rec: TDRec;
begin
  ListView1.Items.Clear;

  for i := 0 to Count do
  begin
    Rec := CalculateDLTime(StrToInt(Edit1.Text), ComboBox1.ItemIndex + 1,i);

    with ListView1.Items.Add do
    begin
      Caption := NameArray[i];
      SubItems.Add(IntToStr(Rec.H));
      SubItems.Add(IntToStr(Rec.M));
      SubItems.Add(IntToStr(Rec.S));
    end;
  end;
end;

Sending Mail using Thread

unit uSMTPMailer;

interface

uses
  Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, 
  Dialogs, IdMessage, IdBaseComponent, IdComponent, IdTCPConnection,
  IdTCPClient, IdMessageClient, IdSMTP, StdCtrls;

type
  TSendMail = class(TThread)
  private
    FPortNumber: Integer;
    FSubject: String;
    FPassword: String;
    FServerName: String;
    FFromAddress: String;
    FBodyMessage: TStrings;
    FRecipientsList: TStrings;
    procedure SetBodyMessage(const Value: TStrings);
    procedure SetFromAddress(const Value: String);
    procedure SetPasword(const Value: String);
    procedure SetPortNumber(const Value: Integer);
    procedure SetRecipientsList(const Value: TStrings);
    procedure SetServerName(const Value: String);
    procedure SetSubject(const Value: String);
  public
    constructor Create(ASuspended: Boolean);
    property PortNumber: Integer read FPortNumber write SetPortNumber;
    property ServerName: String read FServerName write SetServerName;
    property Password: String read FPassword write SetPasword;
    property FromAddress: String read FFromAddress write SetFromAddress;
    property Recipients: TStrings  read FRecipientsList write SetRecipientsList;
    property Subject: String read FSubject write SetSubject;
    property Body: TStrings read FBodyMessage write SetBodyMessage;
    procedure SendEMail;
  protected
    procedure Execute;  override;
  end;

  function SendSMTPMail(APort: Integer;
                        ASMTPServer, APassword, AFromAddress: String;
                        AToAddresses, ABodyText: TStrings): Boolean;

implementation

{ TSendMail }
constructor TSendMail.Create(ASuspended: Boolean);
begin
  inherited Create(ASuspended);
  FreeOnTerminate := True;
  FBodyMessage := TStringList.Create;
  FRecipientsList := TStringList.Create;
end;

procedure TSendMail.Execute;
var
  FIdSMTP: TIdSMTP;
  FIdMessage: TIdMessage;
begin
  FIdSMTP := TIdSMTP.Create(nil);
  FIdMessage := TIdMessage.Create(nil);
  try
    FIdSMTP.Host := FServerName;
    FIdSMTP.Port := FPortNumber;
    FIdSMTP.Password:= FPassword;
    FIdMessage.From.Address := FFromAddress;
    FIdmessage.Recipients.Assign(FRecipientsList);
    FIdMessage.Subject := FSubject;
    FIdMessage.Body.Assign(FBodyMessage);
    try
      FIdSMTP.Connect;
      FIdSMTP.Send(FIdMessage);
    except end;
  finally
    if FIdSMTP.Connected then FIdSMTP.Disconnect;
    FreeAndNil(FIdMessage);
    FreeAndNil(FIdSMTP);
  end;
end;

procedure TSendMail.SendEMail;
begin
  Resume;
end;

procedure TSendMail.SetBodyMessage(const Value: TStrings);
begin
  FBodyMessage.Assign(Value);
end;

procedure TSendMail.SetFromAddress(const Value: String);
begin
  FFromAddress := Value;
end;

procedure TSendMail.SetPasword(const Value: String);
begin
  FPassword := Value;
end;

procedure TSendMail.SetPortNumber(const Value: Integer);
begin
  FPortNumber := Value;
end;

procedure TSendMail.SetRecipientsList(const Value: TStrings);
begin
  FRecipientsList.Assign(Value);
end;

procedure TSendMail.SetServerName(const Value: String);
begin
  FServerName := Value;
end;

procedure TSendMail.SetSubject(const Value: String);
begin
  FSubject := Value;
end;

function SendSMTPMail(APort: Integer; ASMTPServer, APassword,
  AFromAddress: String; AToAddresses, ABodyText: TStrings): Boolean;
begin
  try
    with TSendMail.Create(True) do
    begin
      PortNumber := APort;
      ServerName := ASMTPServer;
      Password   := APassword;
      FromAddress := AFromAddress;
      Recipients.Assign(AToAddresses);
      Body.Assign(ABodyText);
      SendEMail;
      {no need to free, its a self destructive thread}
    end;
    Result := True;
  except
    Result := False;
  end;
end;

end.

Display a shaded column like Windows Explorer in XP

The Windows Explorer in XP displays the sorted column in pale grey. We can bring up similar behaviour in Delphi TListView by handling all two OnCustomDraw, OnColumnClick events to display a list view with a specified column shaded in pale grey.

procedure TForm1.ListView1ColumnClick(Sender: TObject; Column: TListColumn);
begin
  FColumnToSort := Column.Index;
  ListView1.Invalidate;
end; 

procedure TForm1.ListView1CustomDraw(Sender: TCustomListView; const ARect: TRect; var DefaultDraw: Boolean);
var
  ColLeft: Integer;   
  ColBounds: TRect;
  I: Integer;      
begin
  ColLeft := ARect.Left;
  for I := 0 to Pred(FColumnToSort) do
    ColLeft := ColLeft + ListView_GetColumnWidth(ListView1.Handle, I);

  ColBounds := Rect(ColLeft, ARect.Top, ColLeft + ListView_GetColumnWidth(ListView1.Handle, FColumnToSort), ARect.Bottom);

  ListView1.Canvas.Brush.Color := clSilver;
  ListView1.Canvas.FillRect(ColBounds);
end;

Post your Favorite Code here...

Would you be interested in posting your sample code or comments or information into this blog?