A Component that plots graphs

Problem/Question/Abstract:

A component for creating graphs

Answer:

Here is a component that draws graphs. You can zoom in and out of the graph. The code is shown below. Copy the code to .pas file and install the component. I will add a demo to show how to use this component soon.

unit UGraph;

interface

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

type
  TOnMouseMove = procedure(Shift: TShiftState; x, y: integer) of object;
  TOnMouseDown = procedure(Button: TMouseButton; Shift: TShiftState; x, y: integer) of
    object;
  TOnMouseUp = procedure(Button: TMouseButton; Shift: TShiftState; x, y: integer) of
    object;

  TState = (fplotted, fjoined);
  TGraph = class;
  TPlots = class;

  TPoints = class(Tlist)
  private
    fplots: TPlots;
    fptcolor, fcrvcolor: TColor;
    fstate: set of Tstate;
    procedure fPlot;
    procedure fJoin;
  protected
    function Get(index: integer): PPoint;
  public
    procedure Plot;
    procedure Join;
    constructor Create(aplots: TPlots);
    function Add(x, y: integer): PPoint;
    procedure HideDots;
    procedure HideJoins;
    procedure Clear; override;
    property CurveColor: Tcolor read fcrvcolor write fcrvColor;
    property DotColor: Tcolor read fptcolor write fptColor;
    property Items[index: integer]: PPoint read Get; default;
  end;

  TPlots = class(Tlist)
  private
    fgraph: TGraph;
  protected
    function Get(index: integer): TPoints;
  public
    constructor Create(agraph: TGraph);
    function Add: TPoints;
    procedure Clear; override;
    procedure PlotAllDots;
    procedure PlotAllJoins;
    procedure HideAllDots;
    procedure HideAllJoins;
    property Items[index: integer]: TPoints read Get; default;
  end;

  TGraph = class(TGraphicControl)
  private
    faxcolor, fbkcolor, fgridcolor: Tcolor;
    fMouseDown: TOnMouseDown;
    fMouseMove: TOnMouseMove;
    fMouseUp: TOnMouseUp;
    fspc: extended;
    ldiv, sdiv: integer;
    xaxis, yaxis: integer;
    xlc, ylc: integer;
    fmag: integer;
    fplots: TPlots;
    function Translate(x, y: integer): Tpoint;
    function GetScale: Extended;
    procedure DrawGrid;
    procedure DrawAxes;
    procedure GetXLineRect(y: integer; var arect: trect);
    procedure GetYLineRect(x: integer; var arect: trect);
    procedure SetGridColor(acolor: Tcolor);
    procedure SetBackColor(acolor: Tcolor);
    procedure SetAxisColor(acolor: TColor);
  protected
    procedure loaded; override;
    procedure Paint; override;
    {procedure MsgHandler(var msg:TMessage);}
    procedure MouseDown(Button: TMouseButton; shift: TShiftState; x, y: integer);
      override;
    procedure MouseMove(shift: TShiftState; x, y: integer); override;
    procedure MouseUp(Button: TMouseButton; shift: TShiftState; x, y: integer);
      override;
  public
    constructor Create(AComponent: TComponent); override;
    destructor Destroy; override;
    procedure OffSetAxes(x, y: integer);
    procedure ResetAxes;
    procedure Zoom(mag: integer);
    property Plots: TPlots read fplots;
  published
    property OnMouseDown: TOnMouseDown read fMouseDown write fMouseDown;
    property OnMouseMove: TOnMouseMove read fMouseMove write fMouseMove;
    property OnMouseUp: TOnMouseUp read fMouseUp write fMouseUp;
    property GridColor: Tcolor read fgridcolor write SetGridColor;
    property BackColor: Tcolor read fbkcolor write SetBackColor;
    property AxisColor: Tcolor read faxcolor write SetAxisColor;
    property Scale: extended read GetScale;
    property ZoomFactor: integer read fmag;
  end;

procedure Register;

implementation

procedure TGraph.MouseDown(Button: TMouseButton; shift: TShiftState; x, y: integer);
var
  tp: Tpoint;
begin
  tp.x := x - left;
  tp.y := y - top;
  tp.x := trunc(tp.x / fspc - yaxis);
  tp.y := trunc(xaxis - tp.y / fspc);
  if (assigned(fMouseDown)) then
    fMouseDown(button, shift, tp.x, tp.y);
  inherited;
end;

procedure TGraph.MouseMove(shift: TShiftState; x, y: integer);
var
  tp: Tpoint;
begin
  tp.x := x - left;
  tp.y := y - top;
  tp.x := trunc(tp.x / fspc - yaxis);
  tp.y := trunc(xaxis - tp.y / fspc);
  if (assigned(fMousemove)) then
    fMousemove(shift, tp.x, tp.y);
  inherited;
end;

procedure TGraph.MouseUp(Button: TMouseButton; shift: TShiftState; x, y: integer);
var
  tp: Tpoint;
begin
  tp.x := x - left;
  tp.y := y - top;
  tp.x := trunc(tp.x / fspc - yaxis);
  tp.y := trunc(xaxis - tp.y / fspc);
  if (assigned(fMouseUp)) then
    fMouseup(button, shift, tp.x, tp.y);
  inherited;
end;

constructor TPoints.Create(aplots: TPlots);
begin
  if aplots = nil then
    raise Exception.Create('Not a valid Graph object.');
  fplots := aplots;
end;

constructor TPlots.Create(agraph: Tgraph);
begin
  if agraph = nil then
    raise Exception.Create('Not a valid Graph object.');
  fgraph := agraph;
end;

procedure TPoints.HideDots;
begin
  fstate := fstate - [fplotted];
end;

procedure TPoints.HideJoins;
begin
  fstate := fstate - [fjoined];
end;

procedure TPoints.Plot;
begin
  fstate := fstate + [fplotted];
  fplots.fgraph.invalidate;
end;

procedure TPoints.fPlot;
var
  i: integer;
  tmp: tpoint;
begin
  if count <= 0 then
    exit;
  with fplots.fgraph do
  begin
    canvas.pen.color := fptcolor;
    canvas.pen.width := 1;
    for i := 0 to count - 1 do
    begin
      tmp := Translate(items[i].x, items[i].y);
      canvas.Ellipse(rect(tmp.x - 1, tmp.y - 1, tmp.x + 1, tmp.y + 1));
    end;
  end;
end;

procedure TPoints.Join;
begin
  fstate := fstate + [fjoined];
  fplots.fgraph.invalidate;
end;

procedure TPoints.fJoin;
var
  i: integer;
  tmp: tpoint;
begin
  if count <= 0 then
    exit;
  with fplots.fgraph do
  begin
    canvas.pen.color := fcrvcolor;
    canvas.pen.width := 1;
    tmp := Translate(items[0].x, items[0].y);
    canvas.moveto(tmp.x, tmp.y);
    for i := 1 to count - 1 do
    begin
      tmp := Translate(items[i].x, items[i].y);
      canvas.lineto(tmp.x, tmp.y);
    end;
  end;
end;

procedure TPlots.PlotAllDots;
var
  i: integer;
begin
  for i := 0 to count - 1 do
    items[i].Plot;
end;

procedure TPlots.PlotAllJoins;
var
  i: integer;
begin
  for i := 0 to count - 1 do
    items[i].join
end;

procedure TPlots.HideAllDots;
var
  i: integer;
  inv: boolean;
begin
  inv := false;
  for i := 0 to count - 1 do
    if (fplotted in items[i].fstate) then
    begin
      items[i].fstate := items[i].fstate - [fplotted];
      inv := true;
    end;
  if inv then
    fgraph.invalidate;
end;

procedure TPlots.HideAllJoins;
var
  i: integer;
  inv: boolean;
begin
  inv := false;
  for i := 0 to count - 1 do
    if (fjoined in items[i].fstate) then
    begin
      items[i].fstate := items[i].fstate - [fjoined];
      inv := true;
    end;
  if inv then
    fgraph.invalidate;
end;

function TPlots.Get(index: integer): TPoints;
begin
  result := TPoints(inherited Get(index));
end;

function TPlots.Add: TPoints;
begin
  result := TPoints.create(self);
  inherited Add(result);
end;

procedure TPlots.Clear;
var
  i: integer;
  tmp: Tpoints;
begin
  for i := 0 to count - 1 do
  begin
    tmp := items[i];
    freeandnil(tmp);
  end;
  inherited;
end;

procedure TPoints.Clear;
var
  i: integer;
begin
  for i := 0 to count - 1 do
    dispose(items[i]);
  inherited;
end;

function TPoints.Get(index: integer): PPoint;
begin
  result := PPoint(inherited Get(index));
end;

function TPoints.Add(x, y: integer): PPoint;
begin
  new(result);
  result.x := x;
  result.y := y;
  inherited Add(result);
end;

function TGraph.GetScale: extended;
begin
  if fspc result := sdiv / fspc
else
  result := 1;
end;

destructor TGraph.Destroy;
begin
  freeandnil(fplots);
  inherited;
end;

constructor TGraph.Create(AComponent: TComponent);
begin
  fplots := TPlots.create(self);
  fmag := 100;
  fbkcolor := clwhite;
  faxcolor := clnavy;
  fgridcolor := RGB(214, 244, 254);
  ldiv := 10;
  sdiv := 5;
  fspc := 1;
  inherited;
end;

procedure TGraph.GetXLineRect(y: integer; var arect: trect);
begin
  arect.left := left;
  arect.right := arect.left + width;
  arect.top := top + trunc(y * fspc);
  arect.bottom := arect.top + 2;
end;

procedure TGraph.GetYLineRect(x: integer; var arect: trect);
begin
  arect.top := top;
  arect.bottom := arect.top + height;
  arect.left := left + trunc(x * fspc);
  arect.right := arect.left + 2;
end;

procedure TGraph.SetGridColor(acolor: Tcolor);
begin
  fgridcolor := acolor;
  Invalidate;
end;

procedure TGraph.SetBackColor(acolor: Tcolor);
begin
  fbkcolor := acolor;
  Invalidate;
end;

procedure TGraph.SetAxisColor(acolor: TColor);
begin
  faxcolor := acolor;
  Invalidate;
end;

procedure TGraph.Zoom(mag: integer);
begin
  if mag <= 0 then
    mag := 1;
  if mag > 100000 then
    mag := 100000;
  fspc := (mag / 20);
  if fspc > 1 then
    fspc := trunc(fspc);
  fmag := mag;
  xlc := Trunc(width / fspc);
  ylc := Trunc(height / fspc);
  xaxis := Trunc(ylc / 2);
  yaxis := Trunc(xlc / 2);
  Invalidate;
end;

function TGraph.Translate(x, y: integer): Tpoint;
begin
  result.x := trunc((x + yaxis) * fspc);
  result.y := trunc((xaxis - y) * fspc);
end;

procedure TGraph.loaded;
begin
  Zoom(fmag);
end;

procedure TGraph.ResetAxes;
begin
  Zoom(fmag);
end;

procedure TGraph.OffSetAxes(x, y: integer);
var
  tmp: trect;
  tmpx, tmpy: integer;
begin
  canvas.Pen.color := faxcolor;
  canvas.Pen.Width := 1;
  tmpx := xaxis;
  tmpy := yaxis;
  xaxis := xaxis - y;
  yaxis := yaxis + x;
  if (tmpx = xaxis) and (tmpy = yaxis) then
    exit;
  GetXlineRect(tmpx, tmp);
  InvalidateRect(parent.handle, @tmp, false);
  GetYlineRect(tmpy, tmp);
  InvalidateRect(parent.handle, @tmp, false);

  GetXlineRect(xaxis, tmp);
  InvalidateRect(parent.handle, @tmp, false);
  GetYlineRect(yaxis, tmp);
  InvalidateRect(parent.handle, @tmp, false);
end;

procedure TGraph.DrawAxes;
begin
  canvas.Pen.color := faxcolor;
  canvas.Pen.Width := 1;
  canvas.MoveTo(0, trunc(fspc * xaxis));
  canvas.lineto(width, trunc(fspc * xaxis));
  canvas.MoveTo(trunc(fspc * yaxis), 0);
  canvas.lineto(trunc(fspc * yaxis), height);
end;

procedure TGraph.DrawGrid;
var
  i, t: integer;
  t1, t2: Tpoint;
begin
  i := 0;
  t := 0;
  canvas.pen.color := fbkcolor;
  canvas.Brush.color := fbkcolor;
  canvas.rectangle(0, 0, width, height);
  canvas.Pen.color := fgridcolor;
  canvas.Pen.Width := 1;
  while i <= width do
  begin
    if (t mod ldiv) = 0 then
      canvas.pen.width := 2
    else
      canvas.pen.width := 1;
    t1.x := i;
    t1.y := 0;
    canvas.moveto(t1.x, t1.y);
    t2.x := i;
    t2.y := height;
    canvas.lineto(t2.x, t2.y);
    i := i + max(trunc(fspc), sdiv);
    t := t + 1;
  end;
  i := 0;
  t := 0;
  while i <= height do
  begin
    if (t mod ldiv) = 0 then
      canvas.pen.width := 2
    else
      canvas.pen.width := 1;
    t1.x := 0;
    t1.y := i;
    canvas.moveto(t1.x, t1.y);
    t2.x := width;
    t2.y := i;
    canvas.lineto(t2.x, t2.y);
    i := i + max(trunc(fspc), sdiv);
    t := t + 1;
  end;
end;

procedure TGraph.Paint;
var
  i: integer;
begin
  DrawGrid;
  for i := 0 to fplots.count - 1 do
  begin
    if (fplotted in fplots[i].fstate) then
      fplots[i].fplot;
    if fjoined in fplots[i].fstate then
      fplots[i].fjoin;
  end;
  DrawAxes;
end;

procedure Register;
begin
  RegisterComponents('My Components', [TGraph]);
end;

end.

How to restructure a TTable

Problem/Question/Abstract:

How to restructure a TTable

Answer:

unit TTableRestruct;

{Freeware by Brett W. Fleming 1999
SetOperation method added by Bill Todd 1999}

interface

uses
  BDE, DbTables;

type
  TTableRestructure = class(TObject)
  private
    function GetField(Index: Integer): PFLDDesc;
    function GetFieldLength(Index: Integer): Word;
    function GetFieldName(Index: Integer): string;
    function GetFieldType(Index: Integer): Word;
    function GetFieldUnits(Index: Integer): Word;
    function GetOperation(Index: Integer): PCROpType;
    procedure SetFieldLength(Index: Integer; const Value: Word);
    procedure SetFieldType(Index: Integer; const Value: Word);
    procedure SetFieldUnits(Index: Integer; const Value: Word);
    procedure SetFieldName(Index: Integer; const Value: string);
    procedure DetailError(ErrorCode: DbiResult);
    procedure SetOperation(Index: Integer; OpType: PCROpType);
  protected
    Fields: PFLDDesc;
    Operations: PCROpType;
    LocalFieldCount: Integer;
    procedure DestroyFieldDescriptors;
  public
    constructor Create;
    destructor Destroy; override;
    function AddField: Integer;
    function DeleteField(Index: Integer): Boolean;
    function FindField(Name: string): Integer;
    procedure LoadTableStructure(Table: TTable);
    procedure SaveTableStructure(Table: TTable);
    procedure PrintStructure;
    property FieldCount: Integer read LocalFieldCount;
    property FieldLength[Index: Integer]: Word read GetFieldLength write SetFieldLength;
    property FieldName[Index: Integer]: string read GetFieldName write SetFieldName;
    property FieldType[Index: Integer]: Word read GetFieldType write SetFieldType;
    property FieldUnits[Index: Integer]: Word read GetFieldUnits write SetFieldUnits;
    property Field[Index: Integer]: PFLDDesc read GetField;
    property Operation[Index: Integer]: pCROpType read GetOperation write SetOperation;
  end;

implementation

uses
  SysUtils, Dialogs;

{Purpose:
To add a new field to the table
Parameters:
None
Effects:
A new blank field descriptor is created and added to the internal list of
Field Descriptors which is reallocated to accomodate the new field
Returns:
Index of the new field in the array, or -1 if the operation failed}

function TTableRestructure.AddField: Integer;
var
  NewField: PFLDDesc;
  NewOperation: pCROpType;
begin
  Result := -1;
  if (Fields <> nil) then
  begin
    ReallocMem(Fields, (LocalFieldCount + 1) * SizeOf(FLDDesc));
    ReallocMem(Operations, (LocalFieldCount + 1) * SizeOf(CROpType));
    {Move to the new field and empty it out}
    NewField := Fields;
    Inc(NewField, LocalFieldCount);
    FillChar(NewField^, SizeOf(FLDDesc), 0);
    NewField^.iFldNum := LocalFieldCount + 1;
    {Move to the new operation and set it to add}
    NewOperation := Operations;
    Inc(NewOperation, LocalFieldCount);
    NewOperation^ := crAdd;
    Inc(LocalFieldCount);
    {Return the new fields index}
    Result := LocalFieldCount - 1;
  end;
end;

{Purpose: To create a new instance of this class and initialize it's data
Parameters: None
Effects: See purpose}

constructor TTableRestructure.Create;
begin
  Fields := nil;
  Operations := nil;
  LocalFieldCount := 0;
end;

{Purpose:
To delete a specific field from the tables description
Parameters:
Index - Index of the field that is to be removed
Effects:
The field is removed from the array of Field Descriptors and the memory that contains the list
is reallocated
Returns:
True if the operation was successfull, False otherwise}

function TTableRestructure.DeleteField(Index: Integer): Boolean;
var
  FieldBefore,
    FieldAfter: PFLDDesc;
  OperationBefore,
    OperationAfter: PCROpType;
begin
  Result := False;
  if (Fields <> nil) and (LocalFieldCount > 0) and (Index >= 0) and (Index < LocalFieldCount) then
  begin
    {Find the spot before and after the field to delete}
    FieldBefore := Fields;
    FieldAfter := Fields;
    Inc(FieldBefore, Index);
    Inc(FieldAfter, Index + 1);
    {Find the spot before and after the operation to delete}
    OperationBefore := Operations;
    OperationAfter := Operations;
    Inc(OperationBefore, Index);
    Inc(OperationAfter, Index + 1);
    {Now copy the data over the field to delete}
    Move(FieldAfter^, FieldBefore^, (LocalFieldCount - Index) * SizeOf(FLDDesc));
    Move(OperationAfter^, OperationBefore^, (LocalFieldCount - Index) * SizeOf(CROpType));
    {Now shrink the allocated memory}
    Dec(LocalFieldCount);
    ReallocMem(Fields, LocalFieldCount * SizeOf(FLDDesc));
    ReallocMem(Operations, LocalFieldCount * SizeOf(CROpType));
    Result := True;
  end;
end;

{Purpose: To destroy an instance of this class and any memory that was allocated
Parameters: None
Effects: See purpose}

destructor TTableRestructure.Destroy;
begin
  DestroyFieldDescriptors;
end;

{Purpose: To destroy an array of field descriptors
Parameters: None
Effects: The Field Descriptors are freed, and the pointer set to nil}

procedure TTableRestructure.DestroyFieldDescriptors;
begin
  if Fields <> nil then
  begin
    FreeMem(Fields);
    Fields := nil;
    FreeMem(Operations);
    Operations := nil;
    LocalFieldCount := 0;
  end;
end;

{Purpose: To show the details of any Error returned by the BDE routines
Parameters: ErrorCode - Code returned byt the BDE
Effects: None}

procedure TTableRestructure.DetailError(ErrorCode: DbiResult);
var
  ErrorInfo: DBIErrInfo;
  ErrorString: string;
  ErrorString2: string;
begin
  if (ErrorCode <> dbiERR_NONE) then
  begin
    Check(DbiGetErrorInfo(True, ErrorInfo));
    if (ErrorCode = ErrorInfo.iError) then
    begin
      ErrorString := 'Error Number: ' + IntToStr(ErrorInfo.iError) + #10 + #13;
      ErrorString := ErrorString + 'Error Code: ' + string(ErrorInfo.szErrcode) + #10 + #13;
      if (StrLen(ErrorInfo.szContext[1]) <> 0) then
        ErrorString := ErrorString + 'Context1: ' + string(ErrorInfo.szContext[1]) + #10 + #13;
      if (StrLen(ErrorInfo.szContext[2]) <> 0) then
        ErrorString := ErrorString + 'Context2: ' + string(ErrorInfo.szContext[2]) + #10 + #13;
      if (StrLen(ErrorInfo.szContext[3]) <> 0) then
        ErrorString := ErrorString + 'Context3: ' + string(ErrorInfo.szContext[3]) + #10 + #13;
      if (StrLen(ErrorInfo.szContext[4]) <> 0) then
        ErrorString := ErrorString + 'Context4: ' + string(ErrorInfo.szContext[4]) + #10 + #13;
    end
    else
    begin
      SetLength(ErrorString2, dbiMaxMsgLen + 1);
      Check(DbiGetErrorString(ErrorCode, PChar(ErrorString2)));
      SetLength(ErrorString2, StrLen(PChar(ErrorString2)));
      ErrorString := ErrorString + ErrorString2;
    end;
    ShowMessage(ErrorString);
  end;
end;

{Purpose: To find a particular field's index by it's name
Parameters: Name - Name of the field to find in the current list of fields
Effects: None
Returns: Index of the field if found, or -1 if not found}

function TTableRestructure.FindField(Name: string): Integer;
var
  Index: Integer;
begin
  Result := -1;
  Index := FieldCount - 1;
  while (Index >= 0) and (Result < 0) do
  begin
    if CompareText(FieldName[Index], Name) = 0 then
      Result := Index;
    Dec(Index);
  end;
end;

{Purpose: To return a pointer to a specified Field Descriptor
Parameters: Index - Index of the field descriptor
Effects: None
Returns: Pointer to a Field Descriptor or nil if Index isn't valid}

function TTableRestructure.GetField(Index: Integer): PFLDDesc;
begin
  Result := nil;
  if (Fields <> nil) and (Index >= 0) and (Index < LocalFieldCount) then
  begin
    Result := Fields;
    Inc(Result, Index);
  end;
end;

{Purpose: Get method for the FieldLength property
Parameters: Index - Index of a field descriptor
Effects: None
Returns: Length of the specified field or 0 if not field not found}

function TTableRestructure.GetFieldLength(Index: Integer): Word;
var
  Field: PFLDDesc;
begin
  Result := 0;
  Field := GetField(Index);
  if Field <> nil then
    Result := Field^.iLen;
end;

{Purpose: Get method for the FieldName property
Parameters: Index - Index of a field descriptor
Effects: None
Returns: Name of the specified field or '' if not field not found}

function TTableRestructure.GetFieldName(Index: Integer): string;
var
  Field: PFLDDesc;
begin
  Result := '';
  Field := GetField(Index);
  if Field <> nil then
    Result := string(Field^.szName);
end;

{Purpose: Get method for the FieldType property
Parameters: Index - Index of a field descriptor
Effects: None
Returns: Type of the specified field or -1 if not field not found}

function TTableRestructure.GetFieldType(Index: Integer): Word;
var
  Field: PFLDDesc;
begin
  Result := 0;
  Field := GetField(Index);
  if Field <> nil then
    Result := Field^.iFldType;
end;

{Purpose: Get method for the FieldUnits property
Parameters: Index - Index of a field descriptor
Effects: None
Returns: Units1 of the specified field or -1 if not field not found}

function TTableRestructure.GetFieldUnits(Index: Integer): Word;
var
  Field: PFLDDesc;
begin
  Result := 0;
  Field := GetField(Index);
  if Field <> nil then
    Result := Field^.iUnits1;
end;

{Purpose: To get a pointer to an operation type
Parameters: Index - Index of the operation that is desired
Effects: None
Returns: See purpose}

function TTableRestructure.GetOperation(Index: Integer): PCROpType;
begin
  Result := nil;
  if (Index >= 0) and (Index < FieldCount) then
  begin
    Result := Operations;
    Inc(Result, Index);
  end;
end;

{Purpose: To assign a new operation.
Parameters: Index - Index of the operation that is desired
Effects: None
Returns: None}

procedure TTableRestructure.SetOperation(Index: Integer; OpType: PCROpType);
var
  ModifyOperations: PCROpType;
begin
  ModifyOperations := Operations;
  Inc(ModifyOperations, Index);
  ModifyOperations^ := crModify;
end;

{Purpose:
To load in the table structure of the specified table
Parameters:
Table - Table whose structure will be loaded into memory
Effects:
Any previous structure is destroyed and replaced by the new structure if the table could be
opened successfully}

procedure TTableRestructure.LoadTableStructure(Table: TTable);
var
  Index: Integer;
  Field: PFLDDesc;
begin
  DestroyFieldDescriptors;
  if (Table <> nil) then
  begin
    Table.Open;
    LocalFieldCount := Table.FieldCount;
    Fields := AllocMem(LocalFieldCount * SizeOf(FLDDesc));
    try
      Operations := AllocMem(LocalFieldCount * SizeOf(CROpType));
      try
        FillChar(Operations^, LocalFieldCount * SizeOf(CROpType), crNOOP);
        Check(DbiGetFieldDescs(Table.Handle, Fields));
        Field := Fields;
        for Index := 1 to LocalFieldCount do
        begin
          Field^.iFldNum := Index;
          Inc(Field);
        end;
      except
        FreeMem(Operations);
        Operations := nil;
        raise;
      end;
    except
      FreeMem(Fields);
      Fields := nil;
      raise;
    end;
  end;
end;

{Purpose: No real purpose, other than for dumping out the current field data
Parameters: None
Effects: None}

procedure TTableRestructure.PrintStructure;
var
  Index: Integer;
  Field: pFLDDesc;
  Op: PCROpType;
  Item: string;
  List: string;
begin
  List := '# - Op - Type - Name' + #10#13;
  Field := Fields;
  Op := Operations;
  for Index := 0 to LocalFieldCount - 1 do
  begin
    Item := Format('%d - %x - %d - %s', [Field^.iFldNum, Byte(Op^), FieldType[Index], Field^.szName]);
    List := List + Item + #10 + #13;
    Inc(Field);
    Inc(Op);
  end;
  ShowMessage(List);
end;

{Purpose:
To modify a existing table to match the given field descriptors
Parameters:
Table - Table whose structure will be replaced by the structure in memory
Effects:
The table's structure is modified to match the current structure in memory. Once this is done, changes
can not be undone.}

procedure TTableRestructure.SaveTableStructure(Table: TTable);
var
  TableDesc: CRTblDesc;
  hDb: hDBIDb;
begin
  Table.Open;
  FillChar(TableDesc, sizeof(TableDesc), 0);
  {Get the database handle from the table's cursor handle...}
  Check(DbiGetObjFromObj(hDBIObj(Table.Handle), objDATABASE, hDBIObj(hDb)));
  StrPCopy(TableDesc.szTblName, Table.TableName);
  TableDesc.iFldCount := LocalFieldCount;
  TableDesc.pecrFldOp := Operations;
  TableDesc.pFldDesc := Fields;
  Table.Close;
  DetailError(DbiDoRestructure(hDb, 1, @TableDesc, nil, nil, nil, False));
end;

{Purpose: Set method for the FieldLength property
Parameters: Index - Index of the Field to modify / Value - New length of the field
Effects: The field descriptor is modified to reflect the change}

procedure TTableRestructure.SetFieldLength(Index: Integer; const Value: Word);
var
  Field: PFLDDesc;
  Operation: PCROpType;
begin
  Field := GetField(Index);
  if Field <> nil then
  begin
    Field^.iLen := Value;
    Operation := GetOperation(Index);
    if Operation^ <> crAdd then
      Operation^ := crMODIFY;
  end;
end;

{Purpose: Set method for the FieldName property
Parameters: Index - Index of the Field to modify / Value - New Name of the field
Effects: The field descriptor is modified to reflect the change}

procedure TTableRestructure.SetFieldName(Index: Integer; const Value: string);
var
  Field: PFLDDesc;
  Operation: PCROpType;
begin
  Field := GetField(Index);
  if Field <> nil then
  begin
    StrPCopy(Field^.szName, Value);
    Operation := GetOperation(Index);
    if Operation^ <> crAdd then
      Operation^ := crMODIFY;
  end;
end;

{Purpose: Set method for the FieldType property
Parameters: Index - Index of the Field to modify / Value - New Type of the field
Effects: The field descriptor is modified to reflect the change}

procedure TTableRestructure.SetFieldType(Index: Integer; const Value: Word);
var
  Field: PFLDDesc;
  Operation: PCROpType;
begin
  Field := GetField(Index);
  if Field <> nil then
  begin
    Field^.iFldType := Value;
    Operation := GetOperation(Index);
    if Operation^ <> crAdd then
      Operation^ := crMODIFY;
  end;
end;

{Purpose: Set method for the FieldUnits property
Parameters: Index - Index of the Field to modify / Value - New units of the field
Effects: The field descriptor is modified to reflect the change}

procedure TTableRestructure.SetFieldUnits(Index: Integer; const Value: Word);
var
  Field: PFLDDesc;
  Operation: PCROpType;
begin
  Field := GetField(Index);
  if Field <> nil then
  begin
    Field^.iUnits1 := Value;
    Operation := GetOperation(Index);
    if Operation^ <> crAdd then
      Operation^ := crMODIFY;
  end;
end;

end.

SQL Super INSERT/UPDATE Macro Class

Problem/Question/Abstract:

SQL Super INSERT/UPDATE Macro Class

Answer:

Ever got tired of dynamically generating SQL insert and update statements ?. Lots of virtually unreadable constructs such as things like .. (assume Data1:string Data2: integer Data3:TdateTime)

SqlCmd := 'insert into MyTable (Field1,Field2,Field2) values (' +  
                  QuotedStr(Data1) + ',' + IntToStr(Data2) + ',' + 'to_date('
                 + QuotedStr(FormatdateTime('dd/mm/yyyy',Data3)) + ','
                 + QuotedStr('dd/mm/yyyy') + '))';

{Horrible! and it gets worse as the column count gets higher}

This Class takes all the sweat out of this.

A single TQuery is created that handles ALL the SELECT,INSERT,UPDATE and DELETE operations.

FEATURES :

Support for ORACLE and MS-SQL (DateTimes are handled differently by these systems)
Would be grateful if anyone has Interbase,Informix or DB2 that can add functionality for these systems.

DebugMode which display the errant SQL statement and allows modification to correct it. The modified code can be cut to clipboard and is automatically saved to file LastSqlErr.sql on closing debug window.

Automatic error message dialogs or user handled errors via property LastErrorMess and LastSqlCommand.

Single value SQL select returns implemented AsString,AsInteger etc.

INSERT,UPDATE and DELETE super macro methods.


BASIC BUILDING PRIMITIVE FUNCTIONS :

There are a few primitive functions that are used by the Class, but are user callable if required.

    function SqlDateToStr(const Dte : TDateTime) : string;
    function StrToSqlDate(const DateStr : string) : TDateTime;

These functions are used to convert MS-SQL DateTimes to String and TDateTime. MS-SQL DateTimes are in format 'dd-MMM-yyyy hh:nn:ss.zzz'

   function sqlStr(...) : string;

This function is a super set of Borlands QuotedStr(). It has many overloads allowing the conversion of all required datatypes to a SQL string. Str quotes and trailing commas are handled (with comma being TRUE by default). One interesting oveload is an argument of "array of variant" which allows you to specify
an array of differing types to be converted to a SQL string list.

Examples:
   sqlStr('Harry');                 // Returns 'Harry', (Quotes are inculded)
   sqlStr(345.55);                   // Returns 345.55, (No Quotes)
   sqlStr(['GTR',8,Now]);     // 'GTR',8,'23-Oct-2002 13:44:23.000'


CLASS CONSTRUCTOR

Create(const DatabaseName : string; DatabaseSystemType : TSQLSystem);

    Used to create an instance of the object.
    eg.
    var MySql : TSQLCommand;
    MySql := TSQLCommand.Create(MyDb.DatabaseName,sysOracle);  // or
    MySql := TSQLCommand.Create('HELPDESK',sysOracle)
    DatabaseName is the DatabaseName of an open TDatabase Connection


CLASS PROPERTIES :

SqlQuery : TQuery                        -  Not normally used but can be set as a  TDatasource DataSet property for                                                                 TDBGrids etc.

LastErrorMess : string                  - Last Error message of a failed SQL statement

LastSQLCommand : string          - Last SQL statement of failed SQL

AutoErrorMessage : boolean       -  Auto display Error Dialogs [Yes/No]

DebugMode : boolean                   -  Pops up Errant SQL statement and allows mods

TerminateOnError : boolean        -  Terminate app is SQL staement error [Yes/No]

DatabaseName : string                    -  Set by constructor Create(), but can be  changed at runtime

DatabaseSystem : TSQLSystem     - Set by constructor Create(), but can be  Changed at run time


CLASS METHODS :

MISCELLANEOUS
SystemTime : TDateTime -  Returns System DateTime of the Database (System independent)

SystemUser : string            -  Returns Logged in Username of the Database (System independent)


SINGLE VALUE SELECT RETURNS
These function methods are designed to return a single value from a SQL query, such as AsString('select name from emp where id = 990') All the below methods have an alternate overloaded version that takes a select string + array of const formatting options. eg. AsString('select name from emp where id = %d',[990])
See Borlands Format() function for more info.

AsString(const SQLStatement : string) : string
AsInteger(const SQLStatement : string) : integer
AsFloat(const SQLStatement : string) : double
AsDateTime(const SQLStatement : string) : TDateTime


FREE FORM USER COMMANDS
These methods allow for ad-hoc user SQL constructs. The property SqlQury may be used with the commands after Open for Fields retieval or display in a TDBGrid by setting a TDataSource Dataset property to SqlQuery.
Once again FreeFormOpen and Exec have an alternate overloaded option of select string + array of const formatting options.

FreeFormOpen(const SQLStatement : string) : boolean -  Used to open a user ad-hoc query

FreeFormClose  - Used to close the ad-hoc query as opened by FreeFormOpen

Exec(const SQLStatement : string) : boolean  - Used for non cursor queries such as UPDATE etc.


DBMS MACRO COMMANDS
These commands take the sting out of SQL inserts and updates. The Column names are supplied as an array of strings. The update/insert values are specified in an array of variant. Specify tablename and where clause if required and the method will correctly format the SQL statement for the relevant system and execute it.

Insert(ColNames : array of string; Values : array of variant; const TableName : string) : boolean

Update(ColNames : array of string; Values : array of variant; const WhereClause : string; const TableName : string) : boolean

Delete(const WhereClause : string; const TableName : string) : boolean
    (Not that clever - here for completeness  can also be achieved via  Exec('delete from emp where id = 99') )


SIMPLIFIED EXAMPLE OF USE :

procedure MyUpdates;
var
  Name: string;
  SQL: TSQLCommand;
  ID: integer;
begin
  SQL := TSQL.Command.Create('MYBASE', sysOracle);
  SQL.DebugMode := true;
  Label1.Caption := SQL.SystemUser;
  Label2.Caption := SQL.SystemTime;
  ID := SQL.AsInteger('select ID from EMP where TAXNUM = 345');
  Name := SQL.AsString('select NAME from EMP where ID = %d', [ID]);

  SQL.Insert(['NAME', 'TAXDATE', 'ID', 'FLAG'],
    [Name, Now, ID, 0], 'NEWTAXTAB');

  SQL.Update(['TAXDATE', 'FLAG'],
    [Now, 5],
    'NAME = ' + sqlStr(Name, false), OLDTAXTAB);

  SQL.Delete('FLAG = 99', 'ARCTAXTAB');

  SQL.FreeFormOpen('select * from EMP);
    Label3.Caption := SQL.SqlQuery.Fields[0].AsString;
    MyDataSource.DataSet := SQL.SqlQuery;

    ...
    ...

    SQL.FreeFormClose;
    SQL.Free;
end;

Of course the return values of the inserts etc should be checked for TRUE and FALSE, but as stated it is a simplified example for clarity.



unit MahSql;

// =============================================================================
// Mike Heydon Sep 2002
// SQL programming aids
// There must be an open TDatabase connection
// =============================================================================

interface
uses Forms, StdCtrls, SysUtils, Dialogs, DBTables, Controls, DateUtils,
  ComCtrls, ExtCtrls, Buttons, Variants;

// NOTE : Uses DateUtils and Variants are Delphi 6 - remove for lower versions
type
  TSQLSystem = (sysOracle, sysMsSql); // Informix,DB2 users help appreciated here.

{TSQLCOMMAND CLASS}
  TSQLCommand = class(TObject)
  protected
    procedure ShowDebug;
    function OpenQuery(const Command: string;
                       CheckNull: boolean = true): boolean; virtual;
    function ExecQuery(const Command: string): boolean; virtual;
    function ExecFunc(const Func: string): string;
  private
    Memo: TMemo;
    Form: TForm;
    Status: TStatusBar;
    Panel: TPanel;
    btnRetry,
    btnClose: TBitBtn;
    FDatabaseSystem: TSQLSystem;
    FDebugID: char;
    FTerminateOnError,
    FDebugMode,
    FAutoErrorMessage: boolean;
    FLastSQLCommand,
    FLastErrorMess: string;
    Query: TQuery;
    procedure FormClose(Sender: TObject; var Action: TCloseAction);
    procedure RetryClick(Sender: TObject);
    procedure SetDatabaseName(const NewValue: string);
    function GetDatabaseName: string;
  public
    constructor Create(const DatabaseName: string;
                       DatabaseSystemType: TSQLSystem);
    destructor Destroy; override;

    // Misc functions
    function SystemTime: TDateTime;
    function SystemUser: string;

    // Value returns calls - Always takes field[0] regardles of select cmd
    // Optional overload with formating eg.
    // AsString('select * from tab1 where N=%s and D=%d,['Fred',99]);
    function AsString(const SQLStatement: string): string; overload;
    function AsString(const SQLStatement: string;
                      FormatArguments: array of const): string; overload;
    function AsInteger(const SQLStatement: string): integer; overload;
    function AsInteger(const SQLStatement: string;
                       FormatArguments: array of const): integer; overload;
    function AsFloat(const SQLStatement: string): double; overload;
    function AsFloat(const SQLStatement: string;
                     FormatArguments: array of const): double; overload;
    function AsDateTime(const SQLStatement: string): TDateTime; overload;
    function AsDateTime(const SQLStatement: string;
                        FormatArguments: array of const): TDateTime; overload;

    // Free Form
    function FreeFormOpen(const SQLStatement: string): boolean; overload;
    function FreeFormOpen(const SQLStatement: string;
                          FormatArguments: array of const): boolean; overload;

    procedure FreeFormClose;

    function Exec(const SQLStatement: string): boolean; overload;
    function Exec(const SQLStatement: string;
                  FormatArguments: array of const): boolean; overload;

    // DBMS Inserts and Updates
    function Insert(ColNames: array of string;
                    Values: array of variant;
                    const TableName: string): boolean;

    function Update(ColNames: array of string;
                    Values: array of variant;
                    const WhereClause: string;
                    const TableName: string): boolean;

    function Delete(const WhereClause: string;
                    const TableName: string): boolean;

    // Properties
    property SqlQuery: TQuery read Query;
    property LastErrorMess: string read FLastErrorMess;
    property LastSQLCommand: string read FLastSQLCommand;
    property AutoErrorMessage: boolean read FAutoErrorMessage
                                       write FAutoErrorMessage;
    property DebugMode: boolean read FDebugMode write FDebugMode;
    property TerminateOnError: boolean read FTerminateOnError
                                       write FTerminateOnError;
    property DatabaseName: string read GetDatabaseName
                                  write SetDatabaseName;
    property DatabaseSystem: TSQLSystem read FDatabaseSystem
                                        write FDatabaseSystem;
  end;

  // ===================================
  // Primitive Class and User Functions
  // ===================================

  // Date routines
function SqlDateToStr(const Dte: TDateTime): string;
function StrToSqlDate(const DateStr: string): TDateTime;

// Quoted SQL string conversion routines
function sqlStr(Values: array of variant;
                DateTimeType: TSQLSystem = sysOracle): string; overload;
function sqlStr(Dte: TDateTime; DateTimeType: TSQLSystem;
                AddComma: boolean = true): string; overload;
function sqlStr(Dbl: double; NumDecimals: integer;
                AddComma: boolean = true): string; overload;
function sqlStr(const St: string; AddComma: boolean = true): string; overload;
function sqlStr(Num: integer; AddComma: boolean = true): string; overload;
function sqlStr(Flt: extended; AddComma: boolean = true): string; overload;
function sqlStr(Flt: extended; NumDecimals: integer;
                AddComma: boolean = true): string; overload;

// -----------------------------------------------------------------------------
implementation

const
  CrLf = #13#10; // Carriage Return / LineFeed pair

  // =========================
  // General Functions
  // =========================

  // ============================================
  // Return an MS-SQL date compatable string
  // ============================================

function SqlDateToStr(const Dte: TDateTime): string;
begin
  Result := FormatdateTime('dd-MMM-yyyy hh:nn:ss.zzz', Dte);
end;

// ============================================
// Return an SQL date from string
// Format 'dd-MMM-yyyy hh:nn:ss.zzz'
// ============================================

function StrToSqlDate(const DateStr: string): TDateTime;
var
  yyyy, dd, mm, hh, nn, ss, zzz: word;
  MMM: string;
  RetVar: TDateTime;
begin
  mm := 0;
  dd := StrToIntDef(copy(DateStr, 1, 2), 0);
  MMM := UpperCase(copy(DateStr, 4, 3));
  yyyy := StrToIntDef(copy(DateStr, 8, 4), 0);
  hh := StrToIntDef(copy(DateStr, 13, 2), 0);
  nn := StrToIntDef(copy(DateStr, 16, 2), 0);
  ss := StrToIntDef(copy(DateStr, 19, 2), 0);
  zzz := StrToIntDef(copy(DateStr, 22, 3), 0);

  if MMM = 'JAN' then
    mm := 1
  else if MMM = 'FEB' then
    mm := 2
  else if MMM = 'MAR' then
    mm := 3
  else if MMM = 'APR' then
    mm := 4
  else if MMM = 'MAY' then
    mm := 5
  else if MMM = 'JUN' then
    mm := 6
  else if MMM = 'JUL' then
    mm := 7
  else if MMM = 'AUG' then
    mm := 8
  else if MMM = 'SEP' then
    mm := 9
  else if MMM = 'OCT' then
    mm := 10
  else if MMM = 'NOV' then
    mm := 11
  else if MMM = 'DEC' then
    mm := 12;

  if not TryEncodeDateTime(yyyy, mm, dd, hh, nn, ss, zzz, Retvar) then
    RetVar := 0.0;

  Result := Retvar;
end;

// =================================================
// SQL string convertors - QuotedStr() Super Set
// =================================================

// TDATETIME

function sqlStr(Dte: TDateTime; DateTimeType: TSQLSystem;
  AddComma: boolean = true): string; overload;
var
  RetVar: string;
begin
  if DateTimeType = sysOracle then
    RetVar := 'to_date(' +
              QuotedStr(FormatdateTime('dd/mm/yyyy hh:nn:ss', Dte)) + ',' +
              QuotedStr('DD/MM/YYYY HH24:MI:SS') + ')'
  else
    RetVar := QuotedStr(SqlDateToStr(Dte));

  if AddComma then
    RetVar := Retvar + ',';
  Result := RetVar;
end;

// DOUBLE

function sqlStr(Dbl: double; NumDecimals: integer;
  AddComma: boolean = true): string; overload;
var
  Retvar: string;
begin
  RetVar := FormatFloat('###########0.' +
    StringOfChar('0', NumDecimals), Dbl);
  if AddComma then
    Retvar := Retvar + ',';
  Result := RetVar;
end;

// STRING

function sqlStr(const St: string;
  AddComma: boolean = true): string; overload;
var
  Retvar: string;
begin
  RetVar := QuotedStr(St);
  if AddComma then
    Retvar := RetVar + ',';
  Result := RetVar;
end;

// INTEGER

function sqlStr(Num: integer; AddComma: boolean = true): string; overload;
var
  RetVar: string;
begin
  RetVar := IntToStr(Num);
  if AddComma then
    RetVar := Retvar + ',';
  Result := RetVar;
end;

// EXTENDED

function sqlStr(Flt: extended; AddComma: boolean = true): string; overload;
var
  Retvar: string;
begin
  RetVar := FloatToStr(Flt);
  if AddComma then
    Retvar := Retvar + ',';
  Result := RetVar;
end;

// EXTENDED WITH PRECICISION

function sqlStr(Flt: extended; NumDecimals: integer;
  AddComma: boolean = true): string; overload;
var
  Retvar: string;
begin
  RetVar := FormatFloat('###########0.' +
    StringOfChar('0', NumDecimals), Flt);
  if AddComma then
    Retvar := Retvar + ',';
  Result := RetVar;
end;

// ARRAY OF VARIANT eg. [0,'Fred',45.44,'Married',Date]

function sqlStr(Values: array of variant;
  DateTimeType: TSQLSystem = sysOracle): string;
var
  RetVar: string;
  i: integer;
  VType: TVarType;
begin
  RetVar := '';

  for i := 0 to High(Values) do
  begin
    VType := VarType(Values[i]);

    case VType of
      varDate: RetVar := RetVar + sqlStr(TDateTime(Values[i]),
          DateTimeType, false);

      varInteger,
        varSmallint,
        varShortint,
        varByte,
        varWord,
        varLongword,
        varInt64: RetVar := RetVar + IntToStr(Values[i]);

      varSingle,
        varDouble,
        varCurrency: RetVar := RetVar + FloatToStr(Values[i]);

      varStrArg,
        varOleStr,
        varString: RetVar := RetVar + QuotedStr(Values[i]);
    else
      RetVar := RetVar + '????';
    end;

    RetVar := RetVar + ',';
  end;

  Delete(RetVar, length(RetVar), 1);
  Result := Retvar;
end;

// =============================================================================
// TSQLCommand Class
// =============================================================================

// =========================
// Construct & Destroy
// =========================

constructor TSQLCommand.Create(const DatabaseName: string;
  DatabaseSystemType: TSQLSystem);
begin
  Query := TQuery.Create(nil);
  Query.DatabaseName := DatabaseName;
  FLastErrorMess := '';
  FLastSQLCommand := '';
  FAutoErrorMessage := false;
  FDebugMode := false;
  FTerminateOnError := false;
  FDatabaseSystem := DatabaseSystemType;
end;

destructor TSQLCommand.Destroy;
begin
  Query.Free;
end;

// =============================
// Property Get/Set Methods
// =============================

procedure TSQLCommand.SetDatabaseName(const NewValue: string);
begin
  Query.Close;
  Query.DatabaseName := NewValue;
end;

function TSQLCommand.GetDatabaseName: string;
begin
  Result := Query.DatabaseName;
end;

// ==================================================
// Returns a string value from MS-SQL functions
// ==================================================

function TSQLCommand.ExecFunc(const Func: string): string;
var
  Value: string;
begin
  Value := '';

  if OpenQuery(Func, false) then
  begin
    SetLength(Value, Query.RecordSize + 1);
    Query.GetCurrentRecord(PChar(Value));
    SetLength(Value, StrLen(PChar(Value)));
  end;

  Query.Close;
  Result := Value;
end;

// =============================================================
// Show and Save Debug Statement if DebugMode = true - INTERNAL
// =============================================================

// Save on form close

procedure TSQLCommand.FormClose(Sender: TObject; var Action: TCloseAction);
begin
  Memo.Lines.SaveToFile(ExtractFilePath(Application.ExeName) + 'LastSqlErr.sql');
end;

// Retry click

procedure TSQLCommand.RetryClick(Sender: TObject);
begin
  Query.SQL.Assign(memo.Lines);

  try
    if FDebugID = 'O' then
      Query.Open
    else
      Query.ExecSql;
    MessageDlg('SQL Command Ran OK', mtInformation, [mbOk], 0);
  except
    on E: Exception do
      MessageDlg('SQL Command Failed' + CrLf + CrLf + E.Message, mtError, [mbOk], 0);
  end;
end;

procedure TSQLCommand.ShowDebug;
var
  FName: string;
begin
  FName := ExtractFilePath(Application.ExeName) + 'LastSqlErr.sql';
  Form := TForm.Create(nil);
  Form.BorderIcons := Form.BorderIcons - [biMinimize];
  Status := TStatusBar.Create(Form);
  Status.Parent := Form;
  Status.SimplePanel := true;
  Status.SimpleText := '  ' + FName;
  Form.Height := 350;
  Form.Width := 600;
  Form.Caption := 'SQL Error';
  Form.Position := poScreenCenter;
  Panel := TPanel.Create(Form);
  Panel.Parent := Form;
  Panel.Align := alTop;
  Memo := TMemo.Create(Form);
  Memo.Parent := Form;
  Memo.Align := alClient;
  Memo.Font.Name := 'Courier New';
  Memo.Font.Size := 9;
  Memo.Lines.Assign(Query.SQL);
  btnClose := TBitBtn.Create(Form);
  btnClose.Parent := Panel;
  btnClose.Kind := bkClose;
  btnClose.Left := Form.Width - 90;
  btnClose.Top := 8;
  btnClose.Anchors := [akRight, akBottom];
  btnRetry := TBitBtn.Create(Form);
  btnRetry.Parent := Panel;
  btnRetry.Kind := bkRetry;
  btnRetry.Left := 8;
  btnRetry.Top := 8;
  btnRetry.ModalResult := mrNone;
  btnRetry.OnClick := RetryClick;
  Panel.Align := alBottom;
  Form.OnClose := FormClose;
  Form.ShowModal;
  Form.Free; // Free Form and all components in it
end;

// ===============================================
// Open the Query with error checking - INTERNAL
// ===============================================

function TSQLCommand.OpenQuery(const Command: string;
  CheckNull: boolean = true): boolean;
var
  Retvar,
    NullValue: boolean;
begin
  FDebugID := 'O';
  Retvar := false;
  Query.Close;
  FLastSQLCommand := Command;
  Query.SQL.Text := Command;

  try
    Query.Open;
    if CheckNull then
      NullValue := Query.EOF or Query.Fields[0].IsNull
    else
      NullValue := Query.EOF;

    if NullValue then
    begin
      FLastErrorMess := 'No Records in DataSet';
      if FAutoErrorMessage then
        MessageDlg('Open Query Failed!' + CrLf + CrLf + FLastErrorMess, mtError,
          [mbOk], 0);
    end
    else
      Retvar := true;
  except
    on E: Exception do
    begin
      FLastErrorMess := E.Message;
      if FAutoErrorMessage then
        MessageDlg('Open Query Failed!' + CrLf + CrLf + E.Message, mtError, [mbOk],
          0);
      if FDebugMode then
        ShowDebug;
      if FTerminateOnError then
      begin
        Application.Terminate;
        raise Exception.Create('');
      end;
    end;
  end;

  Result := Retvar;
end;

// ================================================
// Exec a query - UPDATE/INSERT etc - INTERNAL
// ================================================

function TSQLCommand.ExecQuery(const Command: string): boolean;
var
  Retvar: boolean;
begin
  FDebugID := 'E';
  Retvar := false;
  Query.Close;
  FLastSQLCommand := Command;
  Query.SQL.Text := Command;

  try
    Query.ExecSQL;
    Retvar := true;
  except
    on E: Exception do
    begin
      FLastErrorMess := E.Message;
      if FAutoErrorMessage then
        MessageDlg('Exec Query Failed!' + CrLf + CrLf + E.Message, mtError, [mbOk],
          0);
      if FDebugMode then
        ShowDebug;
      if FTerminateOnError then
      begin
        Application.Terminate;
        raise Exception.Create('');
      end;
    end;
  end;

  Result := Retvar;
end;

// ====================================================================
// Single Result sets with alternate overload of string/format array
// ====================================================================

// STRING

function TSQLCommand.AsString(const SQLStatement: string): string;
var
  Retvar: string;
begin
  Query.UniDirectional := true;

  if OpenQuery(SQLStatement) then
  begin
    Retvar := Query.Fields[0].AsString;
    Query.Close;
  end
  else
    Retvar := '';

  Result := Retvar;
end;

function TSQLCommand.AsString(const SQLStatement: string;
  FormatArguments: array of const): string;
begin
  Result := AsString(Format(SQLStatement, FormatArguments));
end;

// INTEGER

function TSQLCommand.AsInteger(const SQLStatement: string): integer;
var
  Retvar: integer;
begin
  Query.UniDirectional := true;

  if OpenQuery(SQLStatement) then
  begin
    Retvar := Query.Fields[0].AsInteger;
    Query.Close;
  end
  else
    Retvar := 0;

  Result := Retvar;
end;

function TSQLCommand.AsInteger(const SQLStatement: string;
  FormatArguments: array of const): integer;
begin
  Result := AsInteger(Format(SQLStatement, FormatArguments));
end;

// DOUBLE

function TSQLCommand.AsFloat(const SQLStatement: string): double;
var
  Retvar: double;
begin
  Query.UniDirectional := true;

  if OpenQuery(SQLStatement) then
  begin
    Retvar := Query.Fields[0].AsFloat;
    Query.Close;
  end
  else
    Retvar := 0.0;

  Result := Retvar;
end;

function TSQLCommand.AsFloat(const SQLStatement: string;
  FormatArguments: array of const): double;
begin
  Result := AsFloat(Format(SQLStatement, FormatArguments));
end;

// TDATETIME

function TSQLCommand.AsDateTime(const SQLStatement: string): TDateTime;
var
  Retvar: TDateTime;
begin
  Query.UniDirectional := true;

  if OpenQuery(SQLStatement) then
  begin
    Retvar := Query.Fields[0].AsDateTime;
    Query.Close;
  end
  else
    Retvar := 0.0;

  Result := Retvar;
end;

function TSQLCommand.AsDateTime(const SQLStatement: string;
  FormatArguments: array of const): TDateTime;
begin
  Result := AsDateTime(Format(SQLStatement, FormatArguments));
end;

// ====================================================
// Easy way to open and close free form statements
// ====================================================

function TSQLCommand.FreeFormOpen(const SQLStatement: string): boolean;
begin
  Query.UniDirectional := false;
  Result := OpenQuery(SQLStatement, false);
end;

function TSQLCommand.FreeFormOpen(const SQLStatement: string;
  FormatArguments: array of const): boolean;
begin
  Query.UniDirectional := false;
  Result := OpenQuery(Format(SQLStatement, FormatArguments), false);
end;

// CLOSE SQL

procedure TSQLCommand.FreeFormClose;
begin
  Query.Close;
end;

// EXEC SQL

function TSQLCommand.Exec(const SQLStatement: string): boolean;
begin
  Result := ExecQuery(SQLStatement);
end;

function TSQLCommand.Exec(const SQLStatement: string;
  FormatArguments: array of const): boolean;
begin
  Result := ExecQuery(Format(SQLStatement, FormatArguments));
end;

// ================================
// Inset/Update & Delete Commands
// ================================

// DBMS INSERT

function TSQLCommand.Insert(ColNames: array of string;
  Values: array of variant;
  const TableName: string): boolean;
var
  Cmd: string;
  VType: TVarType;
  Retvar: boolean;
  i: integer;
begin
  Query.UniDirectional := true;

  if (High(ColNames) = -1) or (High(Values) = -1) or
    (High(ColNames) <> High(Values)) then
  begin
    FLastErrorMess := 'Insert Statement ColNames()/Values() Mismatched';
    if FAutoErrorMessage then
      MessageDlg('Insert Failed!' + CrLf + CrLf + FLastErrorMess,
        mtError, [mbOk], 0);
    Retvar := false;
  end
  else
  begin
    Cmd := 'insert into ' + TableName + CrLf + '(' + ColNames[0];
    for i := 1 to High(ColNames) do
      Cmd := Cmd + ',' + ColNames[i];
    Cmd := Cmd + ')' + CrLf;
    Cmd := Cmd + 'values (';

    for i := 0 to High(Values) do
    begin
      VType := VarType(Values[i]);

      case VType of
        varDate: Cmd := Cmd + sqlStr(TDateTime(Values[i]),
            FDatabaseSystem, false);

        varInteger,
          varSmallint,
          varShortint,
          varByte,
          varWord,
          varLongword,
          varInt64: Cmd := Cmd + IntToStr(Values[i]);

        varSingle,
          varDouble,
          varCurrency: Cmd := Cmd + FloatToStr(Values[i]);

        varStrArg,
          varOleStr,
          varString: Cmd := Cmd + QuotedStr(Values[i]);
      else
        Cmd := Cmd + '????';
      end;

      Cmd := Cmd + ',';
    end;

    System.Delete(Cmd, length(Cmd), 1);
    Cmd := Cmd + ')';
    Retvar := ExecQuery(Cmd);
  end;

  Result := RetVar;
end;

// DBMS UPDATE

function TSQLCommand.Update(ColNames: array of string;
  Values: array of variant;
  const WhereClause: string;
  const TableName: string): boolean;
var
  Cmd, Parm: string;
  VType: TVarType;
  Retvar: boolean;
  i: integer;
begin
  Query.UniDirectional := true;

  if (High(ColNames) = -1) or (High(Values) = -1) or
    (High(ColNames) <> High(Values)) then
  begin
    FLastErrorMess := 'Update Statement ColNames()/Values() Mismatched';
    if FAutoErrorMessage then
      MessageDlg('Update Failed!' + CrLf + CrLf + FLastErrorMess,
        mtError, [mbOk], 0);
    Retvar := false;
  end
  else
  begin
    Cmd := 'update ' + TableName + ' set' + CrLf;

    for i := 0 to High(Values) do
    begin
      VType := VarType(Values[i]);

      case VType of
        varDate: Parm := sqlStr(TDateTime(Values[i]),
            FDatabaseSystem, false);

        varInteger,
          varSmallint,
          varShortint,
          varByte,
          varWord,
          varLongword,
          varInt64: Parm := IntToStr(Values[i]);

        varSingle,
          varDouble,
          varCurrency: Parm := FloatToStr(Values[i]);

        varStrArg,
          varOleStr,
          varString: Parm := QuotedStr(Values[i]);
      else
        Parm := '????';
      end;

      Cmd := Cmd + ColNames[i] + '=' + Parm + ',';
    end;

    System.Delete(Cmd, length(Cmd), 1);
    Cmd := Cmd + CrLf + 'where ' + WhereClause;
    Retvar := ExecQuery(Cmd);
  end;

  Result := RetVar;
end;

// DBMS DELETE

function TSQLCommand.Delete(const WhereClause: string;
  const TableName: string): boolean;
var
  Cmd: string;
begin
  Query.UniDirectional := true;
  Cmd := 'delete from ' + TableName + ' where ' + WhereClause;
  Result := ExecQuery(Cmd);
end;

// ============================
// Get the system date/time
// ============================

function TSQLCommand.SystemTime: TDateTime;
var
  Retvar: TDateTime;
begin
  Retvar := 0.0;
  Query.UniDirectional := true;

  if FDatabaseSystem = sysOracle then
  begin
    if OpenQuery('select sysdate from dual') then
      Retvar := Query.Fields[0].AsDateTime;
  end
  else
  begin
    if OpenQuery('select getdate()') then
      Retvar := Query.Fields[0].AsDateTime;
  end;

  Query.Close;
  Result := Retvar;
end;

// ============================
// Get the system user name
// ============================

function TSQLCommand.SystemUser: string;
var
  Retvar: string;
begin
  Retvar := '';
  Query.UniDirectional := true;

  if FDatabaseSystem = sysOracle then
  begin
    if OpenQuery('select user from dual') then
      Retvar := Query.Fields[0].AsString;
  end
  else
  begin
    Retvar := ExecFunc('select system_user');
  end;

  Query.Close;
  Result := Retvar;
end;
end.

Screen capture into a BMP file

Problem/Question/Abstract:

Screen capture into a BMP file

Answer:

This little routine grabs the whole screen, assigns it temporary to a bitmap and stores it into file "sample.bmp".

A potential problem:
If your system is set up to HiColor (32k colors = 15 bits per pixel), some programs will not be able to read the result since they are only capable to read 16 bits/ pixel.


procedure TForm1.Button1Click(Sender: TObject);
var
  DeskTopDC: HDc;
  DeskTopCanvas: TCanvas;
  DeskTopRect: TRect;
  Bitmap: TBitmap;
begin
  DeskTopDC := GetWindowDC(GetDeskTopWindow);
  DeskTopCanvas := TCanvas.Create;
  DeskTopCanvas.Handle := DeskTopDC;
  DeskTopRect := Rect(0, 0, Screen.Width, Screen.Height);
  Bitmap := TBitmap.Create;
  with Bitmap do
  begin
    Width := Screen.Width;
    Height := Screen.Height;
    PixelFormat := pfDevice;
  end;
  Bitmap.Canvas.CopyRect(DeskTopRect, DeskTopCanvas, DeskTopRect);
  Bitmap.SaveToFile('c:\temp\sample.bmp');
  Bitmap.Free;
  DesktopCanvas.Free;
  ReleaseDC(GetDeskTopWindow, DeskTopDC);
end;

Selection Sort

Problem/Question/Abstract:

Selection sort algorithm

Answer:

Selection Sort

An elementary sorting algorithm that is designed to minimize the number of exchanges that are performed. It works by making n-1 passes over the unsorted portion of the array, each time selecting the largest value. This value is then moved into its final sorted position with a single exchange.

procedure SelectionSort(Items: TStrings);
var
  i, n, maxIndex, topIndex: integer;
  Dummy: string;
begin
  n := Items.Count;

  for topIndex := n - 1 downto 1 do
  begin
    maxIndex := topIndex;
    for i := 0 to topIndex - 1 do
      if Items[i] > Items[maxIndex] then
        maxIndex := i;

    Dummy := Items[topIndex];
    Items[topIndex] := Items[maxIndex];
    Items[maxIndex] := Dummy;
  end;
end;

Compare two bitmaps

Problem/Question/Abstract:

How to compare two bitmaps

Answer:

If you really only need to know if they're 100% identical then there is a pretty fast way by reading the bitmaps in strings via a MemoryStream:

{ ... }
begin
  MemStream := TMemoryStream.Create;
  try
    Bmp1.SaveToStream(MemStream);
    MemStream.Position := 0;
    SetLength(S1, MemStream.Size);
    MemStream.Read(S1[1], Length(S1));
    MemStream.Clear;
    Bmp2.SaveToStream(MemStream);
    MemStream.Position := 0;
    SetLength(S2, MemStream.Size);
    MemStream.Read(S2[1], Length(S2));
  finally
    MemStream.Free;
  end;
  if S1 = S2 then
    {they are identically};
end;

How to rearrange items within a TListBox (2)

Problem/Question/Abstract:

I have a TListBox with, say, 10 strings, and I want to be able to use Drag and Drop to reorder those 10 items at runtime. How exactly do I do that?

Answer:

Here's the code I use to do list reordering. Create a new form, place a TListBox on it, set its DragMode property to dmAutomatic and connect the following event handlers.

procedure TForm1.ListBox1DragDrop(Sender, Source: TObject; X, Y: Integer);
var
  aListBox: TListBox;
  DropIndex: Integer;
begin
  aListBox := Sender as TListBox;
  DropIndex := aListBox.ItemAtPos(Point(X, Y), False);
  if aListBox.ItemIndex < DropIndex then
    dec(DropIndex);
  aListBox.Items.Move(aListBox.ItemIndex, DropIndex);
  aListBox.ItemIndex := DropIndex;
end;

procedure TForm1.ListBox1DragOver(Sender, Source: TObject; X, Y: Integer;
  State: TDragState; var Accept: Boolean);
begin
  Accept := Sender = ListBox1;
end;

Access the serial port in Windows XP

Problem/Question/Abstract:

How I do to access the serial or paralell port in Windows XP?

Answer:

The example below sends a char 'R' to the port, then reads a line until CR or LF is encountered, then processes a line via ParseData. Then all is repeated until Terminated is True.

procedure ProcessCOMPortData(FPortName: string);
var
  LPortHandle: THandle;
  LInBuffer: array[0..1023] of Char;
  LBytesWritten, LBytesRead: Cardinal;
  LOutBuffer: Char;
  LOverlapped: TOverlapped;
  LEvent: TEvent;
  LOldCommTimeouts, LCommTimeouts: TCommTimeouts;
  LPCommConfig: PCommConfig;
  LCommConfig: TCommConfig;
  CommConfigSize: Cardinal;
  LEOL: Boolean;
  LIndex: Integer;
begin
  ZeroMemory(@LOverlapped, SizeOf(TOverlapped));
  ZeroMemory(@LCommTimeouts, SizeOf(TCommTimeouts));
  ZeroMemory(@LCommConfig, SizeOf(TCommConfig));
  LPortHandle := INVALID_HANDLE_VALUE;
  LEvent := nil;
  LPCommConfig := nil;
  try
    CommConfigSize := 0;
    LPCommConfig := @LCommConfig;
    GetDefaultCommConfig(PChar(FPortName), LPCommConfig^, CommConfigSize);
    GetMem(LPCommConfig, CommConfigSize);
    GetDefaultCommConfig(PChar(FPortName), LPCommConfig^, CommConfigSize);
    LEvent := TEvent.Create(nil, True, False, '');
    LOverlapped.hEvent := LEvent.Handle;
    LPortHandle := CreateFile(PChar(FPortName), GENERIC_READ or GENERIC_WRITE, 0,
      nil, OPEN_EXISTING, FILE_FLAG_OVERLAPPED, 0);
    if (LPortHandle = INVALID_HANDLE_VALUE) then
      Exit;
    SetCommConfig(LPortHandle, LPCommConfig^, CommConfigSize);
    GetCommTimeouts(LPortHandle, LOldCommTimeouts);
    SetCommTimeouts(LPortHandle, LCommTimeouts);
    while not Terminated do
    begin
      PurgeComm(LPortHandle, PURGE_TXCLEAR or PURGE_RXCLEAR or
        PURGE_RXABORT or PURGE_TXABORT);
      LOutBuffer := 'R';
      WriteFile(LPortHandle, LOutBuffer, Length(LOutBuffer), LBytesWritten,
        @LOverlapped);
      GetOverlappedResult(LPortHandle, LOverlapped, LBytesWritten, True);
      if LBytesWritten = 1 then
      begin
        ZeroMemory(@LInBuffer, SizeOf(LInBuffer));
        ReadFile(LPortHandle, LInBuffer[0], 1, LBytesRead, @LOverlapped);
        case LEvent.WaitFor(50) of
          wrSignaled:
            begin
              GetOverlappedResult(LPortHandle, LOverlapped, LBytesRead, True);
              LEOL := False;
              LIndex := LBytesRead;
              while not LEOL and (LIndex < SizeOf(LInBuffer)) do
              begin
                ReadFile(LPortHandle, LInBuffer[LIndex], 1, LBytesRead, @LOverlapped);
                GetOverlappedResult(LPortHandle, LOverlapped, LBytesRead, True);
                LEOL := (LInBuffer[LIndex] = #$0A) or (LInBuffer[LIndex] = #$0D);
                Inc(LIndex);
              end;
              try
                ParseData(LInBuffer);
              except
              end;
            end;
          wrTimeout, wrAbandoned, wrError:
            begin
              Sleep(100);
            end;
        end;
      end;
    end;
  finally
    SetCommTimeouts(LPortHandle, LOldCommTimeouts);
    CloseHandle(LPortHandle);
    FreeAndNil(LEvent);
    if Assigned(LPCommConfig) then
      FreeMem(LPCommConfig);
  end;
end;

Personal settings and the windows registry

Problem/Question/Abstract:

What is the structure of the registry?
What settings to store in the registry, how to do so?

Answer:

Scope

This article is the third article in a series of four articles about personal settings. This article deals with the usage of the registry for retaining personal settings. It explains the working of the registry, how to read & write date in the registry from Delphi, and contains an example: a form which reads its previous position on the screen.

One thing every application i.m.h.o. should contain is a registration in the registry -the registry should have a clue in which directory your application has been stored. You may choose to have this handled by your installtion program, which is a logical place to do so. But the program can also do it itself, so that the user moving the directory with your application from the windows explorer can fix its own settings by simply starting your program.

The registry - its structure

The registry was introduced by Microsoft with Windows 95. In Windows 95 and Windows 98, there are 2 files in your windows directory called user.dat and system.dat which contain the data in your registry. However, in all cases Microsoft provides a utility regedit to browse and change the registry.

When you use this tool to open your registry, you will see 5 base keys:

HKEY_CLASSES_ROOT

HKEY_CURRENT_USER

HKEY_LOCAL_MACHINE

HKEY_USERS

HKEY_CURRENT_CONFIGURATION


These five keys are identical in all window versions. Each one has many subkeys, which in turn have subkeys again. The registry has a strict hierarchical structure. For our purpose only 2 of them are interesting: HKEY_CURRENT_USER and HKEY_LOCAL_MACHINE. The first is, as the name suggests, user dependant, the second is applicable to all the machine. You might think this key contains just hardware related data, but it has a subkey for software as well. The local machine root is a good choice for items applicable to all users.

Reading data

The reading of data from the registry is illustrated with an example. We will cerate a new form which will remember its previous location on the screen. The location is determined by the Top and Left properties of the form. In addition to these, we will read and store the Height and Width properties of the form.  

const

  cKey = 'SOFTWARE\Test_Company\Test_Application';
  // key where item values will be stored and read

procedure TRememberForm.FormCreate(Sender:
  TObject);
var
  lReg: TRegistry;
  getInt: integer;
begin
  inherited;
  // general purpose:
  // read latest Left, Top, Width and Height
  lReg := TRegistry.Create;
  // create registry object
  lReg.RootKey := HKEY_CURRENT_USER;
  // set root to current user root,
  // to ensure different users on this
  // machine have their own setting
  lReg.OpenKey(cKey, True);
  // Open key where we will read items
  if lReg.ValueExists(self.name +
    '.Left') then // check if
    value for item formname.left exists
    begin
      getint := lReg.ReadInteger(self.name
        + '.Left'); // Read left position of actual form
      if getint > 0 then
        self.Left := getint;
    end;
  if lReg.ValueExists(self.name +
    '.Top') then
  begin
    getint := lReg.ReadInteger(self.name + '.Top');
    if getint > 0 then
      self.Top := getint;
  end;
  if lReg.ValueExists(self.name + '.Width') then
  begin
    getint := lReg.ReadInteger(self.name + '.Width');
    if getint > 0 then
      self.Width := getint;
  end;
  if lReg.ValueExists(self.name + '.Height') then
  begin
    getint := lReg.ReadInteger(self.name + '.Height');
    if getint > 0 then
      self.Height := getint;
  end;
  // Close and free
  lReg.CloseKey;
  lReg.Free;
end;
  
Let's have a short look at the main points:

lReg := TRegistry.Create;
// create registry object

This line creates the Registry object.

lReg.RootKey := HKEY_CURRENT_USER;
// set root to current user root,
// to ensure different users on this
// machine have their own setting

We set the root to indicate in which of the 5 roots we want to work. HKEY_CURRENT_USER is the default value. Alternately, we might have chosen HKEY_LOCAL_MACHINE if we wanted to save settings for all users on this machine.

lReg.OpenKey(cKey, True);
// Open key where we will read items

The key where items will be stored and read is opened. If the key does not exist, windows automatically creates it. Note that capitalization is important when the registry key is created. Most entries in the registry have first letter uppercase and the rest lowercase, and it is good practice to comply.

if lReg.ValueExists(self.name + '.Left') then
  // check if value for item formname. left exists

This statement tests if the item FormName.left exists within the open key.

begin
  getint := lReg.ReadInteger(self.name
    + '.Left'); // Read left position of actual form

As an alternative for ReadInteger, the TRegistry object also provides functions to read strings, booleans, dates, datetimes, times, floats, and binary data.

if getint > 0 then
  self.Left := getint;
end;

By putting all these code in the FormCreate, the window is automatically positioned at the right spot at creation. Of course the code above can not be really tested when we don't have any data, so the next step is to write these items in the FormDestroy.

Writing data

The FormDestroy event is a good moment to write the data to the registry. The code is a lot shorter:  

procedure TRememberForm.FormDestroy(Sender: TObject);
var
  lReg: TRegistry;
begin
  // open registry, set root and key
  lReg := TRegistry.Create;
  lReg.RootKey := HKEY_CURRENT_USER;
  lReg.OpenKey(cKey, True);
  // write last Left, Top, Width and Height
  lReg.WriteInteger(self.name + '.Left', self.Left);
  lReg.WriteInteger(self.name + '.Top', self.Top);
  lReg.WriteInteger(self.name + '.Width', self.Width);
  lReg.WriteInteger(self.name + '.Height', self.Height);
  // close all
  lReg.CloseKey;
  lReg.Free;
  inherited;
end;

As with reading data, the same applies with writing data. You can easily write booleans, currencies, dates, datetimes, floats, strings and times, and binary data. In addition, there is a WriteExpandString, which is meant for unexpanded strings with "%" in it, such as "Open file %s failed".

WriteInteger creates a name when the name does not yet exist. If a write operation fails, an exception is raised.

Alternatives

There are 2 other objects, TRegIniFile and TRegistryInifile available.

TRegistryIniFile presents a simple interface to the system registry and hides the need to know about the underlying structure of the registry. TRegistryIniFile enables handling the Windows system registry as if it were a Windows 3.x INI file. Instead of processing an INI file, however, TRegistryIniFile reads from and writes to the system registry.

TRegIniFile presents a simple interface to the system registry, hiding the need to know about the underlying structure of the registry. TRegIniFile acts as a helper object to TRegistryIniFile.

Personally I avoid using these 2 classes. The programmer saves some time by not having to understand the registry. But the structure of the registry is rather straightforward hierarchical, and using the registry as if it was an ini-file limits its usage.

Limitations and final words

There are a few limitations which we haven't discussed. First, The registry is not meant a a database for storing vast quantities of data. It is meant for storing initialization and configuration data. Anything over 2Kb had better be stored in a separate file. If you wish, you can mention the corresponding file location in the registry. Then WriteBinary is especially useful for storing recordtypes. Using a record type saves you typing code, and it can be written to and read from the registry with 1 statement, saving both time and storage. And a large registry might slow down all applications.

There is a small bug in the MoveKey procedure under WNT. It should move a key including Subkeys, but it does not, at least not in D2-4. In the help of Delphi 5 this problem has been documented. The problem does not seem to appear under W2K.

Third, it seems Windows NT & Windows 2000 administrators can limit Registry access. Using the registry may conflict with IT-policies in some companies.

Should you like the form we created, right click on the form and choose 'add to repository'. You can then create descendants by choosing File / New / forms.


Component Download: http://www.xs4all.nl/~spaanszt/Delphi/DemoRegistry.zip

How to add a calculated field to a dynamically created TTable

Problem/Question/Abstract:

How to add a calculated field to a dynamically created TTable

Answer:

var
  f: TField;
  i: Integer;
begin
  table1.FieldDefs.Update
    Table1.Close;
  for i := 0 to Table1.FieldDefs.Count - 1 do
    {create persistent field that does not exist}
    if table1.FindField(table1.FieldDefs[i].Name) = nil then
      table1.FieldDefs.Items[i].CreateField(Table1);
  {create a calculated field}
  f := TStringField.Create(Table1);
  f.Name := 'Table1CalcField';
  f.FieldName := 'CalcField';
  f.DisplayLabel := 'CalcField';
  f.Calculated := True;
  f.DataSet := Table1;
  Table1.Open;
end;

Use webcam in Delphi

Problem/Question/Abstract:

Do you need to takes pictures from your Delphi application ?

Answer:

First of all, get the SDK at http://developer.logitech.com

After installation, open delphi and Import ActiveX Control VPortal2 from the list.

Now, create a new form, and put a VideoPortal from the ActiveX panel and a button.

In the uses, add VideoPortal

On the OnShow add:

VideoPortal1.PrepareControl('QCSDK',
  'HKEY_LOCAL_MACHINE\Software\JCS Programmation\QCSDK', 0);
VideoPortal1.EnableUIElements(UIELEMENT_STATUSBAR, 0, 0);
VideoPortal1.ConnectCamera2;
VideoPortal1.EnablePreview := 1;

On the ButtonClick add:

var
  BMP: TBitmap;
  JPG: TJpegImage;
  L: string;
begin
  F := 'Photos\test.jpg';
  VideoPortal1.StampBackgroundColor := clYellow;
  VideoPortal1.StampTextColor := clBlack;
  VideoPortal1.StampFontName := 'Arial';
  VideoPortal1.StampPointSize := 10;
  VideoPortal1.StampTransparentBackGround := 0;
  L := Format(' %s - %s ', [DateTimeToStr(Now), Num]);
  VideoPortal1.PictureToFile(0, 24, 'Temp.bmp', L);
  BMP := TBitmap.Create;
  JPG := TJpegImage.Create;
  BMP.LoadFromFile('Temp.bmp');
  JPG.CompressionQuality := 85;
  JPG.Assign(BMP);
  JPG.SaveToFile(F);
  BMP.Free;
  JPG.Free;
end;

It's all, run the application, you will see the image from the camera, click on the button to get a picture.

Here is a copy a VideoPortal.Pas (constants).

unit VideoPortal;

interface
// Copyright (c) 1996-2000 Logitech, Inc.  All Rights Reserved
// User Interface Element, codes used with EnableUIElement method
const
  UIELEMENT_640x480 = 0;
const
  UIELEMENT_320x240 = 1;
const
  UIELEMENT_PCSMART = 2;
const
  UIELEMENT_STATUSBAR = 3;
const
  UIELEMENT_UI = 4;
const
  UIELEMENT_CAMERA = 5;
const
  UIELEMENT_160x120 = 6;

  // Camera status codes, returned by CameraState property
const
  CAMERA_OK = 0;
const
  CAMERA_UNPLUGGED = 1;
const
  CAMERA_INUSE = 2;
const
  CAMERA_ERROR = 3;
const
  CAMERA_SUSPENDED = 4;
const
  CAMERA_DUAL_DETACHED = 5;
const
  CAMERA_UNKNOWNSTATUS = 10;

  // Movie Recording Modes, used with MovieRecordMode property
const
  SEQUENCECAPTURE_FPS_USERSPECIFIED = 1;
const
  SEQUENCECAPTURE_FPS_FASTASPOSSIBLE = 2;
const
  STEPCAPTURE_MANUALTRIGGERED = 3;

  // Movie Creation Flags, used with MovieCreateFlags property
const
  MOVIECREATEFLAGS_CREATENEW = 1;
const
  MOVIECREATEFLAGS_APPEND = 2;

  // Notification Codes
const
  NOTIFICATIONMSG_MOTION = 1;
const
  NOTIFICATIONMSG_MOVIERECORDERROR = 2;
const
  NOTIFICATIONMSG_CAMERADETACHED = 3;
const
  NOTIFICATIONMSG_CAMERAREATTACHED = 4;
const
  NOTIFICATIONMSG_IMAGESIZECHANGE = 5;
const
  NOTIFICATIONMSG_CAMERAPRECHANGE = 6;
const
  NOTIFICATIONMSG_CAMERACHANGEFAILED = 7;
const
  NOTIFICATIONMSG_POSTCAMERACHANGED = 8;
const
  NOTIFICATIONMSG_CAMERBUTTONCLICKED = 9;
const
  NOTIFICATIONMSG_VIDEOHOOK = 10;
const
  NOTIFICATIONMSG_SETTINGDLGCLOSED = 11;
const
  NOTIFICATIONMSG_QUERYPRECAMERAMODIFICATION = 12;
const
  NOTIFICATIONMSG_MOVIESIZE = 13;

  // Error codes used by NOTIFICATIONMSG_MOVIERECORDERROR notification:
const
  WRITEFAILURE_RECORDINGSTOPPED = 0;
const
  WRITEFAILURE_RECORDINGSTOPPED_FILECORRUPTANDDELETED = 1;
const
  WRITEFAILURE_CAMERA_UNPLUGGED = 2;
const
  WRITEFAILURE_CAMERA_SUSPENDED = 3;

  // Camera type codes, returned by GetCameraType method
const
  CAMERA_UNKNOWN = 0;
const
  CAMERA_QUICKCAM_VC = 1;
const
  CAMERA_QUICKCAM_QUICKCLIP = 2;
const
  CAMERA_QUICKCAM_PRO = 3;
const
  CAMERA_QUICKCAM_HOME = 4;
const
  CAMERA_QUICKCAM_PRO_B = 5;
const
  CAMERA_QUICKCAM_TEKCOM = 6;
const
  CAMERA_QUICKCAM_EXPRESS = 7;
const
  CAMERA_QUICKCAM_FROG = 8; // MIGHT CHANGE NAME BUT ENUM STAYS THE SAME
const
  CAMERA_QUICKCAM_EMERALD = 9; // MIGHT CHANGE NAME BUT ENUM STAYS THE SAME

  // Camera-specific property codes used by Set/GetCameraPropertyLong
const
  PROPERTY_ORIENTATION = 0;
const
  PROPERTY_BRIGHTNESSMODE = 1;
const
  PROPERTY_BRIGHTNESS = 2;
const
  PROPERTY_CONTRAST = 3;
const
  PROPERTY_COLORMODE = 4;
const
  PROPERTY_REDGAIN = 5;
const
  PROPERTY_BLUEGAIN = 6;
const
  PROPERTY_SATURATION = 7;
const
  PROPERTY_EXPOSURE = 8;
const
  PROPERTY_RESET = 9;
const
  PROPERTY_COMPRESSION = 10;
const
  PROPERTY_ANTIBLOOM = 11;
const
  PROPERTY_LOWLIGHTFILTER = 12;
const
  PROPERTY_IMAGEFIELD = 13;
const
  PROPERTY_HUE = 14;
const
  PROPERTY_PORT_TYPE = 15;
const
  PROPERTY_PICTSMART_MODE = 16;
const
  PROPERTY_PICTSMART_LIGHT = 17;
const
  PROPERTY_PICTSMART_LENS = 18;
const
  PROPERTY_MOTION_DETECTION_MODE = 19;
const
  PROPERTY_MOTION_SENSITIVITY = 20;
const
  PROPERTY_WHITELEVEL = 21;
const
  PROPERTY_AUTO_WHITELEVEL = 22;
const
  PROPERTY_ANALOGGAIN = 23;
const
  PROPERTY_AUTO_ANALOGGAIN = 24;
const
  PROPERTY_LOWLIGHTBOOST = 25;
const
  PROPERTY_COLORBOOST = 26;
const
  PROPERTY_ANTIFLICKER = 27;
const
  PROPERTY_OPTIMIZATION_SPEED_QUALITY = 28;
const
  PROPERTY_STREAM_HOOK = 29;
const
  PROPERTY_LED = 30;

const
  ADJUSTMENT_MANUAL = 0;
const
  ADJUSTMENT_AUTOMATIC = 1;

const
  ORIENTATIONMODE_NORMAL = 0;
const
  ORIENTATIONMODE_MIRRORED = 1;
const
  ORIENTATIONMODE_FLIPPED = 2;
const
  ORIENTATIONMODE_FLIPPED_AND_MIRRORED = 3;

const
  COMPRESSION_Q0 = 0;
const
  COMPRESSION_Q1 = 1;
const
  COMPRESSION_Q2 = 2;

const
  ANTIFLICKER_OFF = 0;
const
  ANTIFLICKER_50Hz = 1;
const
  ANTIFLICKER_60Hz = 2;

const
  OPTIMIZE_QUALITY = 0;
const
  OPTIMIZE_SPEED = 1;

const
  LED_OFF = 0;
const
  LED_ON = 1;
const
  LED_AUTO = 2;
const
  LED_MAX = 3;

const
  PICTSMART_LIGHTCORRECTION_NONE = 0;
const
  PICTSMART_LIGHTCORRECTION_COOLFLORESCENT = 1;
const
  PICTSMART_LIGHTCORRECTION_WARMFLORESCENT = 2;
const
  PICTSMART_LIGHTCORRECTION_OUTSIDE = 3;
const
  PICTSMART_LIGHTCORRECTION_TUNGSTEN = 4;

const
  PICTSMART_LENSCORRECTION_NORMAL = 0;
const
  PICTSMART_LENSCORRECTION_WIDEANGLE = 1;
const
  PICTSMART_LENSCORRECTION_TELEPHOTO = 2;

const
  CAMERADLG_GENERAL = 0;
const
  CAMERADLG_ADVANCED = 1;

implementation
end.

Example shows how to use the PictureToMemory method in the QuickCam SDK.

type
  TMemoryStream = class(Classes.TMemoryStream);

var
  MS: TMemoryStream;
  lSize: LongInt;
  pBuffer: ^Byte;

begin

  MS := TMemoryStream.Create;
  bitmap1 := TBitmap.Create;

  try
    if VideoPortal1.PictureToMemory(0, 24, 0, lSize, '') = 1 then
    begin
      pBuffer := AllocMem(lSize);
      if VideoPortal1.PictureToMemory(0, 24, integer(pBuffer), lSize, '') = 1 then
      begin
        MS.SetPointer(pBuffer, lSize);
        bitmap1.loadfromstream(MS);
      end;
    end;
  finally
    MS.Free;
    FreeMem(pBuffer);
  end;
end;

How to create a resizable TPanel with a size grip

Problem/Question/Abstract:

How can I create a TPanel that can be resized by grip in the lower right corner (just like the grip, the TStatusBar has)?

Answer:

Solve 1:

Try this one. It may need some refinement in painting the grip.

unit SizeablePanel;

interface

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

type
  TSizeablePanel = class(TPanel)
  private
    FDragging: Boolean;
    FLastPos: TPoint;
  protected
    procedure Paint; override;
    procedure MouseDown(Button: TMouseButton; Shift: TShiftState; X, Y: Integer); override;
    procedure MouseMove(Shift: TShiftState; X, Y: Integer); override;
    procedure MouseUp(Button: TMouseButton; Shift: TShiftState; X, Y: Integer); override;
  public
    { Public declarations }
  published
    { Published declarations }
  end;

procedure Register;

implementation

procedure Register;
begin
  RegisterComponents('PBGoodies', [TSizeablePanel]);
end;

procedure TSizeablePanel.MouseDown(Button: TMouseButton; Shift: TShiftState; X, Y: Integer);
begin
  if (Button = mbLeft) and ((Width - x) < 10) and ((Height - y) < 10) then
  begin
    FDragging := TRue;
    FLastPos := Point(x, y);
    MouseCapture := true;
    Screen.cursor := crSizeNWSE;
  end
  else
    inherited;
end;

procedure TSizeablePanel.MouseMove(Shift: TShiftState; X, Y: Integer);
var
  r: TRect;
begin
  if FDragging then
  begin
    r := BoundsRect;
    SetBounds(r.left, r.top, r.right - r.left + X - FlastPos.X,
      r.bottom - r.top + Y - Flastpos.Y);
    FLastPos := Point(x, y);
  end
  else
  begin
    inherited;
    if ((Width - x) < 10) and ((Height - y) < 10) then
      Cursor := crSizeNWSE
    else
      Cursor := crDefault;
  end;
end;

procedure TSizeablePanel.MouseUp(Button: TMouseButton; Shift: TShiftState; X, Y: Integer);
begin
  if FDragging then
  begin
    FDragging := False;
    MouseCapture := false;
    Screen.Cursor := crDefault;
  end
  else
    inherited;
end;

procedure TSizeablePanel.Paint;
var
  x, y: Integer;
begin
  inherited;
  Canvas.Font.Name := 'Marlett';
  Canvas.Font.Size := 10;
  Canvas.Brush.Style := bsClear;
  x := clientwidth - canvas.textwidth('o');
  y := clientheight - canvas.textheight('o');
  canvas.textout(x, y, 'o');
end;

end.


Solve 2:

Here's a component that will do that and also looks like it has a statusbar at the bottom:

unit SizeGripPanel;

interface

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

type
  TSizeGripPanel = class(TPanel)
  private
    {Private declarations}
    FAllowMove, FAllowSize, FShowSizeGrip: Boolean;
    procedure SetAllowMove(Value: Boolean);
    procedure SetAllowSize(Value: Boolean);
    procedure SetShowSizeGrip(Value: Boolean);
  protected
    {Protected declarations}
    procedure WMNCHitTest(var Msg: TWMNCHitTest); message WM_NCHITTEST;
    procedure Paint; override;
  public
    {Public declarations}
  published
    {Published declarations}
    property ShowSizeGrip: Boolean read FShowSizeGrip write SetShowSizeGrip;
    property AllowMove: Boolean read FAllowMove write SetAllowMove;
    property AllowSize: Boolean read FAllowSize write SetAllowSize;
  end;

procedure Register;

implementation

procedure Register;
begin
  RegisterComponents('Samples', [TSizeGripPanel]);
end;

procedure TSizeGripPanel.WMNCHitTest(var Msg: TWMNCHitTest);
var
  ScreenPt: TPoint;
  MoveArea: TRect;
  HANDLE_WIDTH: Integer;
  SIZEGRIP: Integer;
begin
  {This code came from Lou's Tip of the Day web site... with changes}
  HANDLE_WIDTH := BevelWidth;
  Sizegrip := 19;
  inherited;
  if not (csDesigning in ComponentState) then
  begin
    ScreenPt := ScreenToClient(Point(Msg.Xpos, Msg.Ypos));
    MoveArea := Rect(HANDLE_WIDTH, HANDLE_WIDTH, Width - HANDLE_WIDTH,
      Height - HANDLE_WIDTH);
    if FAllowSize then
    begin
      {left side}
      if (ScreenPt.x < HANDLE_WIDTH) then
        Msg.Result := HTLEFT
          {top side}
      else if (ScreenPt.y < HANDLE_WIDTH) then
        Msg.Result := HTTOP
          {right side}
      else if (ScreenPt.x >= Width - HANDLE_WIDTH) then
        Msg.Result := HTRIGHT
          {bottom side}
      else if (ScreenPt.y >= Height - HANDLE_WIDTH) then
        Msg.Result := HTBOTTOM
          {top left corner}
      else if (ScreenPt.x < Sizegrip) and (ScreenPt.y < Sizegrip) then
        Msg.Result := HTTOPLEFT
          {bottom left corner}
      else if (ScreenPt.x < Sizegrip) and (ScreenPt.y >= Height - Sizegrip) then
        Msg.Result := HTBOTTOMLEFT
          {top right corner}
      else if (ScreenPt.x >= Width - Sizegrip) and (ScreenPt.y < Sizegrip) then
        Msg.Result := HTTOPRIGHT
          {bottom right corner}
      else if (ScreenPt.x >= Width - Sizegrip) and (ScreenPt.y >= Height - Sizegrip) then
        Msg.Result := HTBOTTOMRIGHT;
    end
      {no sides or corners, this will do the dragging}
    else if PtInRect(MoveArea, ScreenPt) and FAllowMove then
      Msg.Result := HTCAPTION;
  end;
end;

procedure TSizeGripPanel.Paint;
const
  Alignments: array[TAlignment] of Longint = (DT_LEFT, DT_RIGHT, DT_CENTER);
var
  Rect: TRect;
  TopColor, BottomColor: TColor;
  FontHeight: Integer;
  LineBeg, LineEnd: TPoint;
  Flags: Longint;
  R: TRect;

  procedure AdjustColors(Bevel: TPanelBevel);
  begin
    TopColor := clBtnHighlight;
    if Bevel = bvLowered then
      TopColor := clBtnShadow;
    BottomColor := clBtnShadow;
    if Bevel = bvLowered then
      BottomColor := clBtnHighlight;
  end;

  procedure DrawCorner(pane: TRect);
  begin
    {Got this code from a Codeguru post. It was a CStatusBar descendant
                 and written in C}
    OffsetRect(pane, -1, -1);
    with Canvas do
    begin
      Canvas.Pen.Color := clBtnHighlight;
      MoveTo(pane.right - 15, pane.bottom);
      LineTo(pane.right, pane.bottom - 15);
      MoveTo(pane.right - 11, pane.bottom);
      LineTo(pane.right, pane.bottom - 11);
      MoveTo(pane.right - 7, pane.bottom);
      LineTo(pane.right, pane.bottom - 7);
      MoveTo(pane.right - 3, pane.bottom);
      LineTo(pane.right, pane.bottom - 3);
      Canvas.Pen.Color := clBtnShadow;
      MoveTo(pane.right - 14, pane.bottom);
      LineTo(pane.right, pane.bottom - 14);
      MoveTo(pane.right - 10, pane.bottom);
      LineTo(pane.right, pane.bottom - 10);
      MoveTo(pane.right - 6, pane.bottom);
      LineTo(pane.right, pane.bottom - 6);
      MoveTo(pane.right - 2, pane.bottom);
      LineTo(pane.right, pane.bottom - 2);
      MoveTo(pane.right - 13, pane.bottom);
      LineTo(pane.right, pane.bottom - 13);
      MoveTo(pane.right - 9, pane.bottom);
      LineTo(pane.right, pane.bottom - 9);
      MoveTo(pane.right - 5, pane.bottom);
      LineTo(pane.right, pane.bottom - 5);
      MoveTo(pane.right - 1, pane.bottom);
      LineTo(pane.right, pane.bottom);
    end;
  end;

begin
  Rect := GetClientRect;
  if BevelOuter <> bvNone then
  begin
    AdjustColors(BevelOuter);
    Frame3D(Canvas, Rect, TopColor, BottomColor, BevelWidth);
  end;
  Frame3D(Canvas, Rect, Color, Color, BorderWidth);
  if BevelInner <> bvNone then
  begin
    AdjustColors(BevelInner);
    Frame3D(Canvas, Rect, TopColor, BottomColor, BevelWidth);
  end;
  with Canvas do
  begin
    Brush.Color := Color;
    FillRect(Rect);
    Brush.Style := bsClear;
    Font := Self.Font;
    FontHeight := TextHeight('W');
    with Rect do
    begin
      Top := ((Bottom + Top) - FontHeight) div 2;
      Bottom := Top + FontHeight;
    end;
    Flags := DT_EXPANDTABS or DT_VCENTER or Alignments[Alignment];
    Flags := DrawTextBiDiModeFlags(Flags);
    DrawText(Handle, PChar(Caption), -1, Rect, Flags);
    Rect := GetClientRect;
    if FShowSizeGrip then
    begin
      R := Rect;
      R.Top := Height - 19;
      R.Left := Rect.Left + BevelWidth;
      R.Bottom := Rect.Bottom - BevelWidth;
      R.Right := Rect.Right - BevelWidth;
      AdjustColors(BevelOuter);
      {Always have sunken statusbar! If you want a bar that is raised when
                         your panel is sunken, use this line, instead:
      Frame3D(Canvas, R, BottomColor, TopColor, 1);}
      Frame3D(Canvas, R, clBtnShadow, clBtnHighlight, 1);
      DrawCorner(R);
    end;
  end;
end;

procedure TSizeGripPanel.SetAllowMove(Value: Boolean);
begin
  if Value <> FAllowMove then
  begin
    FAllowMove := Value;
    Invalidate;
  end;
end;

procedure TSizeGripPanel.SetAllowSize(Value: Boolean);
begin
  if Value <> FAllowSize then
  begin
    FAllowSize := Value;
    FShowSizeGrip := Value;
    Invalidate;
  end;
end;

procedure TSizeGripPanel.SetShowSizeGrip(Value: Boolean);
begin
  if Value <> FShowSizeGrip then
  begin
    FShowSizeGrip := Value;
    Invalidate;
  end;
end;

end.

Display multiple lines in a single cell of a TStringGrid

Problem/Question/Abstract:

How to display multiple lines in a single cell of a TStringGrid

Answer:

Solve 1:

It is fairly easy to draw such text in an OnDrawCell handler. However the standard inplace editor of a grid is not well prepared to handle cells higher than one line.

procedure TForm1.StringGrid1DrawCell(Sender: TObject; Col, Row: Integer;
  Rect: TRect; State: TGridDrawState);
var
  S: string;
  drawrect: TRect;
begin
  S := (Sender as TStringGrid).Cells[Col, Row];
  if Length(S) > 0 then
  begin
    drawrect := rect;
    DrawText((Sender as TStringGrid).canvas.handle, Pchar(S), Length(S), drawrect,
      DT_CALCRECT or DT_WORDBREAK or DT_LEFT);
    if (drawrect.bottom - drawrect.top) > (Sender as TStringGrid).RowHeights[row] then
      (Sender as TStringGrid).RowHeights[row] := (drawrect.bottom - drawrect.top)
    else
    begin
      drawrect.Right := rect.right;
      (Sender as TStringGrid).canvas.fillrect(drawrect);
      DrawText((Sender as TStringGrid).canvas.handle, Pchar(S), Length(S),
        drawrect, DT_WORDBREAK or DT_LEFT);
    end;
  end;
end;

It will automatically adjust the row height to larger values if needed. The main problem is that it will not automatically decrease the row height if the text would fit into a smaller row. It cannot do that since there may be other cells in the row that need a taller row. You could fix that problem by setting the rowheigh back to the defaultrowheight when you change the cell data for a row, that would trigger a redraw and that in turn would adjust the rowheight to what is needed. It would cause some flicker, though.


Solve 2:

This is a unit that enables word-wrap in a cell of a TStringGrid:

unit Unit1;

interface

uses
  SysUtils, WinTypes, WinProcs, Messages, Classes, Graphics, Controls,
  Forms, Dialogs, ExtCtrls, Grids;

type
  TForm1 = class(TForm)
    StringGrid1: TStringGrid;
    Panel1: TPanel;
    procedure StringGrid1DrawCell(Sender: TObject; Col, Row: Longint;
      Rect: TRect; State: TGridDrawState);
  private
    { Private declarations }
  public
    { Public declarations }
  end;

var
  Form1: TForm1;

implementation

{$R *.DFM}

procedure TForm1.StringGrid1DrawCell(Sender: TObject; Col, Row: Longint;
  Rect: TRect; State: TGridDrawState);
var
  A: array[0..255] of char;
  drawrect: TRect;
begin
  StrPCopy(A, (Sender as TStringgrid).Cells[Col, Row]);
  if StrLen(A) > 0 then
    with (Sender as TStringgrid) do
    begin
      drawrect := rect;
      {Note that the first DrawText uses the DT_CALCRECT flag to calculate a new
                        value for drawrect. This value is used to set the RowHeights
                        parameter if necessary.}
      DrawText(canvas.handle, A, -1, drawrect, DT_CALCRECT or DT_WORDBREAK or
        DT_LEFT);
      if (drawrect.bottom - drawrect.top) > RowHeights[Row] then
        RowHeights[row] := (drawrect.bottom - drawrect.top)
      else
      begin
        drawrect.right := rect.right;
        canvas.fillrect(drawrect);
        DrawText(canvas.handle, A, -1, drawrect, DT_WORDBREAK or DT_LEFT);
      end;
    end;
end;

end.