Delphi

QUICK Duplicate Current Record Procedure

For the purposes of this example please assume there is no primary key or constraints on the table. In reallity you would probably want to duplicate a record then change one of the field values, before it is appended.

The problem is that to use dataset.append, dataset.setthefieldvalues, dataset.post, as soon as the append is called, you loose the current record which pointed to the record you want to duplicate. So you could use two datasets and copy one to the other, but this uses extra memory, etc. or you could copy the contents of the current record into a temporary place then call the append.

Taking this second option :
The first solution I came up with was to use VarArrayCreate, but this was slow. Another altenative was to go lower level and use the ActiveBuffer method, but then your getting into memory copies etc. and I didn`t know enough about the internal memory representation of a record.

So this is what I came up with, and has the added benefit of being faster than using the dataset.append dataset.setthefieldvalues dataset.post method. It simply copies the current record in to an array of variant (note NOT a variant array which needs redimsand the such) then uses the dataset.appendrecord method to add the record in one go.

procedure DuplicateCurrentRecord(aDataSet : TDataSet); 
var
  Data : array of variant; 
  aRecord : array of TVarRec; 
  i : integer; 
  max : integer; 
begin
  max := aDataSet.fields.count -1; 
// set the lenghth of the arecord array to be the same as the number of 
// elements in the data array 
  SetLength(arecord,max+1); 
  SetLength(data,max+1); 
// set the variant type pointers to the data array 
for i := 0 to max do
begin
    arecord[i].VType := vtVariant; 
    arecord[i].VVariant := @data[i]; 
end
// Copy the Record to the Array 
for i := 0 to max do
    Data[i] := aDataSet.fields[i].value; 
// finally append the record in one go
  aDataSet.AppendRecord(aRecord); 
end;

Delphi

How to Ensure TEdits are defocused and changes saved on form closure

Some controls that create edit boxes or combos to allow editing of the information they display, for example the TVirtualStringTree, component do not loose the focus when a form is closed, and as such the changes to the edit are not applied. This can be fixed easily with a one-liner.

To ensure that popup edits, independant of the type of control have finished editing, i.e. have lost their focus when a form is closed, simply put the following line in the closequery event.

if assigned(ActiveControl) and (ActiveControl).Focused then DefocusControl(ActiveControl,false);

This line will ensure that the current control that has focus is defocused. It basically checks to see if a control is focused and if it is, Defocuses it.  This should work with all controls, e.g. dropdowns, edits and ensures that edit changes are committed.

Delphi

Painting the background of TEdit

TEdit is a fairly low level component utilizing the standard windows edit window. How on earth do we get the background to be something other than a color.. Can we make it transparent or put a picture in. I don’t know if the following works in versions previous to Delphi 6 but I can’t see why it would not.

This unit is a transparent TEdit descendant.

If you want to put your own background in instead of it being transparent change the else clause of the if Transparent in WMEraseBkGnd.

unit Z9Edit;
interface
uses
  Windows, Messages, SysUtils, Classes, Controls, StdCtrls, Graphics;
type
  TZ9Edit = class(TEdit)
private
{ Private declarations }
    FAlignText: TAlignment;
    FTransparent: Boolean;
    FPainting: Boolean;
procedure SetAlignText(Value: TAlignment);
procedure SetTransparent(Value: Boolean);
protected
{ Protected declarations }
procedure RepaintWindow;
procedure CreateParams(var Params: TCreateParams); override;
procedure Change; override;
procedure SetParent(AParent: TWinControl); override;
procedure WMPaint(var Message: TWMPaint); message WM_PAINT;
procedure WMNCPaint (var Message: TMessage); message WM_NCPAINT;
procedure WMEraseBkGnd(var Message: TWMEraseBkGnd); message WM_ERASEBKGND;
procedure CNCtlColorEdit(var Message: TWMCtlColorEdit); message CN_CTLCOLOREDIT;
procedure CNCtlColorStatic(var Message: TWMCtlColorStatic); message CN_CTLCOLORSTATIC;
procedure CMParentColorChanged(var Message: TMessage); message CM_PARENTCOLORCHANGED;
procedure WMSize(var Message: TWMSize); message WM_SIZE;
procedure WMMove(var Message: TWMMove); message WM_MOVE;
procedure PaintParent(ACanvas: TCanvas);
public
{ Public declarations }
constructor Create(AOwner: TComponent); override;
destructor Destroy; override;
published
{ Published declarations }
property Align;
property AlignText: TAlignment read FAlignText write SetAlignText default taLeftJustify;
property Transparent: Boolean read FTransparent write SetTransparent default false;
end;
implementation
{ TZ9Edit }
uses
  Forms;
type
  TParentControl = class(TWinControl);
const
  BorderRec: array[TBorderStyle] of Integer = (1, -1);
constructor TZ9Edit.Create(AOwner: TComponent);
begin
inherited Create(AOwner);
  FAlignText := taLeftJustify;
  FTransparent := false;
  FPainting := false;
end;
destructor TZ9Edit.Destroy;
begin
inherited Destroy;
end;
procedure TZ9Edit.SetAlignText(Value: TAlignment);
begin
if FAlignText <> Value then
begin
    FAlignText := Value;
    RecreateWnd;
     Invalidate;
end;
end;
procedure TZ9Edit.SetTransparent(Value: Boolean);
begin
if FTransparent <> Value then
begin
    FTransparent := Value;
    Invalidate;
end;
end;
procedure TZ9Edit.WMEraseBkGnd(var Message: TWMEraseBkGnd);
var
  DC: hDC;
  i: integer;
  p: TPoint;
  canvas : TCanvas;
begin
if FTransparent and not(csDesigning in componentstate) then
begin
    canvas := TCanvas.create;
try
      canvas.handle := message.dc;
      PaintParent(Canvas);
finally
      canvas.free;
end;
end
else
begin
    canvas := TCanvas.create;
try
      canvas.handle := message.dc;
      canvas.brush.color := Color;
      canvas.brush.style := bsSolid;
      canvas.fillrect(clientrect);
finally
      canvas.free;
end;
end;
end;
procedure TZ9Edit.WMPaint(var Message: TWMPaint);
begin
inherited;
if FTransparent then
if not FPainting then RepaintWindow;
end;
procedure TZ9Edit.WMNCPaint(var Message: TMessage);
begin
inherited;
end;
procedure TZ9Edit.CNCtlColorEdit(var Message: TWMCtlColorEdit);
begin
inherited;
if FTransparent then SetBkMode(Message.ChildDC, 1);
end;
procedure TZ9Edit.CNCtlColorStatic(var Message: TWMCtlColorStatic);
begin
inherited;
if FTransparent then SetBkMode(Message.ChildDC, 1);
end;
procedure TZ9Edit.CMParentColorChanged(var Message: TMessage);
begin
inherited;
if FTransparent then Invalidate;
end;
procedure TZ9Edit.WMSize(var Message: TWMSize);
var
  r : TRect;
begin
inherited;
  r := ClientRect;
  InvalidateRect(handle,@r,false);
end;
procedure TZ9Edit.WMMove(var Message: TWMMove);
var
  r : TRect;
begin
inherited;
  Invalidate;
  r := ClientRect;
  InvalidateRect(handle,@r,false);
end;
procedure TZ9Edit.RepaintWindow;
var
  DC: hDC;
  TmpBitmap, Bitmap: hBitmap;
begin
if FTransparent then
begin
    FPa
inting := true;
    HideCaret(Handle);
    DC := CreateCompatibleDC(GetDC(Handle));
    TmpBitmap := CreateCompatibleBitmap(GetDC(Handle), Succ(ClientWidth), Succ(ClientHeight));
    Bitmap := SelectObject(DC, TmpBitmap);
    PaintTo(DC, 0, 0);
    BitBlt(GetDC(Handle), BorderRec[BorderStyle] + BorderWidth, BorderRec[BorderStyle] + BorderWidth, ClientWidth, ClientHeight, DC, 1, 1, SRCCOPY);
    SelectObject(DC, Bitmap);
    DeleteDC(DC);
    ReleaseDC(Handle, GetDC(Handle));
    DeleteObject(TmpBitmap);
    ShowCaret(Handle);
    FPainting := false;
end;
end;
procedure TZ9Edit.CreateParams(var Params: TCreateParams);
const
  Alignments: array [TAlignment] of DWord = (ES_LEFT, ES_RIGHT, ES_CENTER);
begin
inherited CreateParams(Params);
  Params.Style := Params.Style or ES_MULTILINE or Alignments[FAlignText];
end;
procedure TZ9Edit.Change;
begin
  RepaintWindow;
inherited Change;
end;
procedure TZ9Edit.SetParent(AParent: TWinControl);
begin
inherited SetParent(AParent);
end;
procedure TZ9Edit.PaintParent(ACanvas: TCanvas);
var
  I, Count, X, Y, SaveIndex: integer;
  DC: cardinal;
  R, SelfR, CtlR: TRect;
  Control : TControl;
begin
  Control := Self;
if Control.Parent = nil then Exit;
  Count := Control.Parent.ControlCount;
  DC := ACanvas.Handle;
  SelfR := Bounds(Control.Left, Control.Top, Control.Width, Control.Height);
  X := -Control.Left; Y := -Control.Top;
// Copy parent control image
  SaveIndex := SaveDC(DC);
  SetViewportOrgEx(DC, X, Y, nil);
  IntersectClipRect(DC, 0, 0, Control.Parent.ClientWidth, Control.Parent.ClientHeight);
  TParentControl(Control.Parent).Perform(WM_ERASEBKGND,DC,0);
  TParentControl(Control.Parent).PaintWindow(DC);
  RestoreDC(DC, SaveIndex);
//Copy images of graphic controls
for I := 0 to Count – 1 do begin
if (Control.Parent.Controls[I] <> nil) then
begin
if Control.Parent.Controls[I] = Control then break;
with Control.Parent.Controls[I] do
begin
        CtlR := Bounds(Left, Top, Width, Height);
if Bool(IntersectRect(R, SelfR, CtlR)) and Visible then
begin
          SaveIndex := SaveDC(DC);
          SetViewportOrgEx(DC, Left + X, Top + Y, nil);
          IntersectClipRect(DC, 0, 0, Width, Height);
          Perform(WM_ERASEBKGND,DC,0);
          Perform(WM_PAINT, integer(DC), 0);
          RestoreDC(DC, SaveIndex);
end;
end;
end;
end;
end;
end.

Delphi

GDI+ TextureBrush paints image offset

The GDI plus TextureBrush renders The brush from the origin of the Graphics canvas that it is drawing to, so if you fill a rectange with a textured brush starting at 10,10 then the brush appears offset.
To ensure the top left corner of the image you have used in your texture brush starts at the same place onthe rectangle you are filling we need to set the brushes translation Transformation to the top left corner of the rectange to fill.
e.g
  ABrush  := TGPTextureBrush.Create(AImage,WrapModeTile);
  ABrush.TranslateTransform(x,y);
  AGraphics.FillRectangle(ABrush,x,y,width,height);
  ABrush.free;

Delphi

Show / Hide a Forms icon and caption in the Taskbar

It is possible to hide the applications mainform from the taskbar or put other forms in your application on the task bar by simply changing the create params as the form is constructed.
Override the Form’s CreateParams and add one of the following to either remove or add to the taskbar
to Show in the taskbar

procedure TForm.CreateParams(var Params: TCreateParams);
begin
  ExStyle := ExStyle or WS_EX_APPWINDOW;
end;

to remove from the taskbar

procedure TForm.CreateParams(var Params: TCreateParams);
begin
  ExStyle := ExStyle and not  WS_EX_APPWINDOW;
end;

Delphi

Delphi Register procedure will not Register Controls

So, you’re changing your packages and splitting them up nicely into a runtime and design time package.  You create a new Component Registration unit and add a register procedure, compile it all up and the register procedure never gets called and the components are not registered……

Oh, how many times has this happened to me ? 

I finally worked out what was wrong.  Not being a copy and paste guy, I typed in the register procedure and didn’t capitalise the ‘R’.  Therefore the entry point to the DLL is never found !  Oh those case-sensitive C programmers have a lot to answer for.
Please ensure the procedure Register is the correct case 🙂