Buttons with wrapped text - use a TBitBtn

Problem/Question/Abstract:

Buttons with wrapped text - use a TBitBtn

Answer:

Besides using a TButton with an embedded TLabel, you can simply use a TBitBtn to display wrapped text. This can be achieved by either of the following ways:

Select 'view form as text' (Alt-F12) and change the TBitBtn caption to Caption = 'wrapped'#10'here'#10'and there' then 'view as form' again. Caution: a few mistypes and have strange consequences here: DO NOT change names or cut and paste new objects, modify only those already created

In startup code (.FormCreate()) set caption to 'Hello' + #10 + 'World';

If you copy a LF(#10) to clipboard you can paste (shift-insert) it into the TBitBtn caption to get the multi line text at design time CR doesn't work for this nor does alt-013 or alt-010 :-( this at least allows captioning.

Determining the record number in a dBASE/Paradox table

Problem/Question/Abstract:

Determining the record number in a dBASE/Paradox table

Answer:

The following procedure determines the physical number of the current record
in a dBase or Paradox table:

function FindRecordNumber(aDataSet: TDataSet): longint;
var
  cP: CurProps;
  rP: RECProps;
  DBRes: DBiResult;
begin
  {Return 0 if dataset is not Paradox or dBase}
  Result := 0;

  with aDataset do
  begin
    if state = dsInactive then
      exit;

    {we need to make this call to grab the cursor's iSeqNums}
    DBRes := DBiGetCursorProps(Handle, cP);
    if DBRes <> DBIERR_NONE then
      exit;

    {synchronize the BDE cursor with the dataset's cursor}
    UpdateCursorPos;

    {fill rP with the current record's properties}
    DBRes := DBiGetRecord(Handle, DBiNOLOCK, nil, @rP);
    if DBRes <> DBIERR_NONE then
      exit;

    {what kind of dataset are we looking at?}
    case cP.iSeqNums of
      0: result := rP.iPhyRecNum; {dBase}
      1: result := rP.iSeqNum; {Paradox}
    end;
  end;
end;

How to quickly clear a large TCanvas

Problem/Question/Abstract:

How to quickly clear a large TCanvas

Answer:

You can use the PatBlt API call for this purpose. The function takes six parameters:

HDC: hdc - The handle of the canvas to be cleared
nXleft: integer - X coordinate of the upper left corner of canvas to be cleared
nYleft: integer - Y coordinate of the upper left corner of canvas to be cleared
nWidth: integer - The width of the canvas to be cleared
nHeight: integer - The height of the canvas to be cleared
dwRop: dWord - Raster operation code (WHITENESS in our case, for clearing the canvas)


To be used like this:


{ ... }
PatBlt(Image1.Canvas.Handle, 0, 0, Image1.Width, Image1.Height, WHITENESS);
Image1.Refresh;
{ ... }


Instead of WHITENESS you could also use:

PATCOPY - Copies the specified pattern into the destination bitmap
PATINVERT - Combines the colors of the specified pattern with the colors of the destination rectangle by using the Boolean OR operator
DSTINVERT - Inverts the destination rectangle
BLACKNESS - Fills the destination rectangle using the color associated with index 0 in the physical palette (This color is black for the default physical palette)
WHITENESS - Fills the destination rectangle using the color associated with index 1 in the physical palette (This color is white for the default physical palette)

Create a XML-file with data from some dataset

Problem/Question/Abstract:

How to generate the XML-file from linked dataset?

Answer:

Solve 1:

Sometimes in our development we must export a data from dataset into different formats like MS Excel, Word, HTML, Text etc. Now in the Internet we have a new popular format - XML-file. So for large part of applications we wants to include the possibility of export into XML, of course. I want to demonstrate the sample of one procedure for exporting of dataset's data into XML:

procedure DatasetToXML(Dataset: TDataset; FileName: string);

The first Dataset parameter is source dataset with data (your Table or Query component, or some other third-party dataset). The second FileName parameter is a name of target XML-file.

{ SMExport suite's free demo
  Data export from dataset into XML-file

  Copyright(C) 2000, written by Scalabium, Shkolnik Mike
  E-Mail:  smexport@scalabium.com
           mshkolnik@yahoo.com
  WEB: http://www.scalabium.com
       http://www.geocities.com/mshkolnik
}
unit DS2XML;

interface

uses
  Classes, DB;

procedure DatasetToXML(Dataset: TDataset; FileName: string);

implementation

uses
  SysUtils;

var
  SourceBuffer: PChar;

procedure WriteString(Stream: TFileStream; s: string);
begin
  StrPCopy(SourceBuffer, s);
  Stream.Write(SourceBuffer[0], StrLen(SourceBuffer));
end;

procedure WriteFileBegin(Stream: TFileStream; Dataset: TDataset);

  function XMLFieldType(fld: TField): string;
  begin
    case fld.DataType of
      ftString: Result := '"string" WIDTH="' + IntToStr(fld.Size) + '"';
      ftSmallint: Result := '"i4"'; //??
      ftInteger: Result := '"i4"';
      ftWord: Result := '"i4"'; //??
      ftBoolean: Result := '"boolean"';
      ftAutoInc: Result := '"i4" SUBTYPE="Autoinc"';
      ftFloat: Result := '"r8"';
      ftCurrency: Result := '"r8" SUBTYPE="Money"';
      ftBCD: Result := '"r8"'; //??
      ftDate: Result := '"date"';
      ftTime: Result := '"time"'; //??
      ftDateTime: Result := '"datetime"';
    else
    end;
    if fld.Required then
      Result := Result + ' required="true"';
    if fld.Readonly then
      Result := Result + ' readonly="true"';
  end;

var
  i: Integer;
begin
  WriteString(Stream,
    '<?xml version="1.0" standalone="yes"?><!-- Generated by SMExport -->  ' +
    '<DATAPACKET Version="2.0">');
  WriteString(Stream, '<METADATA><FIELDS>');

  {write th metadata}
  with Dataset do
    for i := 0 to FieldCount - 1 do
    begin
      WriteString(Stream, '<FIELD attrname="' +
        Fields[i].FieldName +
        '" fieldtype=' +
        XMLFieldType(Fields[i]) +
        '/>');
    end;
  WriteString(Stream, '</FIELDS>');
  WriteString(Stream, '<PARAMS DEFAULT_ORDER="1" PRIMARY_KEY="1" LCID="1033"/>');
  WriteString(Stream, '</METADATA><ROWDATA>');
end;

procedure WriteFileEnd(Stream: TFileStream);
begin
  WriteString(Stream, '</ROWDATA></DATAPACKET>');
end;

procedure WriteRowStart(Stream: TFileStream; IsAddedTitle: Boolean);
begin
  if not IsAddedTitle then
    WriteString(Stream, '<ROW');
end;

procedure WriteRowEnd(Stream: TFileStream; IsAddedTitle: Boolean);
begin
  if not IsAddedTitle then
    WriteString(Stream, '/>');
end;

procedure WriteData(Stream: TFileStream; fld: TField; AString: ShortString);
begin
  if Assigned(fld) and (AString <> '') then
    WriteString(Stream, ' ' + fld.FieldName + '="' + AString + '"');
end;

function GetFieldStr(Field: TField): string;

  function GetDig(i, j: Word): string;
  begin
    Result := IntToStr(i);
    while (Length(Result) < j) do
      Result := '0' + Result;
  end;

var
  Hour, Min, Sec, MSec: Word;
begin
  case Field.DataType of
    ftBoolean: Result := UpperCase(Field.AsString);
    ftDate: Result := FormatDateTime('yyyymmdd', Field.AsDateTime);
    ftTime: Result := FormatDateTime('hhnnss', Field.AsDateTime);
    ftDateTime:
      begin
        Result := FormatDateTime('yyyymmdd', Field.AsDateTime);
        DecodeTime(Field.AsDateTime, Hour, Min, Sec, MSec);
        if (Hour <> 0) or (Min <> 0) or (Sec <> 0) or (MSec <> 0) then
          Result := Result + 'T' + GetDig(Hour, 2) + ':' + GetDig(Min, 2) + ':' +
            GetDig(Sec, 2) + GetDig(MSec, 3);
      end;
  else
    Result := Field.AsString;
  end;
end;

procedure DatasetToXML(Dataset: TDataset; FileName: string);
var
  Stream: TFileStream;
  bkmark: TBookmark;
  i: Integer;
begin
  Stream := TFileStream.Create(FileName, fmCreate);
  SourceBuffer := StrAlloc(1024);
  WriteFileBegin(Stream, Dataset);

  with DataSet do
  begin
    DisableControls;
    bkmark := GetBookmark;
    First;

    {write a title row}
    WriteRowStart(Stream, True);
    for i := 0 to FieldCount - 1 do
      WriteData(Stream, nil, Fields[i].DisplayLabel);
    {write the end of row}
    WriteRowEnd(Stream, True);

    while (not EOF) do
    begin
      WriteRowStart(Stream, False);
      for i := 0 to FieldCount - 1 do
        WriteData(Stream, Fields[i], GetFieldStr(Fields[i]));
      {write the end of row}
      WriteRowEnd(Stream, False);

      Next;
    end;

    GotoBookmark(bkmark);
    EnableControls;
  end;

  WriteFileEnd(Stream);
  Stream.Free;
  StrDispose(SourceBuffer);
end;

end.


Solve 2:

there is a simpler way of saving the resultset in a xml-file...

drop a TClientDataSet and a TdataSetProvider on the form.
set the TDatasetProvider.dataset to point to your TQuery.
Set the TClientDataSet.ProviderName to point to the TDataSetProvider.

In the code write:

ClientDataSet.active := true;
ClentDataSet.SaveToFile('c: \results.xml');

as long as the type name of the file is xml, it will be a xml-file.

Passing String Parameters to WinAPI Functions

Problem/Question/Abstract:

I'm using the Winexec command and trying to use a string as the argument, but Winexec takes only a Pchar as its argument. I can't figure out how to put a regular string into a Pchar, or how to make a Pchar 'point' to a character string.

Answer:

WinAPI calls can be pretty confusing, huh? Let's say you have a function called WinAPICall that takes a PChar as an argument. Here are a couple of ways to make the call:

First Method (This will only work for Delphi 2.0 and above, which supports casting):

WinAPICall(PChar(MyStringVal));

Second Method:

procedure CallWinApiCall(S: string);
var
  Val: string;
  pVal: PChar;
begin
  Val := S;
  {Initialize memory for the PChar}
  GetMem(pVal, Length(Val));

  {Copy the contents of Val to PChar}
  pVal := StrPCopy(pVal, Val);
  WinAPICall(pVal);

  {This next step is ABSOLUTELY necessary}
  FreeMem(pVal, Length(Val));
end;

In any case, that should do it for you pretty nicely.

How to launch the default web browser

Problem/Question/Abstract:

How to launch the default web browser

Answer:

procedure LaunchBrowser(URL: string);
var
  HTMLbrowser: string;
  TheRegistry: TRegistry;
  Value: string;
  L: Integer;
begin
  HTMLBrowser := '';
  TheRegistry := TRegistry.Create;
  try
    TheRegistry.Rootkey := HKEY_CLASSES_ROOT;
    if TheRegistry.OpenKey('.htm', false) then
    begin
      Value := TheRegistry.ReadString('');
      TheRegistry.CloseKey;
      if Value <> '' then
        if TheRegistry.OpenKey(Value + '\shell\open\command', false) then
        begin
          HTMLbrowser := TheRegistry.ReadString('');
          if (HTMLBrowser[1] = '"') and (Pos('"', Copy(HTMLBrowser, 2,
            Length(HTMLBrowser))) > 0) then
            HTMLbrowser := Copy(HTMLbrowser, 1, Pos('"', Copy(HTMLBrowser,
              2, Length(HTMLBrowser))) + 1)
          else
          begin
            L := 1;
            while (L <= Length(HTMLBrowser)) and (HTMLBrowser[L] <> ' ') do
              Inc(L);
            HTMLBrowser := Copy(HTMLBrowser, 1, L);
          end;
          TheRegistry.CloseKey;
        end;
    end;
  finally
    TheRegistry.Free;
    if HTMLBrowser <> '' then
      ShellExecute(0, 'open', pchar(HTMLbrowser), pchar(URL), '', SW_SHOWNORMAL)
    else
      ShellExecute(0, 'open', PChar(URL), '', '', SW_SHOWNORMAL);
  end;
end;

Language for MS Office

Problem/Question/Abstract:

How can I read the default language of installed MS Office application?

Answer:

you may initialize Word.Application instance and read a CountryID:

var
  word: Variant;
begin
  word := CreateOLEObject('Word.Application');
  CountryID := word.System.Country;
  word.Quit;
  word := UnAssigned;
end;

After that check this CountryID with next values:

wdUS = $00000001;
wdCanada = $00000002;
wdLatinAmerica = $00000003;
wdNetherlands = $0000001F;
wdFrance = $00000021;
wdSpain = $00000022;
wdItaly = $00000027;
wdUK = $0000002C;
wdDenmark = $0000002D;
wdSweden = $0000002E;
wdNorway = $0000002F;
wdGermany = $00000031;
wdPeru = $00000033;
wdMexico = $00000034;
wdArgentina = $00000036;
wdBrazil = $00000037;
wdChile = $00000038;
wdVenezuela = $0000003A;
wdJapan = $00000051;
wdTaiwan = $00000376;
wdChina = $00000056;
wdKorea = $00000052;
wdFinland = $00000166;
wdIceland = $00000162;

Get the visible rectangle area of a windowed control

Problem/Question/Abstract:

How do I get the visible rectangle area of a windowed control (including TForm)? Sometimes parts of the control's client area are not visible or not even on screen.

Answer:

This is one of the secrets which is seldomly asked or answered. Each window has serveral clipping regions, which determine where it is allowed to draw. One is the well not clipping region, which you can set with SetClipRgn. But this is only an application defined part. Another one is the socalled meta region, which includes all of the window plus the application defined clipping region. And yet another one is the socalled system region, which includes all other plus anything clipped out which is currently overlapped by other windows (including those from other applications) and the screen area. This one must be made available first so you can use it. The definition is:

const {Region identifiers for GetRandomRgn}
  CLIPRGN = 1;
  METARGN = 2;
  APIRGN = 3;
  SYSRGN = 4;

function GetRandomRgn(DC: HDC; Rgn: HRGN; iNum: Integer): Integer; stdcall; external
  'GDI32.DLL';

According to MSDN only SYSRGN can be used with GetRandomRgn. I found the other IDs too, however I don't know what they are for and they do not return anything. A typical scenario to get that region is:

{ ... }
  {Retrieve the visible region of the window. This is important to avoid overpainting parts of other windows which overlap this one.}
VisibleTreeRegion := CreateRectRgn(0, 0, 1, 1);
DC := GetDCEx(Handle, 0, DCX_CACHE or DCX_WINDOW or DCX_CLIPSIBLINGS
  or DCX_CLIPCHILDREN);
GetRandomRgn(DC, VisibleTreeRegion, SYSRGN);
ReleaseDC(Handle, DC);
{In Win9x the returned visible region is given in client coordinates. We need it in screen coordinates, though.}
if not IsWinNT then
  with ClientToScreen(Point(0, 0)) do
    OffsetRgn(VisibleTreeRegion, X, Y);
{ ... }

You can see you have to create (and later destroy, don't forget that) a region first, which is then filled with the system region data.

Snap a form to another one and move both around

Problem/Question/Abstract:

How do I get forms been redrawn while moving them? I need a form that snaps magnetically to another while moved, but there is no event! I've tried the message WM_WINDOWPOSCHANGING, but it's not possible to show when it fires, because the form is not redrawn, when moved.

Answer:

Note that MOPSChildForm is the "master" and SearchForm follows it around.

procedure TMOPSChildForm.WMWindowPosChanging(var Message: TWMWindowPosChanging);
var
  Moving: Boolean;
begin
  if SearchForm <> nil then
  begin
    with Message.WindowPos^ do
      Moving := (ComponentState * [csReading, csDestroying] = []) and (flags and
        SWP_NOSIZE = 0)
        and ((x <> Left) or (y <> Top));
    inherited;
    if Moving then
      SearchForm.MoveWithForm(HostDockSite <> nil)
  end;
end;

procedure TMOPSSearch.MoveWithForm(Docked: Boolean);
const
  DeltaX = 20; {Offset of this form from MOPSChildForm's TopLeft}
  DeltaY = 40;
begin
  if Docked then
    with TForm(TForm(TForm(Owner).HostDockSite).Owner) do
    begin
      Self.Left := Left + DeltaX;
      Self.Top := Top + DeltaY;
    end
  else
    with TForm(Owner) do
    begin
      Self.Left := Left + DeltaX;
      Self.Top := Top + DeltaY;
    end;
end;

A class to toggle image display in Internet Explorer 5

Problem/Question/Abstract:

Internet Explorer 5 (and others) allows you to toggle image displays. If you are using Twebbrowser this can speed up retrieving webpages as the graphics are not longer fetched.

Answer:

A year ago I had an article published in Delphi Developer on writing Web-robots using the twebbrowser that is part of Internet Explorer and which you can install in Delphi 3 or 4 and comes pre-installed in Delphi 5.

My only gripes with using Twebbrowser are that there is a fair bit of baggage- it renders every web-page which slows things down (especially when it has to retrieve every image on the page).  The class below implements a way of disabling image display (toggling the IE switch programmatically) in IE 5 to speed up web-robots written using it. It hasn&#8217;t beeen tested in IE 4 or IE 5.5 though I suspect it will probably work.

type
  TViewIEImage = class
  private
    fSavedimagesVisible: Boolean;
    function GetState: Boolean;
    procedure SetVisible(Visible: Boolean);
  public
    BroadcastChange: Boolean;
    constructor Create;
    destructor Destroy; override;
    property ImagesVisible: Boolean read GetState write SetVisible;
    property SavedImagesVisible: Boolean read fSavedimagesVisible write
      fSavedimagesVisible;
  end;

constructor TViewIEImage.Create;
begin
  fSavedimagesVisible := GetState;
  BroadcastChange := True;
end;

destructor TViewIEImage.Destroy;
begin
  SetVisible(fSavedimagesVisible);
end;

function TViewIEImage.GetState: Boolean;
begin
  Result := GetRegistryValue = 'yes';
end;

procedure TViewIEImage.SetVisible(Visible: Boolean);
var
  Reg: TRegistry;
  Str: string;
begin
  if Visible then
    Str := 'yes'
  else
    Str := 'no';
  Reg := TRegistry.Create;
  try
    Reg.RootKey := HKEY_CURRENT_USER;
    if Reg.OpenKey('\Software\Microsoft\Internet Explorer\Main',
      False) then
      Reg.WriteString('Display Inline Images', Str);
  finally
    Reg.CloseKey;
    Reg.Free;
    inherited;
  end;
  if BroadcastChange or Visible then
    PostMessage(
      HWND_BROADCAST,
      WM_WININICHANGE,
      0,
      Longint(pchar('HKEY_CURRENT_USER\Software\Microsoft\Internet
      Explorer\Main')));
end;

In future articles I will look at writing web robots without using twebbrowser.

Open a webpage in a webbrowser that's allready active

Problem/Question/Abstract:

Open a webpage in a webbrowser that's allready active.

Answer:

{
This opens a webpage in a browser window that's allready active.
I found the code somewhere on the borland site.
}

procedure GotoWebPage;
var
  DDE: TDDECLientConv;
  URL: string;
  URLFired: Boolean;
begin
  URL := 'http://www.hotbot.com';

  DDE := TDDEClientConv.Create(nil);
  try
    DDE.ServiceApplication := 'iexplore';

    if DDE.SetLink('iexplore', 'WWW_OpenURL') then
      if DDE.RequestData(URL + ',,1') <> nil then
        if DDE.SetLink('iexplore', 'WWW_Activate') then
          URLFired := DDE.RequestData('0,0') <> nil;
  finally
    DDE.Free;
  end;
end;

Change character set of printer's font

Problem/Question/Abstract:

How to change character set of printer's font?

Answer:

uses Sysutils, Printers;

procedure TForm1.Button1Click(Sender: TObject);
var
  Dosya: TextFile
begin
  with Printer do
  begin
    AssignPrn(Dosya);
    Rewrite(Dosya);
    Printer.Canvas.Font.Name := 'Courier New';
    Printer.Canvas.Font.Style := [fsBold];
    Printer.Canvas.Font.Size := 18;

    //****for Turkish special characters
    Writeln(Dosya, '?�i??�?');

    //****set Font CharSet to Turkish(162)
    Printer.Canvas.Font.Charset := 162;
    Writeln(Dosya, '?�i??�?');

    CloseFile(Dosya);
  end;
end;

The following table lists the predefined constants provided for standard character sets:

type
  TFontCharset = 0..255;

Constant Value Description

ANSI_CHARSET 0 ANSI characters.
DEFAULT_CHARSET 1 Font is chosen based solely on Name and Size. If the described font is not available on the system, Windows will substitute another font.
SYMBOL_CHARSET 2 Standard symbol set.
MAC_CHARSET 77 Macintosh characters. Not available on NT 3.51.
SHIFTJIS_CHARSET 128 Japanese shift-jis characters.
HANGEUL_CHARSET 129 Korean characters (Wansung).
JOHAB_CHARSET 130 Korean characters (Johab). Not available on NT 3.51

GB2312_CHARSET 134 Simplified Chinese characters (mainland china).
CHINESEBIG5_CHARSET 136 Traditional Chinese characters (taiwanese).
GREEK_CHARSET 161 Greek characters. Not available on NT 3.51.
TURKISH_CHARSET 162 Turkish characters. Not available on NT 3.51
VIETNAMESE_CHARSET 163 Vietnamese characters. Not available on NT 3.51.
HEBREW_CHARSET 177 Hebrew characters. Not available on NT 3.51
ARABIC_CHARSET 178 Arabic characters. Not available on NT 3.51

BALTIC_CHARSET 186 Baltic characters. Not available on NT 3.51.
RUSSIAN_CHARSET 204 Cyrillic characters. Not available on NT 3.51.
THAI_CHARSET 222 Thai characters. Not available on NT 3.51
EASTEUROPE_CHARSET 238 Includes diacritical marks for eastern european countries. Not available on NT 3.51.
OEM_CHARSET 255 Depends on the codepage of the operating system.

A ScrollText Component

Problem/Question/Abstract:

If you need to Scroll Text like those led advertising things you can use this component.

Answer:

//
//  Scroll Text Component
// Author: Jorge Abel Ayala Marentes
// Created: 25/01/2001
//
unit ScrollText;

interface

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

type
  TColorType = (ctGreen, ctRed, ctBlue);

  TScrollText = class(TComponent)
  private
    FText: string;
    FTimer: TTimer;
    FTextColor: TColorType;
    vi_Mv, vi_St: Integer;
    procedure SetText(const Value: string);
    procedure CustomOnTimer(Sender: TObject);
    procedure SetTextColor(const Value: TColorType);
  protected
  public
    procedure ScrollText;
    constructor Create(AOwner: TComponent); override;
    destructor Destroy; override;
  published
    property Text: string read FText write SetText;
    property TextColor: TColorType read FTextColor write SetTextColor;
  end;

procedure Register;

implementation

procedure Register;
begin
  RegisterComponents('prueba', [TScrollText]);
end;

{ TScrollText }

constructor TScrollText.Create(AOwner: TComponent);
begin
  inherited;
  vi_Mv := 0;
  vi_St := 1;

  FTimer := TTimer.Create(Self);
  with FTimer do
  begin
    Enabled := True;
    Interval := 5;
    OnTimer := CustomOnTimer;
  end;

  if not (AOwner.InheritsFrom(TForm)) then
    raise Exception.Create('This Component can only be dropped on Forms!');

  //Set the Forms Height
  with (Owner as TForm) do
  begin
    Height := 90;
    Color := clBlack;
    BorderStyle := bsDialog;
    Caption := '';
  end;

  ScrollText;
end; //end of TScrollText.Create

procedure TScrollText.CustomOnTimer(Sender: TObject);
begin
  ScrollText;

  //Move text
  Inc(vi_Mv, vi_St);
end; //end of TScrollText.CustomOnTimer

destructor TScrollText.Destroy;
begin
  FTimer.Free;
  inherited;
end; //end of TScrollText.Destroy

procedure TScrollText.ScrollText;
var
  Bitmap: TBitmap;
  Rect: TRect;
  vi_Counter: Integer;
begin
  if not (csDesigning in Self.ComponentState) then
  begin
    //Create a Bitmap to draw the text
    Bitmap := TBitmap.Create;
    try
      //set Bitmap�s Height to equal the Message�s Height
      Bitmap.Height := Bitmap.Canvas.TextHeight(Text);

      //If the text has reaced the end then rewind
      if vi_Mv >= Bitmap.Canvas.Textwidth(Text) then
        vi_St := -16;

      //if its at the beginning, go forward
      if vi_Mv <= 0 then
        vi_St := 1;

      //Set Bitmap�s Width
      Bitmap.Width := (Owner as TForm).Width div 4;

      with Bitmap.Canvas do
      begin
        //We are Filling it with Solid Dark Green
        Brush.Style := bssolid;
        //The colour goes BBGGRR in hex - look up TColor
        case TextColor of
          ctGreen:
            begin
              Brush.Color := $005000;
              Fillrect(ClipRect);
              Font.Color := $00FF00;
            end;
          ctRed:
            begin
              Brush.Color := $000050;
              Fillrect(ClipRect);
              Font.color := $0000FF;
            end;
          ctBlue:
            begin
              Brush.Color := $500000;
              Fillrect(ClipRect);
              Font.color := $FF0000;
            end;
        end;
        Textout(-vi_Mv, 0, Text);
        Rect := Cliprect;
        //Enlarge the image to twice its original size
        Bitmap.Height := Bitmap.Height * 2;
        Bitmap.Width := Bitmap.Width * 2;

        CopyRect(ClipRect, Bitmap.canvas, Rect);
        //Set up pen for solid black
        Pen.Style := pssolid;
        Pen.Color := clblack;

        //Draw a grid of lines across the bitmap in X+Y
        for vi_Counter := 0 to Bitmap.Height div 2 do
        begin
          MoveTo(0, vi_Counter * 2);
          LineTo(Bitmap.width, vi_Counter * 2);
        end;

        for vi_Counter := 0 to Bitmap.width div 2 do
        begin
          MoveTo(vi_Counter * 2, 0);
          LineTo(vi_counter * 2, Bitmap.height);
        end;

        //Stretch bitmap again and draw twice its size on the form
        Rect := Bitmap.Canvas.ClipRect;
        Rect.Bottom := Rect.Bottom * 2;
        Rect.Right := Rect.Right * 2;
        (Owner as TForm).Canvas.StretchDraw(Rect, Bitmap);

      end;
    finally
      Bitmap.Free;
    end;
  end;
end; //end of TScrollText.ScrollText

procedure TScrollText.SetText(const Value: string);
begin
  if Value <> FText then
    FText := Value;

  ScrollText;
end; //end of TScrollText.SetText

procedure TScrollText.SetTextColor(const Value: TColorType);
begin
  if FTextColor <> Value then
    FTextColor := Value;
end; //end of TScrollText.SetTextColor

end.

Finding all computers in a workgroup

Problem/Question/Abstract:

Finding all computers in a workgroup.

Answer:

var
  Computer: array[1..500] of string[25];
  ComputerCount: Integer;

procedure FindAllComputers(Workgroup: string);
var
  EnumHandle: THandle;
  WorkgroupRS: TNetResource;
  Buf: array[1..500] of TNetResource;
  BufSize: Integer;
  Entries: Integer;
  Result: Integer;

begin
  ComputerCount := 0;

  Workgroup := Workgroup + #0;

  FillChar(WorkgroupRS, SizeOf(WorkgroupRS), 0);
  with WorkgroupRS do
  begin
    dwScope := 2;
    dwType := 3;
    dwDisplayType := 1;
    dwUsage := 2;
    lpRemoteName := @Workgroup[1];
  end;

  WNetOpenEnum(RESOURCE_GLOBALNET,
    RESOURCETYPE_ANY,
    0,
    @WorkgroupRS,
    EnumHandle);

  repeat
    Entries := 1;
    BufSize := SizeOf(Buf);

    Result :=
      WNetEnumResource(EnumHandle,
      Entries,
      @Buf,
      BufSize);
    if (Result = NO_ERROR) and (Entries = 1) then
    begin
      Inc(ComputerCount);
      Computer[ComputerCount] := StrPas(Buf[1].lpRemoteName);
    end;
  until (Entries <> 1) or (Result <> NO_ERROR);

  WNetCloseEnum(EnumHandle);
end; { Find All Computers }

Overwrite an existing header or footer in Word

Problem/Question/Abstract:

Can anyone provide an example of how to set the header and footer for an entire Word document, replacing any existing header or footer?

Answer:

This example assumes one section and no odd/ even or different first page headers. Doing the Range.Select selects all text that may have been previously there, so you can use this to write the first time or to change it later. Note that if you want different headers on different pages (besides odd/ even) you will need to use sections.

{ ... }
Word.ActiveDocument.Sections.Item(1).Headers.Item(1).Range.Select;
Word.Selection.ParagraphFormat.TabStops.ClearAll;
{Set tab types to be used in header}
OleVar := wdAlignTabLeft;
OleVar2 := wdTabLeaderSpaces;
{Set tabs}
Word.Selection.ParagraphFormat.TabStops.Add(190, OleVar, OleVar2);
Word.Selection.ParagraphFormat.TabStops.Add(365, OleVar, OleVar2);
{Now tab over and write the header field}
Word.Selection.TypeText(WideString(#9)); {to centered text}
Word.Selection.TypeText(WideString('This Is The Header'));
Word.Selection.TypeText(WideString(#9));
Word.Selection.TypeText(WideString('Blah Blah'));
{Now do the footer}
Word.ActiveDocument.Sections.Item(1).Footers.Item(1).Range.Select;
Word.Selection.ParagraphFormat.TabStops.ClearAll;
{Set tab types to be used in header}
OleVar := wdAlignTabLeft;
OleVar2 := wdTabLeaderSpaces;
{Set tabs}
Word.Selection.ParagraphFormat.TabStops.Add(190, OleVar, OleVar2);
Word.Selection.TypeText(WideString(#9));
Word.Selection.TypeText(WideString('This Is The Footer'));
{ ... }

Create a simple Delphi Expert

Problem/Question/Abstract:

How to create a simple Delphi Expert

Answer:

This unit must be compiled into a package and then will appear in the delphi Help menu.

unit SDCSimpleExpert;

interface

uses ToolsApi;

type
TSDCSimpleExpert = class(TNotifierObject, IOTAMenuWizard, IOTAWizard)
public
function GetIDString: string;
function GetName: string;
function GetState: TWizardState;
procedure Execute;
function GetMenuText: string;
end;

procedure Register;

implementation

uses Dialogs;

procedure Register;
begin
{register expert}
RegisterPackageWizard(TSDCSimpleExpert.Create);
end;

{ TSDCSimpleExpert }

procedure TSDCSimpleExpert.Execute;
begin
{code to execute when menu item is clicked}
ShowMessage('Hello Simple Expert.');
end;

function TSDCSimpleExpert.GetIDString: string;
begin
{unique expert identifier}
Result := 'Hello.SimpleExpert';
end;

function TSDCSimpleExpert.GetMenuText: string;
begin
{caption of menu item in help menu}
Result := 'Simple Expert';
end;

function TSDCSimpleExpert.GetName: string;
begin
{name of the expert}
Result := 'Simple Expert';
end;

function TSDCSimpleExpert.GetState: TWizardState;
begin
Result := [wsEnabled];
end;

end.

Monitor a directory and take action when files are added

Problem/Question/Abstract:

I need to monitor a series of directories, and perform a selective deletion (based on file date) when they reach (or go over) a certain size.

Answer:

The snippet below is a procedure I wrote to monitor a directory and take action when files are added to that directory. It uses these WinAPI functions to accomplish that purpose:

FindFirstChangeNotification
WaitForSingleObject
FindNextChangeNotification
FindCloseChangeNotification

If you look these up in the help, you may be able to solve your problem using a similar technique.

procedure TDosNotifyThread.Execute;
begin
  FChangeHandle := FindFirstChangeNotification(pchar(cRequestDir), false,
    FILE_NOTIFY_CHANGE_FILE_NAME);
  repeat
    FExitWait := WaitForSingleObject(FChangeHandle, cThreadCycleTime); {See GLOBALS}
    if FExitWait = WAIT_OBJECT_0 then
      PostMessage(MilerForm.Handle, DO_REQUEST, 0, 0);
    FindNextChangeNotification(FChangeHandle);
  until
    RTQ or Terminated;
  FindCloseChangeNotification(FChangeHandle);
  if not Terminated then
    Terminate;
end;

Emptying the keyboard queue (key messages)

Problem/Question/Abstract:

Emptying the keyboard queue (key messages)

Answer:

Use the procedure below to remove all pending key messages from your own message queue.

Note that you only can empty your own application's message queue, not from that of another process.


program Dummy;

procedure EmptyKeyQueue;
var
  msg: TMsg;
begin
  while PeekMessage(msg, 0, WM_KEYFIRST, WM_KEYLAST, PM_REMOVE or PM_NOYIELD) do
    ;
end;

begin
  EmptyKeyQueue;
end.

Outlook Automation - Scaning Outlook's Folders and reading Mail

Problem/Question/Abstract:

How to serf in Outlook from myself application and read Mail

Answer:

unit UScanOutlook;

interface

uses
  Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
  StdCtrls, Grids, Outline;
const
  olByValue = 1;
  olByReference = 4;
  olEmbeddedItem = 5;
  olOLE = 6;

  olMailItem = 0;
  olAppointmentItem = 1;
  olContactItem = 2;
  olTaskItem = 3;
  olJournalItem = 4;
  olNoteItem = 5;
  olPostItem = 6;

  olFolderDeletedItems = 3;
  olFolderOutbox = 4;
  olFolderSentMail = 5;
  olFolderInbox = 6;
  olFolderCalendar = 9;
  olFolderContacts = 10;
  olFolderJournal = 11;
  olFolderNotes = 12;
  olFolderTasks = 13;

type
  TItem = class(TObject)
    Letter: OleVariant;
      name: string;
  end;
  TForm1 = class(TForm)
    oline_outlook: TOutline;
    Button8: TButton;
    procedure Button8Click(Sender: TObject);
    procedure oline_outlookDblClick(Sender: TObject);
    procedure FormCreate(Sender: TObject);
    procedure FormCloseQuery(Sender: TObject; var CanClose: Boolean);
  private
    { Private declarations }
  public
    { Public declarations }
    OlApp, NameSpace, root: OleVariant;
    List: Tlist;
    Item: TItem;
    icount: integer;
  end;

var
  Form1: TForm1;

implementation
uses ComObj;
{$R *.DFM}

procedure TForm1.Button8Click(Sender: TObject);
  procedure scan(ol: TOutline; root: OleVariant; s: string);
  var
    i, j, k: integer;
    bcount, rcount: integer;
    branch, MAPIFolder: olevariant;
    line: string;
  begin
    line := '';
    rcount := root.count;
    for i := 1 to rcount do
    begin
      line := s + root.item[i].name;
      ol.Lines.Add(line);
      List.Add(TItem.Create);
      Item := List.items[List.count - 1];
      Item.name := 'Folder';
      branch := root.item[i].folders;
      bcount := branch.count;
      MAPIFolder := Namespace.GetFolderFromId(root.item[i].EntryID,
        root.item[i].StoreID);
      if MAPIFolder.Items.count > 0 then
        for j := 1 to MAPIFolder.Items.count do
        begin
          ol.Lines.Add(s + ' ' + MAPIFolder.Items[j].subject);
          List.Add(TItem.Create);
          Item := List.items[List.count - 1];
          Item.name := 'File';
          Item.Letter := MAPIFolder.Items[j];
        end;
      if bcount > 0 then
      begin
        scan(ol, branch, s + ' ');
      end;
    end;
  end;
begin
  oline_outlook.Lines.Clear;
  OlApp := CreateOleObject('Outlook.Application');
  Namespace := OlApp.GetNameSpace('MAPI');
  root := Namespace.folders;
  scan(oline_outlook, root, '');
end;

procedure TForm1.oline_outlookDblClick(Sender: TObject);
begin
  Item := List.items[oline_outlook.SelectedItem - 1];
  if Item.name = 'File' then
    ShowMessage(Item.Letter.Body);
end;

procedure TForm1.FormCreate(Sender: TObject);
begin
  List := TList.Create;
  Item := TItem.Create;
  icount := 0;
end;

procedure TForm1.FormCloseQuery(Sender: TObject; var CanClose: Boolean);
var
  i: integer;
begin
  for i := List.Count - 1 downto 0 do
  begin
    Item := List.Items[i];
    Item.Free;
  end;
  List.Free;
end;

end.

Change the look of Hint Window in the Delphi IDE

Problem/Question/Abstract:

How to change the look of Hint window in Delphi IDE/ in your application

Answer:

You would all have seen the hint window that appears when you focus your cursor on the controls in the Component pages in the delphi ide, (and also in the editor window in case of delphi5 and above). Here is a piece of code that u can use to change the look and feel of the hint window that appears in the delphi ide. You can use this in your application as well.

unit SNHintWindow;

interface

uses
  Windows, Messages, Classes, Graphics, Controls, Forms;

type
  TSNHintWindow = class(THintWindow)
  private
    { Private declarations }
    FRegion: THandle;
    procedure FreeCurrentRegion;

  public
    { Public declarations }

    destructor Destroy; override;
    procedure ActivateHint(Rect: TRect; const AHint: string); override;
    procedure CreateParams(var Params: TCreateParams); override;
    procedure Paint; override;

  end;

procedure Register;

implementation

procedure Register;
begin
  RegisterComponents('Hint Window', [TSNHintWindow]);
end;

destructor TSNHintWindow.Destroy;
begin
  FreeCurrentRegion;
  inherited Destroy;
end;

procedure TSNHintWindow.FreeCurrentRegion;
{Regions like other API objects should be freed when we have
finished using them. However we cannot delete a region that is
currently set in a window. Therefore in this method I set
the window region to 0 before deleting the region object}
begin
  if FRegion <> 0 then
  begin
    SetWindowRgn(Handle, 0, True);
    DeleteObject(FRegion);
    FRegion := 0;
  end;
end;

procedure TSNHintWindow.ActivateHint(Rect: TRect; const AHint: string);
begin
  with Rect do
  begin
    Left := Left + Canvas.TextWidth('SUBHA'); {Can be any text}
    Right := Right + Canvas.TextWidth('SUBHA'); {Can be any text}
    Bottom := Bottom + Canvas.TextHeight('Girija'); {Can be any text}
    Top := Top + Canvas.TextHeight('Giri'); {Can be any text}
  end;
  BoundsRect := Rect;
  FreeCurrentRegion;
  with BoundsRect do
    FRegion := CreateRoundRectRgn(0, 0, width, height, width, height);
  if FRegion <> 0 then
    SetWindowRgn(Handle, FRegion, True);
  inherited ActivateHint(Rect, AHint);
end;

procedure TSNHintWindow.CreateParams(var Params: TCreateParams);
{Here we remove the border created on the windows API-level
when the window is created}
begin
  inherited CreateParams(Params);
  Params.Style := Params.Style and not WS_BORDER;
end;

procedure TSNHintWindow.Paint;
{This methid gets called by wm_paint handler. It is responsible
for painting the hint window}
var
  r: TRect;
begin
  r := ClientRect; {get bounding rectangle}
  Inc(r.Left, 1); {move left side slightly}
  Canvas.Brush.Color := clAqua; {Set background color and font color}
  Canvas.Font.Color := clFuchsia;
  {paint string in the center of the round rect}
  DrawText(Canvas.handle, PChar(Caption), Length(Caption), R,
    DT_NOPREFIX or DT_WORDBREAK or DT_CENTER or DT_VCENTER);
end;

initialization
  Application.ShowHint := False; // destroy old hint window
  HintWindowClass := TSNHintWindow; // assign new hint window
  Application.ShowHint := True; // create new hint window

end.

Component for Saving User Settings automatically (using Tools API) companent migration to delphi 7

Problem/Question/Abstract:

Daniel Wischnewski 's Article is good.But how i can compile it on delphi7.

Answer:

As you know under delphi 6 there is DsgnIntf. unit. Instead of this unit  DesignIntf  and  DesignEditors units came with delphi 6 and after.
Now to fix code first use   DesignIntf and DesignEditors units instead of DsgnIntf.. and replase IformDesigner to IDesigner in frmDesignTimeEditor unit.After to do this you will get error.to correct this please   replace Designer.form.Name to Designer.Root.Name. And Now You can compile these usefull toll on delphi 7.
here is the code of frmDesignTimeEditor.

Thank again to Daniel Wischnewski for that good companent.

Regards ;
G�ven �zdemir.


unit frmDesignTimeEditor;

interface

uses
  Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
  StdCtrls, ExtCtrls, Buttons, ComCtrls, ComponentStateRecovery, DesignIntf, DesignEditors,
  TypInfo;

type
  // component editor for the TComponentStateRecorder class
  TCSRDesignEditor = class(TDefaultEditor)
  protected
  public
    function GetVerb(Index: Integer): String; override;
    function GetVerbCount: Integer; override;
    procedure ExecuteVerb(Index: Integer); override;
  end;

  // property editor that lists all properties of a component at design-time
  TPropertyNameEditor = class(TStringProperty)
  public
    procedure GetValues(Proc: TGetStrProc); override;
    function GetAttributes: TPropertyAttributes; override;
  end;

  // property editor that lists all components at design-time
  TComponentNameEditor = class(TStringProperty)
  public
    procedure GetValues(Proc: TGetStrProc); override;
    function GetAttributes: TPropertyAttributes; override;
  end;

  TfrmCSRDesigner = class(TForm)
    Panel1: TPanel;
    Label1: TLabel;
    edtRegKey: TEdit;
    Panel2: TPanel;
    btnOK: TBitBtn;
    trvCollections: TTreeView;
    Panel3: TPanel;
    lblComponent: TLabel;
    cmbComponent: TComboBox;
    grpProperty: TGroupBox;
    lblPropertyName: TLabel;
    cmbPropertyName: TComboBox;
    lblDefaultValue: TLabel;
    edtDefaultValue: TEdit;
    btnAddComponent: TButton;
    btnRemove: TButton;
    btnAddProperty: TButton;
    procedure btnOKClick(Sender: TObject);
    procedure trvCollectionsChange(Sender: TObject; Node: TTreeNode);
    procedure btnAddComponentClick(Sender: TObject);
    procedure cmbComponentChange(Sender: TObject);
    procedure edtRegKeyChange(Sender: TObject);
    procedure cmbPropertyNameChange(Sender: TObject);
    procedure edtDefaultValueChange(Sender: TObject);
    procedure btnAddPropertyClick(Sender: TObject);
    procedure btnRemoveClick(Sender: TObject);
  private
    FCSR: TComponentStateRecorder;
    FDesigner: IDesigner;
    procedure SetCSR(const Value: TComponentStateRecorder);
    procedure ShowProperties(Name: String);
    procedure UpdateForSelectedNode;
    procedure SetDesigner(const Value: IDesigner);
  public
    property CSR: TComponentStateRecorder read FCSR write SetCSR;
    property Designer: IDesigner read FDesigner write SetDesigner;
  end;

var
  frmCSRDesigner: TfrmCSRDesigner;

procedure Register;

implementation

{$R *.DFM}

procedure Register;
begin
  // register component
  RegisterComponents('gate(n)etwork', [TComponentStateRecorder]);
  // register property editors (they will provide drop-down lists to the OI)
  RegisterPropertyEditor(
    TypeInfo(String), TSavedComponent, 'ComponentName', TComponentNameEditor
  );
  RegisterPropertyEditor(
    TypeInfo(String), TSavedProperty, 'PropertyName', TPropertyNameEditor
  );
  // register component editor
  RegisterComponentEditor(TComponentStateRecorder, TCSRDesignEditor);
end;

{ TCSRDesignEditor }

procedure TCSRDesignEditor.ExecuteVerb(Index: Integer);
begin
  with TfrmCSRDesigner.Create(Application) do
  try
    Designer := Self.Designer;
    CSR := TComponentStateRecorder(Component);
    ShowModal;
  finally
    Free;
  end;
end;

function TCSRDesignEditor.GetVerb(Index: Integer): String;
begin
  if Index = 0 then
    Result := 'Edit all recorded Properties...'
  else
    Result := '';
end;

function TCSRDesignEditor.GetVerbCount: Integer;
begin
  Result := 1;
end;

{ TPropertyNameEditor }

function TPropertyNameEditor.GetAttributes: TPropertyAttributes;
begin
  // the property editor will provide a sorted list of possible values
  Result := [paValueList, paSortList];
end;

procedure TPropertyNameEditor.GetValues(Proc: TGetStrProc);
var
  I, Count: Integer;
  PropInfos: PPropList;
  TmpComponent: TComponent;
  SC: TSavedComponent;
begin
  // check property type
  if not (GetComponent(0) is TSavedProperty) then
    Exit;
  // get TSavedComponent (parent object)
  SC := TSavedProperties(
    TSavedProperty(GetComponent(0)).Collection
  ).SavedComponent;
  // find the corresponding component


  if SC.ComponentName = Designer.Root.Name  then
     TmpComponent := Designer.Root
   else
    TmpComponent := Designer.GetComponent(SC.ComponentName);


  // quit if component was not found
  if TmpComponent = nil then
    Exit;
  // determine the property count
  Count := GetPropList(TmpComponent.ClassInfo, [
    tkInteger, tkInt64, tkFloat, tkEnumeration, tkSet, tkChar, tkString,
    tkLString
  ], nil);
  // reserve memory needed for property informations
  GetMem(PropInfos, Count * SizeOf(PPropInfo));
  try
    // load property list
    GetPropList(TmpComponent.ClassInfo, [
      tkInteger, tkInt64, tkFloat, tkEnumeration, tkSet, tkChar, tkString,
      tkLString
    ], PropInfos);
    // save to object inspector list
    for I := 0 to Pred(Count) do
      Proc(PropInfos^[I]^.Name);
  finally
    // free resources
    FreeMem(PropInfos);
  end;
end;

{ TComponentNameEditor }

function TComponentNameEditor.GetAttributes: TPropertyAttributes;
begin
  // the property editor will provide a sorted list of possible values
  Result := [paValueList, paSortList];
end;

procedure TComponentNameEditor.GetValues(Proc: TGetStrProc);
var
  I: Integer;
begin
  // return name of form
  if Designer.Root.Name <> '' then
    Proc(Designer.Root.Name);
  // return names of all components
  for I := 0 to Pred(Designer.root.ComponentCount) do
    if Designer.root.Components[I].Name <> '' then
      Proc(Designer.root.Components[I].Name);
end;

{ TfrmCSRDesigner }

procedure TfrmCSRDesigner.btnAddComponentClick(Sender: TObject);
var
  Node: TTreeNode;
  SC: TSavedComponent;
begin
  SC := CSR.SavedComponents.Add;
  Node := trvCollections.Items.AddChild(nil, SC.DisplayName);
  trvCollections.Selected := Node;
  Node.Data := SC;
  UpdateForSelectedNode;
  Designer.Modified;
end;

procedure TfrmCSRDesigner.btnAddPropertyClick(Sender: TObject);
var
  Node: TTreeNode;
  SP: TSavedProperty;
begin
  if trvCollections.Selected = nil then
    Exit;
  if trvCollections.Selected.Data = nil then
    Exit;
  if not (TObject(trvCollections.Selected.Data) is TSavedComponent) then
    Exit;
  SP := TSavedComponent(trvCollections.Selected.Data).SavedProperties.Add;
  Node :=
    trvCollections.Items.AddChild(trvCollections.Selected, SP.DisplayName);
  Node.Data := SP;
  trvCollections.Selected := Node;
  UpdateForSelectedNode;
  Designer.Modified;
end;

procedure TfrmCSRDesigner.btnOKClick(Sender: TObject);
begin
  ModalResult := mrOK;
end;

procedure TfrmCSRDesigner.btnRemoveClick(Sender: TObject);
begin
  if trvCollections.Selected = nil then
    Exit;
  if trvCollections.Selected.Data = nil then
    Exit;
  if (TObject(trvCollections.Selected.Data) is TSavedComponent) then
  begin
    TSavedComponent(trvCollections.Selected.Data).Collection.Delete(
      TSavedComponent(trvCollections.Selected.Data).Index
    );
    trvCollections.Items.Delete(trvCollections.Selected);
  end;
  if (TObject(trvCollections.Selected.Data) is TSavedProperty) then
  begin
    TSavedProperty(trvCollections.Selected.Data).Collection.Delete(
      TSavedProperty(trvCollections.Selected.Data).Index
    );
    trvCollections.Items.Delete(trvCollections.Selected);
  end;
  Designer.Modified;
end;

procedure TfrmCSRDesigner.cmbComponentChange(Sender: TObject);
begin
  if trvCollections.Selected = nil then
    Exit;
  if trvCollections.Selected.Data = nil then
    Exit;
  if not (TObject(trvCollections.Selected.Data) is TSavedComponent) then
    Exit;
  TSavedComponent(trvCollections.Selected.Data).ComponentName :=
    cmbComponent.Text;
  trvCollections.Selected.Text :=
    TSavedComponent(trvCollections.Selected.Data).DisplayName;
  Designer.Modified;
end;

procedure TfrmCSRDesigner.cmbPropertyNameChange(Sender: TObject);
begin
  if trvCollections.Selected = nil then
    Exit;
  if trvCollections.Selected.Data = nil then
    Exit;
  if not (TObject(trvCollections.Selected.Data) is TSavedProperty) then
    Exit;
  TSavedProperty(trvCollections.Selected.Data).DefaultValue := '';
  TSavedProperty(trvCollections.Selected.Data).PropertyName :=
    cmbPropertyName.Text;
  trvCollections.Selected.Text :=
    TSavedProperty(trvCollections.Selected.Data).DisplayName;
  edtDefaultValue.Text :=
    TSavedProperty(trvCollections.Selected.Data).DefaultValue;
  Designer.Modified;
end;

procedure TfrmCSRDesigner.edtDefaultValueChange(Sender: TObject);
begin
  if trvCollections.Selected = nil then
    Exit;
  if trvCollections.Selected.Data = nil then
    Exit;
  if not (TObject(trvCollections.Selected.Data) is TSavedProperty) then
    Exit;
  TSavedProperty(trvCollections.Selected.Data).DefaultValue :=
    edtDefaultValue.Text;
  Designer.Modified;
end;

procedure TfrmCSRDesigner.edtRegKeyChange(Sender: TObject);
begin
  FCSR.RegistryKey := edtRegKey.Text;
  Designer.Modified;
end;

procedure TfrmCSRDesigner.SetCSR(const Value: TComponentStateRecorder);
var
  I, J: Integer;
  SC: TSavedComponent;
  SP: TSavedProperty;
  SCNode, SPNode: TTreeNode;
begin
  FCSR := Value;
  // load registry key
  edtRegKey.Text := FCSR.RegistryKey;
  trvCollections.Items.Clear;
  // parse all selected components
  for I := 0 to Pred(FCSR.SavedComponents.Count) do
  begin
    SC := FCSR.SavedComponents.Items[I];
    SCNode := trvCollections.Items.AddChild(nil, SC.DisplayName);
    SCNode.Data := SC;
    // parse all selected properties
    for J := 0 to Pred(SC.SavedProperties.Count) do
    begin
      SP := SC.SavedProperties.Items[J];
      SPNode := trvCollections.Items.AddChild(SCNode, SP.DisplayName);
      SPNode.Data := SP;
    end;
  end;
  // select the first item in the list
  if trvCollections.Items.Count > 0 then
    trvCollections.Selected := trvCollections.Items.Item[0];
  if Designer <> nil then
  begin
    // return name of form
    if Designer.root.Name <> '' then
      cmbComponent.Items.Add(Designer.root.Name);
    // return names of all components
    for I := 0 to Pred(Designer.root.ComponentCount) do
      if Designer.root.Components[I].Name <> '' then
        cmbComponent.Items.Add(Designer.root.Components[I].Name);
  end;
  // show state of selection
  UpdateForSelectedNode;
end;

type
  TEnableStates = (esComponent, esProperty);
  TEnableStateSet = set of TEnableStates;

procedure TfrmCSRDesigner.SetDesigner(const Value: IDesigner);
begin
  FDesigner := Value;
end;

procedure TfrmCSRDesigner.ShowProperties(Name: String);
var
  I, Count: Integer;
  PropInfos: PPropList;
  TmpComponent: TComponent;
begin
  // clear list
  cmbPropertyName.Clear;
  // stop if no component name is provided
  if Name = '' then
    Exit;
  //  get component
  if CSR.Owner.Name = Name then
   TmpComponent := CSR.Owner
  else
    TmpComponent := CSR.Owner.FindComponent(Name);
  // stop if component was not found
  if TmpComponent = nil then
    Exit;
  // determine the property count
  Count := GetPropList(TmpComponent.ClassInfo, [
    tkInteger, tkInt64, tkFloat, tkEnumeration, tkSet, tkChar, tkString,
    tkLString
  ], nil);
  // reserve memory needed for property informations
  GetMem(PropInfos, Count * SizeOf(PPropInfo));
  try
    // load property list
    GetPropList(TmpComponent.ClassInfo, [
      tkInteger, tkInt64, tkFloat, tkEnumeration, tkSet, tkChar, tkString,
      tkLString
    ], PropInfos);
    // save to object inspector list
    for I := 0 to Pred(Count) do
      cmbPropertyName.Items.Add(PropInfos^[I]^.Name);
  finally
    // free resources
    FreeMem(PropInfos);
  end;
end;

procedure TfrmCSRDesigner.trvCollectionsChange(Sender: TObject;
  Node: TTreeNode);
begin
  UpdateForSelectedNode;
end;

procedure TfrmCSRDesigner.UpdateForSelectedNode;
var
  CompName, PropertyName: String;
  EnableStates: TEnableStateSet;
begin
  EnableStates := [];
  Name := '';
  if trvCollections.Selected <> nil then
    if trvCollections.Selected.Data <> nil then
    begin
      if TObject(trvCollections.Selected.Data) is TSavedComponent then
      begin
        cmbComponent.Text :=
          TSavedComponent(trvCollections.Selected.Data).ComponentName;
        EnableStates := EnableStates + [esComponent];
        cmbPropertyName.Text := '';
        edtDefaultValue.Text := '';
        trvCollections.Selected.Text :=
          TSavedComponent(trvCollections.Selected.Data).DisplayName;
        CompName := '';
        PropertyName := '';
      end;
      if TObject(trvCollections.Selected.Data) is TSavedProperty then
      begin
        EnableStates := EnableStates + [esProperty];
        CompName :=
          TSavedProperties(TSavedProperty(
            trvCollections.Selected.Data
          ).Collection).SavedComponent.ComponentName;
        cmbComponent.Text := CompName;
        PropertyName :=
          TSavedProperty(trvCollections.Selected.Data).PropertyName;
        cmbPropertyName.Text := Name;
        edtDefaultValue.Text :=
          TSavedProperty(trvCollections.Selected.Data).DefaultValue;
        trvCollections.Selected.Text :=
          TSavedProperty(trvCollections.Selected.Data).DisplayName;
      end;
    end;
  cmbComponent.Enabled := esComponent in EnableStates;
  lblComponent.Enabled := esComponent in EnableStates;
  btnAddProperty.Enabled := esComponent in EnableStates;
  cmbPropertyName.Enabled := esProperty in EnableStates;
  lblPropertyName.Enabled := esProperty in EnableStates;
  edtDefaultValue.Enabled := esProperty in EnableStates;
  lblDefaultValue.Enabled := esProperty in EnableStates;
  grpProperty.Enabled := esProperty in EnableStates;
  btnRemove.Enabled := EnableStates <> [];
  ShowProperties(CompName);
  cmbPropertyName.Text := PropertyName;
  trvCollections.Update;
end;

end.

How to override the standard row selection behaviour of a TDBGrid

Problem/Question/Abstract:

How to override the standard row selection behaviour of a TDBGrid

Answer:

The standard behaviour is as follows:

Keyboard - If you hold down the Shift key and use the arrow keys the rows are continuously selected as you step through the grid. Clear all selections with the Escape key.

Mouse - If you hold down the Ctrl key and click with the mouse you can select/ deselect individual rows.

The following code allows selection/ deselection by hitting the spacebar and also allows stepping up/ down with the arrow keys without causing deselection.

procedure TForm1.DBGrid1KeyDown(Sender: TObject; var Key: Word; Shift: TShiftState);
begin
  if (Shift = []) then
  begin
    case Key of
      VK_UP:
        begin
          Key := 0;
          TDBGrid(Sender).DataSource.DataSet.Prior;
        end;
      VK_Down:
        begin
          Key := 0;
          TDBGrid(Sender).DataSource.DataSet.Next;
        end;
      VK_Space:
        begin
          Key := 0;
          TDBGrid(Sender).SelectedRows.CurrentRowSelected :=
            not (TDBGrid(Sender).SelectedRows.CurrentRowSelected);
        end;
    end;
  end;
end;

Simulate an OnCheck event for TListView checkboxes

Problem/Question/Abstract:

I am working on a program that uses a TListView with the checkboxes property set to true. There are several things I would like to be triggered off of the boxes being checked or unchecked. Is there any OnCheck event or something similar that I can use to start a process off of the check of one of these boxes?

Answer:

It seems, there isn't such event. But you could use this workaround:

procedure TForm1.ListView1MouseDown(Sender: TObject; Button: TMouseButton;
  Shift: TShiftState; X, Y: Integer);
var
  li: TListItem;
  ht: THitTests;
begin
  if ListView1.Items.Count <= 0 then
    exit;
  li := ListView1.GetItemAt(x, y);
  if Li <> nil then
  begin
    if li.Selected = false then
      li.Selected := true;
  end
  else
    exit;
  ht := LVSoLine.GetHitTestInfoAt(x, y);
  if ht = [htOnStateIcon] then
  begin
    { Write your code here for checkbox OnCheck event. Remember this will
    fire after the checkbox state is changed }
  end;
end;

How to blend two TBitmap's

Problem/Question/Abstract:

I need to combine two images: One is a jpeg and the other is a watermark. I have succeeded in placing a jpeg, bmp and gif (converted to bmp) in/ on the image, but I do not not know how to make the watermark image transparent. I want the main jpeg to show through the watermark.

Answer:

The easiest way is using AlphaBlend function, however it works under Win98/ NT/ 2000 only. To make things working under 95 as well you have to implement semitransparency by hands.

{Blend background and foreground bitmaps to get the semitransparency effect}
var
  i, j: Integer;
  BackPoint, ForePoint: pByteArray;
begin
  for i := 0 to FBackGround.Height - 1 do
  begin
    BackPoint := FBackGround.ScanLine[i];
    ForePoint := FForeGround.ScanLine[i];
    for j := 0 to (3 * FBackGround.Width) - 1 do
      ForePoint[j] := ForePoint[j] + Transparency * (BackPoint[j] - ForePoint[j]) div 100;
  end;
end;

Transparency is measured in percents. The size of FBackGround and FForeGround bitmaps should be the same.

Manipulating a TRadioGroup's Individual Buttons

Problem/Question/Abstract:

Is there a way to manipulate the appearance of the individual buttons in a TRadioGroup?

Answer:

This subject falls into the yeah, it's something you could do, but should you category. In other words, don't do it just because it's possible. Especially because for what I'll be discussing here, this is pretty much undocumented stuff, and purposely hidden from obvious access.

The Delphi engineers hid a lot of stuff from the visible interface for a good reason: Unless you really know what you're doing and understand the workings of Delphi and the VCL components and its object hierarchy, it's better to leave the internal stuff alone. In fact, I'd venture that 98% of the time you won't need to access any of the hidden features of Delphi. But as we all know, it's that remaining 2% that always kills us. I ran into one of those 2% situations recently.

I had created a form that had a few TRadioGroups with up to 20 items in each on it. The selections specified some standard query selection criteria, which my users could then just set with a few clicks of the mouse, press the OK button and the program would produce a formatted report. No possible mistyping, so no worries about entering in wrong information for the criteria-matching. However, one of my users had a problem with the form in that because the radio groups were side-by-side, it was difficult to immediately tell which selection she had made from one group to the next. So she asked me if I could change the appearance of the item she checked.

So what I did was take advantage of the fact that objects that can act as containers all have an array property called Components, which holds the component index of a contained component relative to the container. TRadioGroup is nothing more than a TWinControl descendant (a few levels down) with a collection of TRadioButtons. And conveniently, the radio buttons in the group are indexed with the ItemIndex property, which in turn corresponds to the index of the Components array. So all we have to do to access an individual TRadioButton in a TRadioGroup is to typecast a Components element as a TRadioButton. What I came up with is fairly simple, but remember, this is undocumented stuff.

unit main;

interface

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

type
  TForm1 = class(TForm)
    RadioGroup1: TRadioGroup;
    procedure FormCreate(Sender: TObject);
    procedure RadioGroup1Click(Sender: TObject);
  private
    {Private declarations}
    OldItemIndex: Integer;
  public
    {Public declarations}
  end;

var
  Form1: TForm1;

implementation

{$R *.DFM}

procedure TForm1.FormCreate(Sender: TObject);
begin
  OldItemIndex := -1;
end;

procedure TForm1.RadioGroup1Click(Sender: TObject);
begin
  with RadioGroup1 do
  begin
    {if there was a previously set item, change it back to the default
                appearance first}
    if (OldItemIndex > -1) then
      with (Components[OldItemIndex] as TRadioButton) do
      begin
        Color := clBtnFace;
        Font.Color := clBtnFace;
        Font.Style := [];
      end;
    {Now with the currently selected item, change its appearance}
    with (Components[ItemIndex] as TRadioButton) do
    begin
      Color := clBlue;
      Font.Color := clWhite;
      Font.Style := [fsBold];
      OldItemIndex := ItemIndex;
    end;
  end;
end;

The unit code above depicts a simple form with a single TRadioGroup dropped on it. I filled the group up with about 20 values by hand for testing. Now what goes on is pretty straightforward. I have defined a private variable called OldItemIndex that holds the value of a previously selected item. This is a "just in case" thing in that if users change their mind about a selection, they can go back to the radio group, change the value, and the old item will revert back to its original appearance. The code is listed in the OnClick handler for RadioGroup1 above.

Granted, this was pretty simple. You could do more with the TRadioButton if you wish. In fact, all the properties of TRadioButton are available. But as I said before, this is undocumented material, so use at your own risk, even if it's for a purpose as innocuous as this.

Create a dBase database at runtime

Problem/Question/Abstract:

Create a dBase database at runtime

Answer:

The following procedure may be especially useful for temporary tables:

procedure MakeDataBase;
begin
  with TTable.Create(nil) do
  begin
    DatabaseName := 'c:\temp'; (* alias *)
    TableName := 'test.dbf';
    TableType := ttDBase;
    with FieldDefs do
    begin
      Add('F_NAME', ftString, 20, false);
      Add('L_NAME', ftString, 30, false);
    end;
    CreateTable;
    { create a calculated index }
    with IndexDefs do
    begin
      Clear;
      { don't forget ixExpression in calculated indexes! }
      AddIndex('name', 'Upper(L_NAME)+Upper(F_NAME)', [ixExpression]);
    end;
  end;
end;

Delphi IDE does not generate EXE file

Problem/Question/Abstract:

I compile a Delphi Program within the Delphi IDE and it's not generating the EXE file. This seems like some misconfiguration of the environment but I where?

Answer:

Check the following options:

1) Is there an existing EXE file that cannot be deleted/ overwritten because it is set to read-only or maybe still running? Check the task manager.

I have frequently the following situation in one project:

- I run the freshly compiled EXE from the IDE
- the EXE terminates itself upon an error condition and restarts itself
- I close the newly started instance.

Delphi then cannot overwrite the EXE file even though no instance is running. I have to close and restart Delphi. (Experiencing this with Delphi 3)


2) Maybe the EXE file is put to an unexpected (separate) directory?
Check Project->Options...->Directories/Conditionals->Output Directory.


3) Maybe someone changed the extension for the application from '.EXE' to something else? Under GEM the extension '.APP' was common..
So check Project->Options...->Application->Target File Extension

How to convert a Paradox table to a fixed length ASCII table

Problem/Question/Abstract:

How to convert a Paradox table to a fixed length ASCII table

Answer:

procedure TForm1.Button1Click(Sender: TObject);
var
  t1, t2: TTable; {t1 = PW table; t2 = ASCII version}
begin
  t1 := TTable.create(self);
  with t1 do
  begin
    DataBaseName := 'pw'; { Personal Alias for Paradox Directory }
    tableName := 'customer.db'; { Source Table }
    open;
  end;
  t2 := TTable.create(self);
  with t2 do
  begin
    DataBaseName := 'pw'; { Personal Alias for Paradox Directory }
    tableName := 'asdf.txt';
    TableType := ttASCII;
    createTable;
    open;
    edit;
    BatchMove(t1, batCopy);
    close;
  end;
  t1.close;
end;

How to capture the Windows desktop to a form canvas

Problem/Question/Abstract:

How to capture the Windows desktop to a form canvas

Answer:

procedure TScrnFrm.GrabScreen;
var
  DeskTopDC: HDc;
  DeskTopCanvas: TCanvas;
  DeskTopRect: TRect;
begin
  DeskTopDC := GetWindowDC(GetDeskTopWindow);
  DeskTopCanvas := TCanvas.Create;
  DeskTopCanvas.Handle := DeskTopDC;
  DeskTopRect := Rect(0, 0, Screen.Width, Screen.Height);
  ScrnForm.Canvas.CopyRect(DeskTopRect, DeskTopCanvas, DeskTopRect);
  ReleaseDC(GetDeskTopWindow, DeskTopDC);
end;

Note: You may also have to play around with coordinates, depending on what you want to do. Also, if your form is already loaded and displayed, that is what you you will get, so you may want to do a hide and a show.

How to implement a multi-line caption on a TButton

Problem/Question/Abstract:

How do I make a button have a two line caption? I think there is a character or sequence there to embed a linefeed in the caption property.

Answer:

It is not as simple as adding a #13#10 sequence as a line break in the caption. You also need to add the BS_MULTILINE style. The following sample component will accept a pipe character ("|") in the caption as proxy for a linebreak. This allows you to specify the break in the designer, which does not accept Return as part of the caption string.

unit MLButton;

interface

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

type
  TMultilineButton = class(TButton)
  private
    FMultiline: Boolean;
    function GetCaption: string;
    procedure SetCaption(const Value: string);
    procedure SetMultiline(const Value: Boolean);
  public
    procedure CreateParams(var params: TCreateParams); override;
    constructor Create(aOwner: TComponent); override;
  published
    property Multiline: Boolean read FMultiline write SetMultiline default True;
    property Caption: string read GetCaption write SetCaption;
  end;

procedure Register;

implementation

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

constructor TMultilineButton.Create(aOwner: TComponent);
begin
  inherited;
  FMultiline := True;
end;

procedure TMultilineButton.CreateParams(var params: TCreateParams);
begin
  inherited;
  if FMultiline then
    params.Style := params.Style or BS_MULTILINE;
end;

function TMultilineButton.GetCaption: string;
begin
  Result := Stringreplace(inherited Caption, #13, '|', [rfReplaceAll]);
end;

procedure TMultilineButton.SetCaption(const Value: string);
begin
  if value <> Caption then
  begin
    inherited Caption := Stringreplace(value, '|', #13, [rfReplaceAll]);
    Invalidate;
  end;
end;

procedure TMultilineButton.SetMultiline(const Value: Boolean);
begin
  if FMultiline <> Value then
  begin
    FMultiline := Value;
    RecreateWnd;
  end;
end;

end.