BCS Delphi XE8 Search Database Grid

Posted on by archman007


There are those times when it would be handy to search the contents of a database grid.
I have developed code that will allow for searching of the database grid.
[codesyntax lang=”delphi”]

{*-----------------------------------------------------------------------------
 Procedure: SearchGrid
 Author:    Mr. Arch Brooks, Software Engineer, Brooks Computing Systems, LLC
 Date:      21-Oct-2015
 @Param     dg: TDBGrid; LookUpField, KeyField: string; Rcolor: TColor; han: THandle
 @Return    None
 -----------------------------------------------------------------------------}
procedure TBCSPwbC.SearchGrid(dg: TDBGrid; LookUpField, KeyField: string;
  Rcolor: TColor; han: THandle);
var
  ttf: string;
  sc: TStringList;
  std: string;
begin
  ttf := InputBox('Enter Text To Find', 'Detect String', '');
  dg.DataSource.DataSet.DisableControls;
  dg.DataSource.DataSet.First;
  sc := TStringList.Create;
  while not dg.DataSource.DataSet.Eof do
  begin
    if ContainsText(dg.DataSource.DataSet.FieldByName(LookUpField).AsString, ttf)
    then
    begin
      sc.Add(dg.DataSource.DataSet.FieldByName(KeyField).AsString + ' ' +
        dg.DataSource.DataSet.FieldByName(LookUpField).AsString);
    end;
    dg.DataSource.DataSet.Next;
  end;
  BCSLFC.RDColor := Rcolor;
  BCSLFC.RCaption := 'Select From Detected Text';
  dg.DataSource.DataSet.EnableControls;
  if (sc.Count - 1) > -1 then
  begin
    BCSLFC.lbxDets.Items.Assign(sc);
    if BCSLFC.ShowModal = idOk then
    begin
      std := BCSLFC.lbxDets.Items[BCSLFC.lbxDets.ItemIndex];
      Delete(std, Pos(' ', std), Length(std));
      dg.DataSource.DataSet.Locate(KeyField, std, [])
    end;
  end
  else
  begin
    dg.DataSource.DataSet.First;
    MessageBox(han, 'Text Not Found', 'No Such Text', mb_OkCancel);
  end;
  sc.Free;
end;
[/codesyntax]

This routine contains the commands to accept the string to search for from the user.
glu1
The search routing is invoked by the following line of code.
[codesyntax lang=”delphi”]

  SearchGrid(BCSPwbMastersDBGrid, 'cat', 'idlk1', RDColor, Handle);

[/codesyntax]
The fields are as follows:

  • The name of the database grid to search.
  • The name of the look up field.
  • The name of the key field.
  • The default color of the background for the dialog.
  • The handle for the message box when needed.

The following dialog appears when the designated text is found.
glu2
Double click on the desired item and the database grid will be positioned to that item.
If there matches were not found the following message box will appear.
glu3
The form Delphi XE8 source code for the detected items in below.
[codesyntax lang=”delphi”]

{*-----------------------------------------------------------------------------
 Unit Name: BCSLFU
 Date:      03-Oct-2015
 Purpose:
 History:
 @Author    Mr. Arch Brooks, Software Engineer, Brooks Computing Systems, LLC
 @version    1.0.0.0
-----------------------------------------------------------------------------}
unit BCSLFU;
interface
uses
  ShellAPI, System.Classes, System.SysUtils, System.Variants, Vcl.ComCtrls,
  Vcl.Controls, Vcl.Dialogs, Vcl.Forms, Vcl.Graphics, Vcl.Menus,
  Winapi.Messages, Winapi.Windows, Vcl.ExtCtrls, Vcl.StdCtrls;
type
  /// Tab Sheet Class
  TTabSheet = class(Vcl.ComCtrls.TTabSheet)
  private
    /// Tab Control Color
    FColor: TColor;
    procedure SetColor(Value: TColor);
    procedure WMEraseBkGnd(var Msg: TWMEraseBkGnd); message WM_ERASEBKGND;
  public
    constructor Create(aOwner: TComponent); override;
    property Color: TColor read FColor write SetColor;
  end;
  /// Main Dialog Class
  TBCSLFC = class(TForm)
    /// Colors Menu Item
    Colors: TMenuItem;
    /// Fonts Menu Item
    Fonts: TMenuItem;
    /// Help Menu Item
    Help: TMenuItem;
    /// Top Menu
    BCSLFMenu: TMainMenu;
    /// Page Control
    BCSLFPageContol: TPageControl;
    /// Status Bar
    BCSLFStatusBar: TStatusBar;
    /// Tab Sheet 1
    BCSLFTabSheet1: TTabSheet;
    /// Utils Menu Item
    BCSLFUtils: TMenuItem;
    /// Color Dialog
    BCSLFColorDialog: TColorDialog;
    /// Font Dialog
    BCSLFFontDialog: TFontDialog;
    /// Timer Control
    BCSLFTimer: TTimer;
    /// OK Menu Item
    OK1: TMenuItem;
    /// Detects Look Up Box
    lbxDets: TListBox;
    procedure ColorsClick(Sender: TObject);
    procedure FontsClick(Sender: TObject);
    procedure FormActivate(Sender: TObject);
    procedure HelpClick(Sender: TObject);
    procedure BCSLFDrawTab(Control: TCustomTabControl; TabIndex: Integer;
      const Rect: TRect; Active: Boolean);
    procedure BCSLFTimerTimer(Sender: TObject);
    procedure BCSLFStatusBarDrawPanel(StatusBar: TStatusBar;
      Panel: TStatusPanel; const Rect: TRect);
    procedure OK1Click(Sender: TObject);
    procedure lbxDetsDblClick(Sender: TObject);
  private
    {Private declarations}
    /// Default Dialog Color
    FColor: TColor;
    /// Dialog Caption
    FCaption: String;
    procedure UpColor;
    procedure Xqt(cmd: string);
  public
    {Public declarations}
    property RDColor: TColor read FColor write FColor;
    property RCaption: String read FCaption write FCaption;
  end;
var
  /// Main Form Dialog Handle
  BCSLFC: TBCSLFC;
implementation
{$R *.dfm}
var
  /// TimeStamp Variable
  ftime: String;
  {*-----------------------------------------------------------------------------
   Procedure: Create
   Author:    Mr. Arch Brooks, Software Engineer, Brooks Computing Systems LLC
   Date:      25-May-2015
   @Param     aOwner: TComponent
   @Return    None
   -----------------------------------------------------------------------------}
constructor TTabSheet.Create(aOwner: TComponent);
begin
  inherited;
  FColor := Color;
end;
{*-----------------------------------------------------------------------------
 Procedure: SetColor
 Author:    Mr. Arch Brooks, Software Engineer, Brooks Computing Systems LLC
 Date:      25-May-2015
 @Param     Value: TColor
 @Return    None
 -----------------------------------------------------------------------------}
procedure TTabSheet.SetColor(Value: TColor);
begin
  if FColor <> Value then
  begin
    FColor := Value;
    Invalidate;
  end;
end;
{*-----------------------------------------------------------------------------
 Procedure: WMEraseBkGnd
 Author:    Mr. Arch Brooks, Software Engineer, Brooks Computing Systems LLC
 Date:      25-May-2015
 @Param     var Msg: TWMEraseBkGnd
 @Return    None
 -----------------------------------------------------------------------------}
procedure TTabSheet.WMEraseBkGnd(var Msg: TWMEraseBkGnd);
begin
  if FColor = clBtnFace then
    inherited
  else
  begin
    Brush.Color := FColor;
    FillRect(Msg.dc, ClientRect, Brush.Handle);
    Msg.Result := 1;
  end;
end;
{*-----------------------------------------------------------------------------
 Procedure: ColorsClick
 Author:    Mr. Arch Brooks, Software Engineer, Brooks Computing Systems LLC
 Date:      25-May-2015
 @Param     Sender: TObject
 @Return    None
 -----------------------------------------------------------------------------}
procedure TBCSLFC.ColorsClick(Sender: TObject);
begin
  if BCSLFColorDialog.Execute(Handle) then
  begin
    RDColor := BCSLFColorDialog.Color;
    BCSLFTabSheet1.Color := RDColor;
    BCSLFStatusBar.Color := RDColor;
    UpColor;
  end;
end;
{*-----------------------------------------------------------------------------
 Procedure: FontsClick
 Author:    Mr. Arch Brooks, Software Engineer, Brooks Computing Systems LLC
 Date:      25-May-2015
 @Param     Sender: TObject
 @Return    None
 -----------------------------------------------------------------------------}
procedure TBCSLFC.FontsClick(Sender: TObject);
begin
  if BCSLFFontDialog.Execute(Handle) then
  begin
  end;
end;
{*-----------------------------------------------------------------------------
 Procedure: FormActivate
 Author:    Mr. Arch Brooks, Software Engineer, Brooks Computing Systems LLC
 Date:      25-May-2015
 @Param     Sender: TObject
 @Return    None
 -----------------------------------------------------------------------------}
procedure TBCSLFC.FormActivate(Sender: TObject);
begin
  if RCaption > '' then
  begin
    BCSLFC.Caption := RCaption;
  end;
  UpColor;
end;
{*-----------------------------------------------------------------------------
 Procedure: BCSLFDrawTab
 Author:    Mr. Arch Brooks, Software Engineer, Brooks Computing Systems LLC
 Date:      25-May-2015
 @Param     Control: TCustomTabControl; TabIndex: Integer; const Rect: TRect; Active: Boolean
 @Return    None
 -----------------------------------------------------------------------------}
procedure TBCSLFC.BCSLFDrawTab(Control: TCustomTabControl;
  TabIndex: Integer; const Rect: TRect; Active: Boolean);
var
  AText: string;
  APoint: TPoint;
begin
  with (Control as TPageControl).Canvas do
  begin
    Brush.Color := Color;
    FillRect(Rect);
    AText := TPageControl(Control).Pages[TabIndex].Caption;
    with Control.Canvas do
    begin
      APoint.x := (Rect.Right - Rect.Left) div 2 - TextWidth(AText) div 2;
      APoint.y := (Rect.Bottom - Rect.Top) div 2 - TextHeight(AText) div 2;
      TextRect(Rect, Rect.Left + APoint.x, Rect.Top + APoint.y, AText);
    end;
  end;
end;
{*-----------------------------------------------------------------------------
 Procedure: HelpClick
 Author:    Mr. Arch Brooks, Software Engineer, Brooks Computing Systems LLC
 Date:      25-May-2015
 @Param     Sender: TObject
 @Return    None
 -----------------------------------------------------------------------------}
procedure TBCSLFC.HelpClick(Sender: TObject);
begin
  Xqt('https://archbrooks.us/doc/app/html');
end;
{*-----------------------------------------------------------------------------
  Procedure: lbxDetsDblClick
  Author:    Mr. Arch Brooks, Software Engineer, Brooks Computing Systems, LLC
  Date:      21-Oct-2015
  @Param     Sender: TObject
  @Return    None
-----------------------------------------------------------------------------}
procedure TBCSLFC.lbxDetsDblClick(Sender: TObject);
begin
  ModalResult := mrOk;
end;
{*-----------------------------------------------------------------------------
 Procedure: OK1Click
 Author:    archman
 Date:      25-May-2015
 @Param     Sender: TObject
 @Return    None
 -----------------------------------------------------------------------------}
procedure TBCSLFC.OK1Click(Sender: TObject);
begin
  ModalResult := mrOk;
end;
{*-----------------------------------------------------------------------------
 Procedure: BCSLFStatusBarDrawPanel
 Author:    Mr. Arch Brooks, Software Engineer, Brooks Computing Systems LLC
 Date:      25-May-2015
 @Param     StatusBar: TStatusBar; Panel: TStatusPanel; const Rect: TRect
 @Return    None
 -----------------------------------------------------------------------------}
procedure TBCSLFC.BCSLFStatusBarDrawPanel(StatusBar: TStatusBar;
  Panel: TStatusPanel; const Rect: TRect);
begin
  with StatusBar.Canvas do
  begin
    FillRect(Rect);
    case Panel.Index of
      0: // fist panel
        begin
          Brush.Color := RDColor;
          Font.Color := clBlack;
          // Font.Style := [fsBold];
          TextRect(Rect, 2 + Rect.Left, 2 + Rect.Top, Panel.Text);
        end;
      1: // second panel
        begin
          Brush.Color := RDColor;
          Font.Color := clBlack;
          // Font.Style := [fsItalic];
          TextRect(Rect, 2 + Rect.Left, 2 + Rect.Top, Panel.Text);
        end;
      2: // Third panel
        begin
          Brush.Color := RDColor;
          Font.Color := clBlack;
          // Font.Style := [fsItalic];
          Panel.Text := ftime;
          Panel.Alignment := taRightJustify;
          TextRect(Rect, 12 + Rect.Left, 2 + Rect.Top, Panel.Text);
          // TextOut(0, 0, ftime);
        end;
    end;
  end;
end;
{*-----------------------------------------------------------------------------
 Procedure: BCSLFTimerTimer
 Author:    Mr. Arch Brooks, Software Engineer, Brooks Computing Systems LLC
 Date:      25-May-2015
 @Param     Sender: TObject
 @Return    None
 -----------------------------------------------------------------------------}
procedure TBCSLFC.BCSLFTimerTimer(Sender: TObject);
begin
  DateTimeToString(ftime, 'dddd, mmmm dd, yyyy hh:mm:ss     ', now);
  BCSLFStatusBar.Panels[2].Alignment := taRightJustify;
  BCSLFStatusBar.Panels[2].Text := ftime;
end;
{*-----------------------------------------------------------------------------
 Procedure: UpColor
 Author:    Mr. Arch Brooks, Software Engineer, Brooks Computing Systems LLC
 Date:      25-May-2015
 @Param     None
 @Return    None
 -----------------------------------------------------------------------------}
procedure TBCSLFC.UpColor;
begin
  Color := RDColor;
  BCSLFTabSheet1.Color := RDColor;
  BCSLFStatusBar.Color := RDColor;
end;
{*-----------------------------------------------------------------------------
  Procedure: Xqt
  Author:    Mr. Arch Brooks, Software Engineer, Brooks Computing Systems LLC
  Date:      12-Jun-2015
  @Param     cmd: string
  @Return    None
-----------------------------------------------------------------------------}
procedure TBCSLFC.Xqt(cmd: string);
begin
  ShellAPI.ShellExecute(Handle, PWideChar('open'), PWideChar(cmd), '',
    PWideChar(''), sw_Normal);
end;
end.

[/codesyntax]
The form (.dfm) file is below.
[codesyntax lang=”delphi”]

object BCSLFC: TBCSLFC
  Left = 0
  Top = 0
  Caption = 'BCSLFC'
  ClientHeight = 201
  ClientWidth = 447
  Color = clBtnFace
  Font.Charset = DEFAULT_CHARSET
  Font.Color = clWindowText
  Font.Height = -11
  Font.Name = 'Tahoma'
  Font.Style = []
  Menu = BCSLFMenu
  OldCreateOrder = False
  Position = poDesktopCenter
  OnActivate = FormActivate
  PixelsPerInch = 96
  TextHeight = 13
  object BCSLFStatusBar: TStatusBar
    Left = 0
    Top = 182
    Width = 447
    Height = 19
    Color = clGradientActiveCaption
    Panels = <
      item
        Style = psOwnerDraw
        Width = 100
      end
      item
        Style = psOwnerDraw
        Width = 150
      end
      item
        Style = psOwnerDraw
        Width = 50
      end>
    OnDrawPanel = BCSLFStatusBarDrawPanel
  end
  object BCSLFPageContol: TPageControl
    Left = 0
    Top = 0
    Width = 447
    Height = 182
    ActivePage = BCSLFTabSheet1
    Align = alClient
    OwnerDraw = True
    TabOrder = 1
    TabPosition = tpBottom
    OnDrawTab = BCSLFDrawTab
    object BCSLFTabSheet1: TTabSheet
      Caption = 'Workbench'
      ParentShowHint = False
      ShowHint = True
      object lbxDets: TListBox
        Left = 23
        Top = 14
        Width = 393
        Height = 129
        ItemHeight = 13
        TabOrder = 0
        OnDblClick = lbxDetsDblClick
      end
    end
  end
  object BCSLFMenu: TMainMenu
    Left = 300
    Top = 44
    object BCSLFUtils: TMenuItem
      Caption = 'Utils'
      object Colors: TMenuItem
        Caption = 'Colors'
        OnClick = ColorsClick
      end
      object Fonts: TMenuItem
        Caption = 'Fonts'
        OnClick = FontsClick
      end
      object Help: TMenuItem
        Caption = 'Help'
        OnClick = HelpClick
      end
    end
    object OK1: TMenuItem
      Caption = 'OK'
      OnClick = OK1Click
    end
  end
  object BCSLFColorDialog: TColorDialog
    Options = [cdFullOpen]
    Left = 108
    Top = 28
  end
  object BCSLFFontDialog: TFontDialog
    Font.Charset = DEFAULT_CHARSET
    Font.Color = clWindowText
    Font.Height = -11
    Font.Name = 'Tahoma'
    Font.Style = []
    Left = 76
    Top = 84
  end
  object BCSLFTimer: TTimer
    OnTimer = BCSLFTimerTimer
    Left = 292
    Top = 92
  end
end

[/codesyntax]
This handy technique can be implemented for every database grid in you applications.
The source code may be found by clicking here.
Mr. Arch Brooks, Software Engineer, Brooks Computing Systems, LLC authored this article.

Leave a Reply

Your email address will not be published. Required fields are marked *