Open a WORD-document and replace Bookmarks with given Values

Problem/Question/Abstract:

An Example how to Open a WORD-Document and replace the bookmarks inside of it.

Answer:

here I try to give a detailed Example how to Open an existing WORD-document from the background of an application an replace bookmarks in this document with given text.

Global declarations:

TDocKapselWORD = class(TDocKapsel)
private
  OleWord: OLEVariant;
public
  function DocClose: Integer;
  function DocNew(VorlagenFilename: string): Integer;
  function ReplaceTM(TM_Name, Ergebnis: string): Integer;
  procedure Test;
end;

function TDocKapselWORD.DocNew(TemplateFilename: string): Integer;
// Opens the connection to WORD
// Returns 0 when ok, -1 on Error
var
  LocalWordDoc: OLEVariant;
  rtnCode: integer;
begin
  rtnCode := 0;
  // Is OLEWord still open? When yes, -> Error
  if VarIsEmpty(OLEWord) = FALSE then
    rtnCode := -1
  else
  begin
    try
      LocalWordDoc := CreateOleObject('WORD.Document');
    except
      // OLE-connection not successful
      rtnCode := -1;
    end;
    if rtnCode >= 0 then
    begin
      // New Document with given template
      LocalWordDoc.Application.Documents.Add(TemplateFilename);
      // Put new document in private variable
      OLEWord := LocalWordDoc.Application.ActiveDocument;
      LocalWordDoc.close();
      // Everything gone ok?
      if OLEWord.Application.Documents.Count > 0 then
        rtnCode := 0
      else
        RtnCode := -1;
    end;
  end;
  DocNew := rtnCode;
end;

function TDocKapselWORD.ReplaceTM(TM_Name, Ergebnis: string): Integer;
// Replaces Bookmark TM_Name with String Ergebnis
// returns 0 when ok, -1 on error.
begin
  if OLEWord.Bookmarks.exists(TM_Name) then
  begin
    OLEWord.Bookmarks.Item(TM_Name).Range.Text := Ergebnis;
    if OLEWord.Bookmarks.exists(TM_Name) then
      result := -1
    else
      result := 0
  end
  else
    result := -1;
end;

function TDocKapselWORD.DocClose: Integer;
// Closes Document and OLE-connection
// Returns 0 when ok, -1 on Error
var
  rtnCode: integer;
begin
  result := -1;
  if not VarIsEmpty(OleWord) then
  try
    OleWord.close();
    OleWord := unassigned;
    if VarIsEmpty(OleWord) then
      result := 0
    else
      result := -1;
  except
    OleWord := unassigned;
    result := -1;
  end;
end;

procedure TDocKapselWord.test;
var
  BMCount, BM: integer;
  MyBookmarks: array[1..42] of string;
  MyTexts: array[1..42] of string;
  rtnCode: integer
begin
  rtnCode := DocNew('TestFile.DOT');
  if rtnCode = 0 then
  begin // Go on only when Opened
    ...
      // Here You need to initialize the bookmarks: how many, what text to which
    // bookmark and so on. I suppose here, it's in two arrays!
    ...
      BM := 1
      repeat
      rtnCode := ReplaceTM(bookmarks[BM], texts[BM]);
      BM := BM + 1;
    until (BM > 42) or (rtnCode < 0);
    ...
      // Some Processing afterwards, perhaps print or save
    ...
      rtnCode := DocClose;
  end;
  ...
    // Some Processing, when it was or was not successful
  ...
end;

Stack Overflow error

Problem/Question/Abstract:

I was filling a Tree view from a huge number of hierarchical records. Inorder to keep them in hierarchy, I used
a recursive function. But after filling about 90%, a "Stack overflow" error occurred. How can I complete the operation.

Answer:

In Delphi, we can use the directive MAXSTACKSIZE to alter the Stack size.  Setting it to a large value causes more memory to be allocated in the stack

Eg:

{Include the following statement in your program}
{$MAXSTACKSIZE 999999}

Place text in the header or footer of a Word document

Problem/Question/Abstract:

Can someone tell me how to set the text in footers of MS Word documents programmatically from inside D5? I can create and open the document. I think it has to do with the BuiltInDocumentProperties. However, I cannot find a property for the document footer. Any ideas?

Answer:

Solve 1:

You can't access the header/ footer via BuiltInDocumentProperties. Use this instead:

Footer:

{ ... }
aDoc := WordApp.Documents.Add(EmptyParam, EmptyParam);
aDoc.Sections.Item(1).Footers.Item(wdHeaderFooterPrimary).Range.Text :=
  'This is a footer';
{ ... }

Header:

{ ... }
aDoc := WordApp.Documents.Add(EmptyParam, EmptyParam);
aDoc.Sections.Item(1).Headers.Item(wdHeaderFooterPrimary).Range.Text :=
  'This is a header';
{ ... }


Solve 2:

This works with Word 2000, and I can't remember it having changed since Word 97, anyway. If Doc is your Word document:

{ ... }
var
  Hdr: HeaderFooter;
  { ... }
  Hdr := Doc.Sections.Item(1).Headers.Item(wdHeaderFooterPrimary);
  Hdr.Range.Text := 'This is a header';
  { ... }

how to delete temporary Internet Files

Problem/Question/Abstract:

How to delete Temporary Internet files.

Answer:

uses
WinInet;

procedure DeleteIECache;
var
lpEntryInfo: PInternetCacheEntryInfo;
hCacheDir: LongWord;
dwEntrySize: LongWord;
begin
dwEntrySize := 0;
FindFirstUrlCacheEntry(nil, TInternetCacheEntryInfo(nil^), dwEntrySize);
GetMem(lpEntryInfo, dwEntrySize);
if dwEntrySize > 0 then lpEntryInfo^.dwStructSize := dwEntrySize;
hCacheDir := FindFirstUrlCacheEntry(nil, lpEntryInfo^, dwEntrySize);
if hCacheDir <> 0 then
begin
repeat
DeleteUrlCacheEntry(lpEntryInfo^.lpszSourceUrlName);
FreeMem(lpEntryInfo, dwEntrySize);
dwEntrySize := 0;
FindNextUrlCacheEntry(hCacheDir, TInternetCacheEntryInfo(nil^), dwEntrySize);
GetMem(lpEntryInfo, dwEntrySize);
if dwEntrySize > 0 then lpEntryInfo^.dwStructSize := dwEntrySize;
until not FindNextUrlCacheEntry(hCacheDir, lpEntryInfo^, dwEntrySize);
end;
FreeMem(lpEntryInfo, dwEntrySize);
FindCloseUrlCache(hCacheDir);
end;


// Beispiel:
// Example:
procedure TForm1.Button1Click(Sender: TObject);
begin
DeleteIECache;
end;

Extract FileName from Url

Problem/Question/Abstract:

How can I extract a FileName from a URL?  For example http://www.domain.com/file.zip -> file.zip

Answer:

Solve 1:

function ExtractUrlFileName(const AUrl: string): string;
var
I: Integer;
begin
I := LastDelimiter('\:/', AUrl);
Result := Copy(AUrl, I + 1, MaxInt);
end;


Solve 2:

You will just have to parse the string manually, ie:

Filename := '../../afolder/anotherfolder/aFilename.ext';
Pos := LastDelimiter('/\', Filename);
if (Pos > 0) then
Filename := Copy(Pos + 1, Length(Filename) - Pos, Filename);


Solve 3:

Filename := '../../afolder/anotherfolder/aFilename.ext';
Filename := StringReplace(Filename, '/', '\', [rfReplaceAll]);
Filename := ExtractFileName(Filename);


Solve 4:

You can treat a string as an array of characters and index individual characters in it with array notation. That allows you to write a loop that checks characters starting from the end of the string and walking backwards. Once you find the start of the filename you can use the Copy function to isolate it.

function GetFilenameFromUrl(const url: string): string;
var
i: Integer;
begin
Result := EmptyStr; // be a realist, assume failure
i := Length(url);
while (i > 0) and (url[i] <> '.') do
dec(i);

if i = 0 then
Exit; // no filename separator found

if AnsiCompareText(Copy(url, i, maxint), '.exe') <> 0 then
Exit; // no .exe at end of url

// find next '.' before current position
dec(i);
while (i > 0) and (url[i] <> '.') do
dec(i);

if i = 0 then
Exit; // no filename separator found
Result := Copy(url, i + 1, maxint);
end;

Give a listbox a rounded border

Problem/Question/Abstract:

How to give a listbox a rounded border

Answer:

To round a ListBox use CreateRoundRectRgn to shape it. Reduce the client size to reposition back in place. Experiment with the rounding value. The greater the round value the smoother it is.

Add a TListBox to a form

procedure TForm1.RoundListbox(var TheList: TListbox);
const
schange = 5;
rnd = 20;
var
thergn: HRGN;
mclient: TRect;
begin
mclient := TheList.ClientRect; {get size}
thergn := CreateRoundRectRgn(mclient.Left, mclient.top, mclient.right,
mclient.bottom, rnd, rnd);
TheList.BorderStyle := bsNone;
InflateRect(mclient, -schange, -schange); {shrink}
TheList.Perform(EM_SETRECTNP, 0, lparam(@mclient)); {change}
SetWindowRgn(TheList.Handle, thergn, true);
end;

Minimize an application by pressing [ALT] [TAB]

Problem/Question/Abstract:

I would like to be able to minimize my application if the user presses [ALT] + [TAB]. Will I need to hook the keyboard for this? There is lot of code around to disable [ALT] [TAB] but nothing to detect it.

Answer:

This works on WinNT SP3+, Win2K and WinXP:

{ ... }
var
FHook: HHook = 0;

const
WH_KEYBOARD_LL = 13;
LLKHF_ALTDOWN = KF_ALTDOWN shr 8;

type
tagKBDLLHOOKSTRUCT = packed record
vkCode: DWord;
scanCode: DWord;
flags: DWord;
time: DWord;
dwExtraInfo: PDWord;
end;
TKBDLLHOOKSTRUCT = tagKBDLLHOOKSTRUCT;
PKBDLLHOOKSTRUCT = ^TKBDLLHOOKSTRUCT;
{ ... }

function LowLevelKeyboardProc(HookCode: Longint; MessageParam: WParam;
StructParam: LParam): DWord; stdcall;
var
SwitchingTask: Boolean;
P: PKBDLLHOOKSTRUCT;
begin
SwitchingTask := False;
if (HookCode = HC_ACTION) then
case (MessageParam) of
WM_KEYDOWN, WM_SYSKEYDOWN, WM_KEYUP, WM_SYSKEYUP:
begin
P := PKBDLLHOOKSTRUCT(StructParam);
SwitchingTask := ((P.VKCode = VK_TAB) and (P.Flags and LLKHF_ALTDOWN <> 0))
or
((P.VKCode = VK_ESCAPE) and ((P.Flags and LLKHF_ALTDOWN) <> 0)) or
((P.VKCode = VK_ESCAPE) and ((GetKeyState(VK_CONTROL)
and $8000) <> 0));
end;
end;
if SwitchingTask then
begin
{If you want to disable task switch just uncomment next two lines}
// Result := 1;
// Exit;
{If not, put your code here...}
Application.Minimize;
end;
Result := CallNextHookEx(0, HookCode, MessageParam, StructParam);
end;

procedure SetHook;
begin
FHook := SetWindowsHookEx(WH_KEYBOARD_LL, @LowLevelKeyboardProc, Hinstance, 0);
end;

procedure UnHook;
begin
if FHook > 0 then
UnHookWindowsHookEx(FHook);
end;

procedure TMainForm.FormCreate(Sender: TObject);
begin
SetHook;
end;

procedure TMainForm.FormDestroy(Sender: TObject);
begin
UnHook;
end;

Connecting to Firebird DB

Problem/Question/Abstract:

How do i connect to a remote firebird database server?

Answer:

Firebird/Interbase Databases
A Firebird database is a single file - normally either *.fdb or *.gdb - all the tables are stored in that file.
To create a new alias, follow the instructions above, select the INTRBASE driver, and set the following parameters.

Property  Value  Comments
Server Name     This is the fully qualified *.fdb or *.gdb file
User Name  SYSDBA  For employee.gdb, the default password is masterkey

Warning:  If the focus is in an Opened Interbase/Firebird table when Object / New... is selected, it is possible that you will create a new table or a new field instead of a new alias.

To connect to a remote firebird server, you MUST include the drive letter after the computer name.

CompName:C:\Program Files\Common Files\Borland Shared\Data\employee.gdb

The Interbase help says that the following format is also acceptable in ISQL - but it definitely does NOT work in the Database Explore.
\\CompName\C:\Program Files\Common Files\Borland Shared\Data\employee.gdb

Firebird is the open source version of Borland's Interbase database server.

.

Write multiple values to a bookmark in Word

Problem/Question/Abstract:

How can I add rows at the end of a wordtable even when I have vertically merged cells? I always receive the error message "cannot access individual rows in this collection because the table has vertically merged cells"! The recorded word macro simple add a row by "selection.insertrows 1", but I have problems converting this into a Delphi statement (defining the right selection etc.).

Answer:

I've been automating MS Word, using bookmarks. Sometimes I need to write multiple values to one bookmark. I pass the values to the following routine as comma-text in the AValue parameter. It works fine with D5 using the Word97 unit and MS Word 2000 executable. Hope it helps.

{ ... }
FMSWord := CreateComObject(CLASS_WordApplication) as WordApplication;
{ ... }

procedure TLTWordDocHandler.PopulateListBookMark(const ABookMarkName:
  string; const AValue: Widestring);
var
  i: integer;
  LBMName: OleVariant;
  MoveUnit: OleVariant;
  NumRows: OleVariant;
  WorkingList: TStringList;
begin
  LBMName := ABookMarkName;
  FMSWord.ActiveDocument.Bookmarks.Item(LBMName).Select;
  if FMSWord.Selection.Tables.Count = 0 then
    raise Exception.Create(Format(sBookmarkNotInTable, [ABookmarkName]));
  MoveUnit := wdCell;
  NumRows := 1;
  WorkingList := TStringList.Create;
  try
    WorkingList.CommaText := AValue;
    for i := 0 to WorkingList.Count - 1 do
    begin
      FMSWord.Selection.TypeText(WorkingList.Strings[i]);
      if not (i = (WorkingList.Count - 1)) then
        FMSWord.Selection.MoveRight(MoveUnit, EmptyParam, EmptyParam);
          {97 & 2000 compliant}
    end;
  finally
    FreeAndNil(WorkingList);
  end;
end;

Web Pages about developing Winhelp and HTML help files

Problem/Question/Abstract:

Web Pages about developing Winhelp and HTML help files

Answer:

Helpmaster
Web site with lots of Winhelp/ HTML Help related information and links

Helpware Home Page
A web site focussing on HTML help

HTML Help Center
Samples, source code and tools for working with HTML Help

MSDN Online Library
Official Microsoft page with extensive information on HTML help

Richard Hendricks' Windows Help File Authoring Web Site
Many links to WinHelp and HTML Help related sources

VizAcc
Home of Help Jotter - a commercial WYSIWYG Windows help authoring tool creating all types of help files and printed manuals from the same data

Winhelp.net
Tips and information about developing Winhelp and HTML help files

WinWriters
Winhelp/ HTML Help related links and online help journal

Speed up some queries on my Microsoft SQL Server

Problem/Question/Abstract:

What can I do to speed up some queries on my Microsoft SQL Server?

Answer:

I have found that queries like:

select * from table1 innerjoin table2 on table1.field=table2.field

...sometimes will query quickly, but takes time to return a result.

The solution I have found to work is to insert the first query to a temporary table, then query the second, like:


select * into #temptable from table1 innerjoin table2 on table1.field=table2.field

select * from #temptable


The "#temptable" can be anything starting with the pound sign.  The temporary table will be released when your connection is closed.

I have found what I think is the answer here-- table locking.
When I query active tables, I fight with other applications having locks on various rows and tables.  When the query takes part into a temporary table, the lock is not there.

This article then has a really silly premise, I concur.

What should be used rather than temporary tables in a select statement is the "with (nolock)" feature that does a dirty read. Like:

select * from BigTable with (nolock)

rather than:
select * into #tempTable from BigTable

Format Float with Comma

Problem/Question/Abstract:

Format Float with Comma

Answer:

function FormatNum(Value: Extended; Decimal: Integer): string;
var
  SLen, SPos: Integer;
  SVal: string;
begin
  Str(Value: 0: Decimal, SVal);
  SLen := Length(SVal);
  if Decimal = 0 then
    SPos := SLen - 2
  else
    SPos := SLen - (Decimal + 3);
  while SPos > 1 do
  begin
    Insert(',', SVal, SPos);
    SPos := SPos - 3;
  end;
  Result := SVal;
end;

Also, you can simply do this:

i: Extended;
s: string;

i := 1000.123456;
s := Format('%.2n', [i]);

The value of s will be 1,000.12

You can also add your own characters, so you could do something like this:

s := Format('$%.2n', [i]);

This would output $1,000.12

So, good luck in your number to string formatting.

Next Position of a sub-string in a string

Problem/Question/Abstract:

The Pos funciton of Delphi returns the first occurence of a sub string within a string, only. How to get the positions of the next occurences?

Answer:

Solve 1:

This solution was developed using Borland Delphi 5 Service Pack 1. It is based upon the Pos algorithm delivered by Borland within the Systems unit, completely written in Assembler. !!!It might work with other versions of Borland Delphi (3.x, 4.x, 5.0) but has not been tested on them!!!

The syntax is similar to the syntax of the Pos function supplied by Delphi:

function NextPos(Substr: string; S: string; LastPos: DWORD = 0): DWORD;

NextPos returns the index value of the first character in a specified substring that occurs in a given string starting after the index value supplied by LastPos. LastPos may be omitted.

Note: As LastPos you should pass the position of the last occurence, not last position + 1. Just for convinience.

Here the commented Code:

function NextPos(SubStr: AnsiString; Str: AnsiString; LastPos: DWORD
  = 0): DWORD;
type
  StrRec = packed record
    allocSiz: Longint;
    refCnt: Longint;
    length: Longint;
  end;
const
  skew = sizeof(StrRec);

  asm
  // Search-String passed?
  TEST    EAX,EAX
  JE      @@noWork

  // Sub-String passed?
  TEST    EDX,EDX
  JE      @@stringEmpty

   // Save registers affected
PUSH ECX
PUSH EBX
PUSH ESI
PUSH EDI

// Load Sub-String pointer
MOV ESI, EAX
// Load Search-String pointer
MOV EDI, EDX
// Save Last Position in EBX
MOV EBX, ECX
// Get Search-String Length
MOV ECX, [EDI - skew].StrRec.length
// subtract Start Position
SUB ECX, EBX
// Save Start Position of Search String to return
PUSH EDI
// Adjust Start Position of Search String
ADD EDI, EBX
// Get Sub-String Length
MOV EDX, [ESI - skew].StrRec.length
// Adjust
DEC EDX
// Failed if Sub-String Length was zero
JS@@fail
// Pull first character of Sub-String for SCASB function
MOV AL, [ESI]
// Point to second character for CMPSB function
INC ESI
// Load character count to be scanned
SUB ECX, EDX
// Failed if Sub-String was equal or longer than Search-String
JLE@@fail
@@loop:
// Scan for first matching character
REPNE SCASB
// Failed, if none are matching
JNE@@fail
// Save counter
MOV EBX, ECX
PUSH ESI
PUSH EDI
// load Sub-String length
MOV ECX, EDX
// compare all bytes until one is not equal
REPE CMPSB
// restore counter
POP EDI
POP ESI
// all byte were equal, search is completed
JE@@found
// restore counter
MOV ECX, EBX
// continue search
JMP@@loop
@@fail:
// saved pointer is not needed
POP EDX
xor EAX, EAX
JMP@@exit
@@stringEmpty:
// return zero - no match
xor EAX, EAX
JMP@@noWork
@@found:
// restore pointer to start position of Search-String
POP EDX
// load position of match
MOV EAX, EDI
// difference between position and start in memory is
//   position of Sub
SUB EAX, EDX
@@exit:
// restore registers
POP EDI
POP ESI
POP EBX
POP ECX
@@noWork:
end;


Solve 2:

PosEx function:

function PosEx(SubStr: string; s: string; Index: DWord): DWord;
var
  I: Integer;
begin
  I := Pos(SubStr, Copy(s, Index, Length(s) - Index + 1));
  if I <> 0 then
    I := I + Index - 1;
  Result := I;
end;

The prarameter Index is the position you want to begin to search substr in s.

How to scroll a TTreeView?

Problem/Question/Abstract:

How to scroll a TTreeView?

Answer:

procedure TForm1.FormMouseWheelUp(Sender: TObject;
  Shift: TShiftState;
  MousePos: TPoint;
  var Handled: Boolean);

var
  iPos: Integer;

begin
  iPos := GetScrollPos(Form1.TreeView1.Handle, SB_VERT);
  SetScrollPos(Form1.TreeView1.Handle, SB_VERT, iPos - 1, True);
  // Don't set Handled to True otherwise the scrollbar scrolls
  // but the content of the TreeView does NOT scroll!
  // I have not found a way to check if the TreeView has a scrollbar or not.
  // Maybe if you first call:
  // GetScrollRange(Form1.TreeView1.Handle, SB_VERT,lpMinPos,lpMaxPos);
  // and then:
  // if MaxPos = 0 and MinPos = 0 then there is no vertical scrollbar
  // if MaxPos <> 0 then there is a vertical scrollbar
end;

Draw the caption of a TForm programmatically

Problem/Question/Abstract:

I need to be able to draw the text in a TForm's caption area manually, without using WM_SETTEXT (setting the TForm's Caption property, or using the API call SetWindowText, both use this method so they are unsuitable). I need functionality similar to DrawText where the text is drawn directly rather than sent to a message handler. Can anyone help?

Answer:

unit Unit1;

interface

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

type
  TForm1 = class(TForm)
    procedure WMPaint(var Message: TWMPaint); message WM_PAINT;
    procedure FormShow(Sender: TObject);
  private
    { Private declarations }
  public
    { Public declarations }
  end;

var
  Form1: TForm1;

implementation

{$R *.DFM}

procedure WriteTexttoDC(WinHandle: HWND; Text: string; X, Y: Integer);
var
  DC: HDC;
begin
  DC := GetWindowDC(WinHandle);
  ExtTextOut(DC, 1, 1, ETO_CLIPPED, nil, PChar(Text), Length(Text), nil);
  ReleaseDC(WinHandle, DC);
end;

procedure TForm1.WMPaint(var Message: TWMPaint);
begin
  WriteTexttoDC(Handle, 'Is it OK?', 5, 5);
end;

procedure TForm1.FormShow(Sender: TObject);
begin
  WriteTexttoDC(Handle, 'Is it OK?', 5, 5);
end;

end.

How to create a Paradox table with an AutoInc field at runtime

Problem/Question/Abstract:

How do I create a Paradox table with an Auto Increment type field programmatically? I'm using TTable.CreateTable, but TFieldType doesn't include this type.

Answer:

Use a TQuery and SQL CREATE TABLE statement. For example:

procedure TForm1.Button1Click(Sender: TObject);
begin
  with Query1 do
  begin
    DatabaseName := 'DBDemos';
    with SQL do
    begin
      Clear;
      Add('CREATE TABLE "PDoxTbl.db" (ID AUTOINC,');
      Add('Name CHAR(255),');
      Add('PRIMARY KEY(ID))');
      ExecSQL;
      Clear;
      Add('CREATE INDEX ByName ON "PDoxTbl.db" (Name)');
      ExecSQL;
    end;
  end;
end;

Remote Execute Function (Unix REXEC)

Problem/Question/Abstract:

Remote Execute Function (Unix REXEC)

Answer:

This function will execute a command to a Unix box (or any TCP connection that supports REXEC - port 512) and return the display results in a file. I currently use it on HP and SUN systems.

The parameters to RExec() are

  HostIP                                 : string               // eg. '196.11.121.160'          
  UserID                                 : string               // eg. 'root'
  Password                         : string                          // eg. 'fraqu34'
  Command                         : string                          // eg. 'export TERM=vt100; dv'
  ResultFilename         : string                           // eg. 'c:\temp\uxresult.txt'

The function returns true if sucessful, else false.

The command may contain multiple statements separated by semi-colons. REMEMBER : REXEC does not run the user .profile, so NO user environments are set. You can export  any environment settings in this parameter.

eg. 'export TERM=vt100; export APP=baan; run_mycommand'

An example of use is ....
(change to directory /var and return a dir listing and return results in file c:\temp\ux.txt)

procedure TForm1.Button1Click(Sender: TObject);
begin
  RExec('196.11.121.162',
    'root', 'passwd342',
    'cd /var; ls -1',
    'c:\temp\ux.txt');

  Memo1.Lines.LoadFromFile('c:\temp\ux.txt');
end;


uses ScktComp;

function RExec(const HostIP: string; const UserID: string;
  const Password: string; const Command: string;
  const ResultFilename: string): boolean;
var
  TCP: TClientSocket;
  i: integer;
  TxOut: file;
  Buffer, Cr, Lf: byte;
  Failed: boolean;
begin
  Failed := true; // Assume initial error state
  Cr := 13; // Carriage Return Char
  Lf := 10; // Line Feed Char
  TCP := TClientSocket.Create(nil);

  try
    TCP.Address := HostIP;
    TCP.ClientType := ctBlocking;
    TCP.Port := 512; // REXEC port
    TCP.Open;

    // Give time to connect
    for i := 1 to 500 do
      if not TCP.Active then
        Sleep(100)
      else
        break;

    // If TCP opened OK then send the command to host
    // and write results to specified file
    if TCP.Active then
    begin
      AssignFile(TxOut, ResultFileName);
      Rewrite(TxOut, 1);
      TCP.Socket.SendText('0' + #0);
      TCP.Socket.SendText(UserID + #0);
      TCP.Socket.SendText(Password + #0);
      TCP.Socket.SendText(Command + #0);
      TCP.Socket.SendText(#13);
      Sleep(20); // Give a gap to respond

      // Wait for resonse from Host
      // You may want to check for timeout here using
      // a TTimer. My complete function does this, but
      // have omitted for sake of clarity.
      while (TCP.Socket.ReceiveBuf(Buffer, 1) <> 1) do
        Application.ProcessMessages;

      // Write host byte stream to file
      while TCP.Socket.ReceiveBuf(Buffer, 1) = 1 do
      begin
        if (Buffer = 10) then
        begin
          BlockWrite(TxOut, Cr, 1);
          BlockWrite(TxOut, Lf, 1);
        end
        else
          BlockWrite(TxOut, Buffer, 1);
      end;

      TCP.Close;
      CloseFile(TxOut);
      Failed := false;
    end;
  finally
    TCP.Free;
  end;

  Result := not Failed;
end;

Play WAV files

Problem/Question/Abstract:

Play WAV files

Answer:

You can use the mci commands (easy using the mciSendString() routine) or - even easier, this:

uses
  MMSystem;

var
  s: array[0..79] of char;
begin
  StrCopy(s, 'ding.wav');
  sndPlaySound(s, 0);
end;

Get the server (router) and client IP address of your dial up connection

Problem/Question/Abstract:

There are quite a lot of articles on retrieving IP addresses for LAN interfaces. Here's one for dialup using RAS(Remote Access Services). Note that it requires header files which are available from Delphi JEDI site

Answer:

Please note that the program uses ras.pas and other header files which are available in the API library of delphi jedi site. The complete project having all the header files is being provided to the webmaster for update.

It displays the server and client IP every second on a label.

unit uMain;

interface

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

type
  TfrmMain = class(TForm)
    lblIP: TLabel;
    tmrUpdate: TTimer;
    procedure tmrUpdateTimer(Sender: TObject);
  private
    { Private declarations }
  public
    { Public declarations }
  end;

var
  frmMain: TfrmMain;

implementation

uses Ras, RasError;

{$R *.DFM}

procedure GetDialUpIpAddress(var server, client: string);
var
  RASPppIp: RASIP;
  lpcp: DWORD;
  ConnClientIP: array[0..RAS_MaxIpAddress] of Char;
  ConnServerIP: array[0..RAS_MaxIpAddress] of Char;

  Entries: PRasConn;
  BufSize, NumberOfEntries, Res: DWORD;
  RasConnHandle: THRasConn;
begin
  New(Entries);
  BufSize := Sizeof(Entries^);
  ZeroMemory(Entries, BufSize);
  Entries^.dwSize := Sizeof(Entries^);

  Res := RasEnumConnections(Entries, BufSize, NumberOfEntries);
  if Res = ERROR_BUFFER_TOO_SMALL then
  begin
    ReallocMem(Entries, BufSize);
    ZeroMemory(Entries, BufSize);
    Entries^.dwSize := Sizeof(Entries^);
    Res := RasEnumConnections(Entries, BufSize, NumberOfEntries);
  end;
  try
    if (Res = 0) and (NumberOfEntries > 0) then
      RasConnHandle := Entries.hrasconn
    else
      exit
  finally
    FreeMem(Entries);
  end;

  FillChar(RASPppIp, SizeOf(tagRASIP), 0);
  RASPppIp.dwSize := SizeOf(tagRASIP);
  lpcp := RASPppIp.dwSize;
  if RasGetProjectionInfo(RasConnHandle,
    RASP_PppIp, @RasPppIp, lpcp) = 0 then
  begin

    Move(RASPppIp.szServerIpAddress,
      ConnServerIP,
      SizeOf(ConnServerIP));
    Server := ConnServerIP;
    Move(RASPppIp.szIpAddress,
      ConnClientIP,
      SizeOf(ConnClientIP));
    client := ConnClientIP;
  end;
end;

procedure TfrmMain.tmrUpdateTimer(Sender: TObject);
var
  ConnServerIP, ConnClientIP: string;
begin
  GetDialUpIpAddress(ConnServerIP, ConnClientIP);
  if ConnServerIP = '' then
    ConnServerIP := 'NA';
  if ConnClientIP = '' then
    ConnClientIP := 'NA';
  lblIP.Caption := Format('Server : %s'#13#10'Client   : %s', [ConnServerIP,
    ConnClientIP])
end;

Viewing PCX File Format in Delphi (256-colors)

Problem/Question/Abstract:

How to show bitmap in pcx file format using Delphi ??

Answer:

This is quite simple way to answer above question: viewing pcx file format using Delphi. But this answer is limited only for 256-colors image (pcx image).

Here is the example code for the answer :

type
  TArrBuff = array[1..512] of Byte;
  TPalette_Cell = record
    r, g, b: byte;
  end;
  TPal = array[0..255] of TPalette_Cell;
  TPPal = ^TPal;

  TPCX_Header = record // PCX Header
    Manufacture, Version, Encoding, BpPixel: Byte;
    XMin, YMin, XMax, YMax, Hdpi, Vdpi: Smallint;
    ColorMap: array[0..15, 0..2] of Byte;
    Reserved, Nplanes: Byte;
    BpLpPlane, PaletteInfo, HScreenSize, VScreenSize: Smallint;
    Filer: array[74..127] of Byte;
  end;

var
  pal: TPPal;
  pFile: file;
  FPcxHeader: TPCX_Header;
  buffer: TArrBuff;

procedure THPPcx.ReadImageData2Bitmap;
var
  X, Y: Integer;
  i, Loop: Byte;
  data: Word;
  tmpClr: TColor;
begin
  X := FPcxHeader.XMin;
  Y := FPcxHeader.YMin;
  data := 1;
  BlockRead(pFile, Buffer, SizeOf(Buffer));
  while (Y <= FPcxHeader.YMax) do
  begin
    if (Buffer[data] and $C0) = $C0 then
    begin
      Loop := Buffer[data] and $3F;
      if data < SizeOf(Buffer) then
        Inc(data)
      else
      begin
        data := 1;
        BlockRead(pFile, Buffer, SizeOf(Buffer));
      end;
    end
    else
      Loop := 1;
    for i := 1 to Loop do
    begin
      tmpClr := rgb(pal^[Buffer[data]].R, pal^[Buffer[data]].G, pal^[Buffer[data]].B);
      SetPixel(Bitmap.Canvas.Handle, x, y, tmpClr);
      Inc(X);
      if X = FPcxHeader.BpLpPlane then
      begin
        X := FPcxHeader.XMin;
        Inc(Y);
      end;
    end;
    if data < SizeOf(Buffer) then
      Inc(data)
    else
    begin
      data := 1;
      BlockRead(pFile, Buffer, SizeOf(Buffer));
    end;
  end;
end;

procedure THPPCX.LoadFromFile(const FileName: string);
begin
  AssignFile(pFile, FileName);
{$I-}Reset(pFile, 1);
{$I+}
  if IOResult = 0 then
  begin
    BlockRead(pFile, FPcxHeader, SizeOf(FPcxHeader));
    if FPcxHeader.Manufacture = 10 then
    begin // valid pcx header id
      Bitmap.Width := FPcxHeader.XMax;
      Bitmap.Height := FPcxHeader.YMax;
      GetMem(pal, 768);
      try
        Seek(pFile, FileSize(pFile) - 768); // palette position
        BlockRead(pFile, pal^, 768);
        Seek(pFile, SizeOf(FPcxHeader)); // image data position
        ReadImageData2Bitmap;
      finally
        FreeMem(pal);
      end;
    end
    else
      MessageBox(Application.Handle, 'Not A Valid PCX File Format',
        'PCX Viewer Error', MB_ICONHAND);
    CloseFile(pFile);
  end
  else
    MessageBox(Application.Handle, 'Error Opening File', 'PCX Viewer Error',
      MB_ICONHAND);
end;

How to try this code ?? Just call the "LoadFromFile" procedure above in your application (probably with little modification offcourse, especially about the name of mainForm that I used here [THPPCX]).

Hopefully It can help you.

For full source code and simple application that use this, you can look and download from my website: www.geocities.com/h4ryp/delphi.html

How to use an animated cursor to your application

Problem/Question/Abstract:

How to use an animated cursor to your application

Answer:

Using animated cursors in your application is very easy.

Here's an example:

mycursor.ani is an animated cursor file. You can create those with Microsoft's aniedit.exe


const
  crMyCursor = 1;

procedure TForm1.FormCreate(Sender: TObject);
begin
  // Load the cursor. Needs to be done only once
  Screen.Cursors[crMyCursor] := LoadCursorFromFile('c:\mystuff\mycursor.ani');
  // Use the cursor with this form
  Cursor := crMyCursor;
end;

Change the font color of a specific row in a TListView

Problem/Question/Abstract:

How to change the font color of a specific row in a TListView

Answer:

Use the events OnCustomDrawItem and OnCustomDrawSubItem:

procedure TForm1.ListView1CustomDrawItem(Sender: TCustomListView;
  Item: TListItem; State: TCustomDrawState; var DefaultDraw: Boolean);
begin
  if (Item.Index mod 2) = 0 then
    Sender.Canvas.Font.Color := clRed
  else
    Sender.Canvas.Font.Color := clBlack;
end;

Share memory among several instances of a DLL

Problem/Question/Abstract:

Share memory among several instances of a DLL

Answer:

The DB unit in the 32-bit version has some examples of how it's done in general.

Basically, in 32-bit mode a DLL is mapped into each process's address space, not an address space of its own, so that it cannot share memory simply by virtue of being a DLL. You must use some kind of shared memory object -- such as shared memory, or a memory-mapped file -- and employ semaphores to properly synchronize access to it.

Have a window stay on top all the time

Problem/Question/Abstract:

Have a window stay on top all the time

Answer:

The following code results in a window that stays on top all the time, even when the main application form is in the background:


Minitool := TMinitool.Create(Self);
Application.NormalizeTopMosts;
SetWindowPos(Minitool.Handle, HWND_TOPMOST, 0, 0, 0, 0,
  SWP_NOACTIVATE + SWP_NOMOVE + SWP_NOSIZE);
Minitool.Show;

How to create an array of buttons at runtime

Problem/Question/Abstract:

How to create an array of buttons at runtime

Answer:

Here is a unit that creates a row of buttons and a label at run time and displays which button is clicked on. All you need to do is start a new project, then paste all the code below into Unit1.

unit Unit1;

interface

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

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

var
  Form1: TForm1;

implementation

{$R *.DFM}

const
  b = 4; {Total number of buttons to create}

var
  ButtonArray: array[0..b - 1] of TButton; {Set up an array of buttons}
  MessageBox: TLabel;

procedure TForm1.FormCreate(Sender: TObject);
var
  loop: integer;
begin
  {Size the form to fit all the components in}
  ClientWidth := (b * 60) + 10;
  ClientHeight := 65;
  MessageBox := TLabel.Create(Self); {Create a label...}
  MessageBox.Parent := Self;
  MessageBox.Align := alTop; {...set up it's properties...}
  MessageBox.Alignment := taCenter;
  MessageBox.Caption := 'Press a Button';
  for loop := 0 to b - 1 do {Now create all the buttons}
  begin
    ButtonArray[loop] := TButton.Create(Self);
    with ButtonArray[loop] do
    begin
      Parent := self;
      Caption := IntToStr(loop);
      Width := 50;
      Height := 25;
      Top := 30;
      Left := (loop * 60) + 10;
      Tag := loop; {Used to tell which button is pressed}
      OnClick := ButtonClick;
    end;
  end;
end;

procedure TForm1.ButtonClick(Sender: TObject);
var
  t: Integer;
begin
  t := (Sender as TButton).Tag; {Get the button number}
  MessageBox.Caption := ' You pressed Button ' + IntToStr(t);
end;

end.

Implement tooltips in a TListView

Problem/Question/Abstract:

Is there a possibility to get tooltips in a common TListView component under Delphi 4.0? I want to display details if the user moves the mouse over an item and wait a little (same function like the component names in Delphi, if you move your mouse over a component).

Answer:

There is an event handler in Delphi 5, which makes it possible for you to get tooltips for each item of a ListView easily: TListView.OnInfoTip. In Delphi 3 and 4, you have to write your own hint event handler, which you assign to the method OnShowHint of TApplication:

unit Test_u1;
{ ... }

type
  TForm1 = class(TForm)
    ListView1: TListView;
    { ... }
  private
    procedure DisplayHint(var HintStr: string; var CanShow: Boolean; var HintInfo:
      THintInfo);
  end;

  { ... }

implementation

{$R *.DFM}

procedure TForm1.FormCreate(Sender: TObject);
var
  NewItem: TListItem;
begin
  Application.OnShowHint := DisplayHint;
  { ... }
end;

procedure TForm1.DisplayHint;
var
  Item: TListItem;
  Rect: TRect;
begin
  CanShow := true;
  {Trace the item of ListView1, which is found on the mouse position X, Y.
        If the mouse isn't dragged over a item, result will be nil.}
  Item := ListView1.GetItemAt(HintInfo.CursorPos.X, HintInfo.CursorPos.Y);
  if Item <> nil then
  begin
    Rect := Item.DisplayRect(drBounds); {in coordinates of ListView1!}
    HintInfo.HintStr := 'Mouse is over Item ' + Item.Caption;
  end
  else
  begin
    Rect := ActiveControl.ClientRect;
    HintInfo.HintStr := GetShortHint(TControl(ActiveControl).Hint);
  end;
  { Converting into coordinates of screen. }
  Rect.TopLeft := ActiveControl.ClientToScreen(Rect.TopLeft);
  Rect.BottomRight := ActiveControl.ClientToScreen(Rect.BottomRight);
  with HintInfo do
  begin
    HintPos.Y := Rect.Top + GetSystemMetrics(SM_CYCURSOR);
    HintPos.X := Rect.Left + GetSystemMetrics(SM_CXCURSOR);
    HintMaxWidth := TControl(ActiveControl).ClientWidth;
    HintColor := clInfoBk;
    ReshowTimeout := 10;
    HideTimeout := 100;
  end;
end;

end.

BTW: The type THintInfo is used to define the appearance and the function of the HintWindow:

type
  THintWindowClass = class of THintWindow;

  THintInfo = record
    HintControl: TControl;
    HintWindowClass: THintWindowClass;
    HintPos: TPoint;
    HintMaxWidth: Integer;
    HintColor: TColor;
    CursorRect: TRect;
    CursorPos: TPoint;
    ReshowTimeout: Integer;
    HideTimeout: Integer;
    HintStr: string;
    HintData: Pointer;
  end;

How to flip the characters in a string

Problem/Question/Abstract:

How to flip the characters in a string

Answer:

If you want to take "Hello" and make it "olleH" then use the following:

procedure Flip(A: string);
var
  t: Integer;
begin
  Result := '';
  for t := Length(A) downto 1 do
    Result := Result + A[t];
end;

If you want to take "abcd" and make it "zyxw" then use the following:

procedure Flip(A: string);
var
  t: Integer;
begin
  Result := '';
  A := Uppercase(A); {develop others for lower case}
  for t := 1 to Length(A) do
    Result := Result + CHR(91 - (ORD(A[t]) - 65));
end;

Filter operation on a lookup field

Problem/Question/Abstract:

How can I filter on a lookup field in a dataset?

Answer:

You cannot use the lookup field's name in the filter string, but you can use an OnFilterRecord event handler instead.

Recompile a component that is in a package

Problem/Question/Abstract:

Recently I had downloaded an updated freeware component and wanted to recompile the package in which I kept that one. The question was: in which package did I put this component?

Answer:

Choose menu item "Component | Configure Palette" or right click on the component palette and then choose Properties. A dialog with an overview comes up - sort it by component name and see the package name in the second column. Open this package and recompile it.

Adding Explorer ToolBar Btn

Problem/Question/Abstract:

Creating  Explorer ToolBar Button

Answer:

type
  TConnType = (COM_OBJECT, EXPLORER_BAR, SCRIPT, EXECUTABLE);

function AddBandToolbarBtn(Visible: Boolean; ConnType: TConnType;
  BtnText, HotIcon, Icon, GuidOrPath: string): string;
var
  GUID: TGUID;
  Reg: TRegistry;
  ID: string;
begin
  CreateGuid(GUID);
  ID := GuidToString(GUID);
  Reg := TRegistry.Create;
  with Reg do
  try
    RootKey := HKEY_LOCAL_MACHINE;
    OpenKey('\Software\Microsoft\Internet Explorer\Extensions\'
      + ID, True);
    if Visible then
      WriteString('Default Visible', 'Yes')
    else
      WriteString('Default Visible', 'No');
    WriteString('ButtonText', BtnText);
    WriteString('HotIcon', HotIcon);
    WriteString('Icon', Icon);
    case ConnType of
      COM_OBJECT:
        begin
          WriteString('CLSID', '{1FBA04EE-3024-11d2-8F1F-0000F87ABD16}');
          WriteString('ClsidExtension', GuidOrPath);
        end;
      EXPLORER_BAR:
        begin
          WriteString('CLSID', '{E0DD6CAB-2D10-11D2-8F1A-0000F87ABD16}');
          WriteString('BandCLSID', GuidOrPath);
        end;
      EXECUTABLE:
        begin
          WriteString('CLSID', '{1FBA04EE-3024-11D2-8F1F-0000F87ABD16}');
          WriteString('Exec', GuidOrPath);
        end;
      SCRIPT:
        begin
          writeString('CLSID', '{1FBA04EE-3024-11D2-8F1F-0000F87ABD16}');
          WriteString('Script', GuidOrPath);
        end;
    end;
    CloseKey;
    OpenKey('\Software\IE5Tools\ToolBar Buttons\', True);
    WriteString(BtnText, ID);
    CloseKey;
  finally
    Free;
  end;
  Result := ID;
end;

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.