Can I build "Query By Form" applications using Delphi?

Problem/Question/Abstract:

I used Oracle Forms for a long time to build Query By Form applications. I have recently switched to Delphi, and am wondering if it's possible to build Query By Form applications in it.

Answer:

What is Query By Form (QBF)?

First of all, one of the mistakes many people make about QBF is that is a proprietary feature of a some company's development environment. It's not. Think about QBF as an application design methodology or paradigm. Any programming environment in which you can build windows (forms) and in turn can access a database platform has the ability to build a QBF application. Admittedly, some products provide a relatively easy way to implement QBF over others, but if a product meets the two requirements mentioned above, it can do QBF.

For those of you not familiar with the concept, Query By Form is the act of wrapping an intelligent user interface around a query or group of queries that they might normally have to create by hand. By intelligence I don't mean a program that has cognitive abilities; rather, it's one that can translate and process user input by way of a form and provide result data in a reasonable format such as a printed report or a data grid.

In a nutshell, QBF is a way to hide the complexities of data extraction from the user, thus allowing him/her to focus on a specific business problem rather than being distracted by cryptic commands and keystrokes usually associated with query languages such as SQL. And because QBF is by nature business-problem-centric, QBF applications have the added advantage of restricting the user to a specific problem domain. In other words, it is very unlikely that while using a QBF application, the user could ask the wrong questions. This is because the program has only a limited set of questions which are bound by a specific problem domain.

There are a few people out there that disagree with this concept, saying it's inflexible and contending that users want to perform more ad hoc queries of their data to get their answers. In some cases I will agree with this. But I will counter that almost all business problems are defined by very specific sets of protocols and so have clearly defined and expected results. These protocols can in turn be modeled, then transformed into a seamless automation of the protocols.

Ad hoc querying is not only error-prone, but suffers from the danger of introducing unnecessary, extraneous data that could be perceived as meaningful but in actuality is far from it. Not only that, but most analyses require more than one query to achieve an intelligible answer set, usually starting with some initial extraction, then going through various levels of refinement until the appropriate data set is achieved. Users performing queries by ad hoc means may run their refinement queries out of sequence, or even miss some intermediate steps altogether.

Enter Delphi

Now let's look at how we can implement QBF. The concept of QBF can be applied in numerous ways in Delphi, so I'm not going to talk to much about specific cases of coding. However, I will talk about certain techniques I've used in Delphi when creating QBF applications.

Delphi is an ideal tool for doing QBF for a number of compelling reasons. Among them are:

Delphi applications are built with a form or window design paradigm. Every new project you start has a form and an associated unit that's created along with the project. This puts the developer in the interface design state right away. That's what QBF is all about: building a form to be the interface to your data extraction.
Delphi data-aware VCL components such as TTable and TQuery can make the process of creating QBF applications as easy as dragging and dropping and setting properties. This especially applies to really simple QBF apps that have only one query. Of course, for several sequential queries you'll have to do a bit of coding, but it's still pretty easy.
On top of all that, the Borland Database Engine (BDE) provides connectivity to a variety of database platforms, which means you can create generic QBFs that can go after data on heterogenous platforms.

The above are just a few examples of why I feel Delphi is an ideal tool for creating QBF applications.

Concept Revisited

I mentioned above that QBF implements an intelligent interface that has the ability to tranform user input requests into a data set of some sort. What is implied by QBF is that you use queries to perform the transformations, but I'm going to break stride here and say that you don't necessarily need to use queries to get your answer sets. Why? Think about it for a moment. The whole purpose of QBF is to hide the complexities inherent to data retrieval languages from the user. All users care about is the end product: the answer set. They don't care about the back-end operations. In that light, we open up a bunch of doors to getting data to the user.

For brevity's sake we won't go into all the different ways to do QBF. What I will concentrate on here are two common, useful ways of doing QBF in Delphi: by Dynamic Querying and TTable SetRange.

If there's something bugging you about the whole concept of QBF, it's probably this: You probably already know how to do this! That's right. Anytime you put a front-end form in front of a query or data retrieval operation, you're essentially doing Query By Form.

QBF Techniques: Another Flavor of Dynamic Queries

When you think of dynamic queries, what comes to mind? Usually the parameter-ized variety of placing a query variable within a SQL statement you preprocess with a Prepare, fill with a value, then execute. That's a perfectly valid methodology to employ in many cases. But for a lot of my own applications, I've found using parameter-ized queries limiting in many ways. You can't use a parameter in the FROM clause of a query. This means that you can't apply the query to different tables that have the same structure. For myself, I want to have ultimate flexibility, so what I do is address the SQL property directly.

The SQL property of a TQuery is a TStrings type property. Ah! the old TStrings. That's right folks, this is something many of you have used time and again in your programs. As you may already know, a TStrings object is nothing more than an ordered collection of strings, each accessed by means of a zero-based index (meaning the first string's index is '0'). So what's so special about this respect to the SQL property of a TQuery? It all has to do with strings themselves. The most important thing is that strings can be easily manipulated. You can pretty much dice and slice them any way you choose. With respect to dynamic queries, the ability to manipulate the SQL property is a boon to doing QBF. Let's look at a sample of a real code snippet from one of my larger QBF applications.

InitQuery := TQuery.Create(Application);
with InitQuery do
begin
  DatabaseName := 'PRIVATE';
  Close;
  SQL.Clear;
  SQL.Add('SELECT D.BATCH, D.RECORD, D.ACCOUNT, D.FACILITY, D."INGREDIENT COST",');
  SQL.Add('D."PHARMACY ID", D.DAW, D."DAYS SUPPLY", D."DISPENSING FEE",
        D."MEMBER ID",');
  SQL.Add('D."DOCTOR ID", D.NDC, D.FORMULARY, D."Apr Amt Due",');
  SQL.Add('D1."DEA CODE", D1."GPI CODE", D1."DRUG NAME", D1."GENERIC CODE",
  0 AS D."DAW COUNT"');
  SQL.Add('FROM "' + EncPath + '" D, ":DRUGS:' + DrugTable + '" D1');
  SQL.Add('WHERE (D.' + DateFld + ' = ' + BStart + ' AND D.' + DateFld + ' <= ' + BEnd
    + ') AND');
  SQL.Add('((D."RECORD STATUS" = ''P'') OR (D."RECORD STATUS" = ''R'')) AND ');

  //Get Account List and Medical Group entries. Have to do this conditionally to
  //handle both lists at the same time. A bit of a short-circuit
  if (MainForm.DBRadioGroup1.ItemIndex = 1) then
    if (MainForm.DBRadioGroup2.ItemIndex = 1) then
    begin
      AddSQLList(MainForm.AccountList, SQL, 'Account', True);
      AddSQLList(MainForm.MedGrpList, SQL, 'Facility', True);
    end
    else
      AddSQLList(MainForm.AccountList, SQL, 'Account', True)
  else if (MainForm.DBRadioGroup2.ItemIndex = 1) then
    AddSQLList(MainForm.MedGrpList, SQL, 'Facility', True);

  SQL.Add('(D.FORMULARY <> ''Q'') AND (D.NDC = D1.NDC)');

  SQL.SaveToFile('mgrInit.sql');
  try
    Open;
  except
    Free;
    raise;
    Abort;
  end;
end;

In the code above, I've marked in bold the places I've inserted string variables to be filled in at runtime. Due to the changing nature of user requests, I found this technique far more flexible and it allows me to change the SQL in any number of places in the SQL statement. One thing you should note in the code above is that not only did I just provide fill-in areas with string vars, I also used a remote procedure to load in SQL items using AddSQLList.

This takes advantage of an interesting feature of a TStrings item. While you cannot pass a TStrings item by reference (ie. procedure procName(var _tString: TStrings);), you can pass a TStrings object by constant value to add or delete from the list depending upon what you want to do. That is what the procedure AddSQLList performs. Essentially, it takes what users have entered in a TDBMemo criteria field on the QBF form, turns the list values into a string of comma-separated values, then turns the string into a SQL IN statement. The IN statement is then tacked onto the end of the SQL TStrings object. Let's look at the code:

{=====================================================================================
This procedure will add an IN query statement from a list of values passed from a
TDBMemo into the SQL of a TQuery. Using an IN is far more elegant than several
Field = 'value1' OR Field = 'value2' statements.
====================================================================================}

procedure AddSQLList(lst: TDBMemo; //List you want to read from
  const encSQL: TStrings; //SQL to add to
  fldName: string; //The field to query on
  AddAND: Boolean); //Add an AND to tail end?
var
  I: Word;
  valStr: string;

begin

  //initialize vars;

  valStr := '';

  //Parse the list and make a CSV string out of the values
  for I := 0 to (lst.Lines.Count - 1) do
  begin
    valStr := valStr + '''' + lst.Lines[I] + ''',';
  end;

  //Remove the trailing comma
  valStr := Copy(valStr, 1, Length(valStr) - 1);

  //Append the SQL IN clause with field name. If there is another
  //SQL statement to follow, append an AND to the end.
  if addAND then
    encSQL.Add(' D.' + fldName + ' IN (' + valStr + ') AND ')
  else
    encSQL.Add(' D.' + fldName + ' IN (' + valStr + ')');

end;

The only danger to the procedure above is that I don't know if this is a loophole in the compiler or not. One would assume that to change something, you would pass it by reference. But this is not so with TStrings. I'm waiting to hear replies from Borland and the folks a CompuServe. But rest assured, I've used this technique in both versions of Delphi with no problems. My only concern is what will happen in future versions of the compiler. In any case, the whole point to this discussion is that manipulating the SQL property directly is much more flexible that using parameter-ized queries.

QBF Techniques: TTable SetRange

Remember what I said above, that users don't care how they get their data, they just want to get it? Especially with simple retrieval functions, you don't necessarily need to perform a query. Sometimes a TTable SetRange will do the job for you, and not only that -- but faster.

There are a couple of ways to perform a SetRange. The first is to use the SetRange function itself, which combines the SetRangeStart, SetRangeEnd and ApplyRange functions in one call. This is effective for setting ranges on the first index of a table. For other setting ranges on other index fields, you will need to explicitly use the three functions mentioned previously . The help file explains the usage of these functions in detail, so I won't go into specific coding examples.

Wrapping It Up

I realize that this has been more of a concept discussion rather than a real coding discussion. But you should remember that there's a lot more to progamming than coding. Programming is a really complex process that includes a lot of conceptualization and analysis. Over the years that I have been developing applications, I have found that I've become a much more effective programmer by paying attention to the concepts that have been put before me, and using them as means to approaching a code solution from different perspectives.

How to synchronize two controls

Problem/Question/Abstract:

I have a frame with two panels on it (right and left). The left panel is a pretty standard treeview. The right panel is a representation of the data record for the selected node in the tree view. The right panel is dynamic, that is it is constructed on the fly at run time as the users have the ability to define what fields they wish to show and what the labels are for those fields.

I need the right panel to change the treeview node text when the record in the right panel is posted. The general consensus is that it'd best be done with a callback, but I've never done one before. Can anyone give me a simple example of how to do this?

Answer:

What you are describing is a Mediator Pattern. In essence, you set up a class which is aware of your two (or more) components. Set up properties to record changes and then in the appropriate event handler, simply assign the new values. The Mediator is solely responsible for synchronizing the two.

Very simple example (yours will be slightly more complex, but surprisingly probably won't have too much more code):

TEditBoxMediator = class
private
  FIsChanging: boolean;
  FFirstBox: TEdit;
  FSecondBox: TEdit;
  function GetText: string;
  procedure SetText(Value: string);
public
  property Text: string read GetText write SetText;
  constructor Create(const FirstBox, SecondBox: TEdit);
end;

constructor TEditBoxMediator.Create(const FirstBox, SecondBox: TEdit);
begin
  inherited Create;
  FFirstBox := FirstBox;
  FSecondBox := SecondBox;
  FIsChanging := False;
end;

function TEditBoxMediator.GetText: string;
begin
  Result := FFirstBox.Text;
end;

procedure TEditBoxMediator.SetText(Value: string);
begin
  if FIsChanging then
    Exit;
  FIsChanging := True;
  if FFirstBox.Text <> Value then
    FFirstBox.Text := Value;
  if FSecondBox.Text <> Value then
    FSecondBox.Text := Value;
  FIsChanging := False;
end;

procedure TForm1.Create {...}
begin
  FEditBoxMediator := TEditBoxMediator.Create(Edit1, Edit2);
end;

procedure TForm1.Edit1Change(Sender: TObject);
begin
  FEditBoxMediator.Text := Edit1.Text;
end;

and so on.


The idea is that the mediator handles the changes (and uses the internal flag to prevent an endless
loop).

Construct a class instance from a string

Problem/Question/Abstract:

Is it possible to construct an instance of a class given the name of the class in a string variable? I would also want to test that the so named class actually exists and is a descendent of another known base class before construction.

Answer:

Yes, if some preconditions are met. The first thing you need is a class registry, a construct that allows you to register all the classes you want to create at run-time given the class name. The VCL already contains such a registry for TPersistent-derived classes (actually it is used only for TComponent-derived classes). Look at RegisterClass, GetClass and FindClass in the online help.

If you have your own hierachry of classes it is quite easy to set up your own class registry, using the TClassList class from the Contnrs unit (see online help). You would have one instance (a singleton) of TClasslist as your registry, to which you add your classes at run-time, typically from the Initialization section of the unit that implements the class in question.

Delphi has class reference types (see online help), which are types the values of which are classes. So you define such a type for your base class:

type
  TClassAClass = class of TClassA;

TClassA needs to have a virtual constructor (like Tcomponent) for this scheme to work properly. You can now derive other classes from TClassA, which may override the base classes constructor as appropiate. To find a class in the registry given its classname you iterate over the classlist:

function CreateInstance(const classname: string; minclass: TClassAClass): TClassA;
var
  i: Integer;
  classref: TClassAClass
begin
  Result := nil;
  for i := 0 to classlist.count - 1 do
  begin
    classref := TClassAClass(classlist[i]);
    if classref.ClassnameIs(classname) and classref.InheritsFrom(minclass) then
    begin
      Result := classref.Create;
      Break;
    end;
  end;
end;

If the constructor needs parameters you have to pass these to your CreateInstance function.

Boyer-Moore-Horspool pattern matching

Problem/Question/Abstract:

Boyer-Moore-Horspool pattern matching

Answer:

Solve 1:

function search(pat: PATTERN; text: TEXT): integer;
var
  i, j, k, m, n: integer;
  skip: array[0..MAXCHAR] of integer;
  found: boolean;
begin
  found := FALSE;
  search := 0;
  m := length(pat);
  if m = 0 then
  begin
    search := 1;
    found := TRUE;
  end;
  for k := 0 to MAXCHAR do
    skip[k] := m;
  {Preprocessing}
  for k := 1 to m - 1 do
    skip[ord(pat[k])] := m - k;
  k := m;
  n := length(text);
  {Search}
  while not found and (k < = n) do
  begin
    i := k;
    j := m;
    while (j = 1) do
      if text[i] <> pat[j] then
        j := -1
      else
      begin
        j := j - 1;
        i := i - 1;
      end;
    if j = 0 then
    begin
      search := i + 1;
      found := TRUE;
    end;
    k := k + skip[ord(text[k])];
  end;
end;


Solve 2:

unit exbmh;

interface

uses
  Windows, SysUtils;

procedure BMHInit(const pattern: pchar);
function BMHSearch(cstring: pchar; const stringlen: integer): pchar;

var
  found: pchar;

implementation

{Date last modified: 05-Jul-1997
Case-sensitive Boyer-Moore-Horspool pattern match
Public domain by Raymond Gardner 7/92
Limitation: pattern length + string length must be less than 32767
10/21/93 rdg  Fixed bug found by Jeff Dunlop}

const
  Large = 32767;

type
  TSkip = array[0..256] of integer;
  PSkip = ^TSkip;
  TByteArray = array[0..0] of byte;
  PByteArray = ^TByteArray;

var
  patlen: integer;
  skip: TSkip;
  skip2: integer;
  pat: pchar;

procedure BMHInit1(const pattern: pchar);
var
  i, lastpatchar: integer;
begin
  pat := pattern;
  patlen := StrLen(pattern);
  for i := 0 to 255 do
    skip[i] := patlen;
  for i := 0 to patlen - 1 do
    skip[Byte(pat[i])] := patlen - i - 1;
  lastpatchar := byte(pat[patlen - 1]);
  skip[lastpatchar] := Large;
  skip2 := patlen;
  for i := 0 to patlen - 2 do
    if byte(pat[i]) = lastpatchar then
      skip2 := patlen - i - 1;
end;

function BMHSearch1(cstring: pchar; const stringlen: integer): pchar;
var
  i, j: integer;
  s: pchar;
begin
  i := patlen - 1 - stringlen;
  result := nil;
  if i >= 0 then
    exit;
  inc(cstring, stringlen);
  while true do
  begin
    repeat
      inc(i, skip[byte(cstring[i])]);
    until
      i > = 0;
    if i < (Large - StringLen) then
      exit;
    dec(i, Large);
    j := patlen - 1;
    s := cstring + (i - j);
    dec(j);
    while (j >= 0) and (s[j] = pat[j]) do
      dec(j);
    if (j < 0) then
    begin
      result := s;
      exit;
    end;
    inc(i, skip2);
    if (i >= 0) then
      exit;
  end;
end;

procedure BMHInit(const pattern: pchar);
var
  i, lastpatchar: integer;
  len: integer;
  skip: PSkip;
begin
  pat := pattern;
  len := StrLen(pattern);
  patlen := len;
  skip := @BMHSearchs.Skip;
  for i := 0 to 255 do
    skip[i] := len;
  for i := 0 to len - 1 do
    skip[Byte(pattern[i])] := len - i - 1;
  lastpatchar := byte(pattern[len - 1]);
  skip[lastpatchar] := Large;
  skip2 := len;
  for i := 0 to len - 2 do
    if byte(pattern[i]) = lastpatchar then
      skip2 := len - i - 1;
end;

function inner(i: integer; c: PByteArray): integer;
asm
  push ebx
  @L1:
    movzx ebx, byte ptr[edx + eax]
    add eax, [offset skip + ebx]
    jl @l1;
    pop ebx
end;

function BMHSearch(cstring: pchar; const stringlen: integer): pchar;
var
  i, j: integer;
  s: pchar;
  pat: pchar;
begin
  pat := BMHSearchs.pat;
  i := patlen - 1 - stringlen;
  result := nil;
  if i >= 0 then
    exit;
  inc(cstring, stringlen);
  while true do
  begin
    repeat
      inc(i, skip[byte(cstring[i])]);
    until
      i >= 0;
    if i < (Large - StringLen) then
      exit;
    dec(i, Large);
    j := patlen - 1;
    s := cstring + (i - j);
    dec(j);
    while (j >= 0) and (s[j] = pat[j]) do
      dec(j);
    if (j < 0) then
    begin
      result := s;
      exit;
    end;
    inc(i, skip2);
    if (i >= 0) then
      exit;
  end;
end;

const
data = 'of a procedure to find a pattern in a stringThis is a test of a procedure to find a pattern in a string last This is a test of aprocedure to find a pattern in a string';

initialization
  BMHInit('last');
  found := BMHSearch(data, length(data));

end.

How to specify a different width for the items list in a TComboBox

Problem/Question/Abstract:

How to specify a different width for the items list in a TComboBox

Answer:

Send it the CB_SETDROPPEDWIDTH message with a new width.

procedure TForm1.Button1Click(Sender: TObject);
var
  W: integer;
begin
  W := 300;
  SendMessage(ComboBox1.Handle, CB_SETDROPPEDWIDTH, W, 0);
end;

Cryptographic Random Numbers

Problem/Question/Abstract:

The time comes in many security related applications to generate random numbers. If done poorly, the entire application will be compromised (think netscape's CSS!). This article demonstrates a TRUE random number generator implemented in 3 layers.

Answer:

Simply calling Randomize and using the Random() procedure is a severe security flaw in application seeking to pretect data with random numbers. A random number generator gets is 'randomness' from entropy. Borlands Random() procedure uses a 32bit seed as entropy, and that seed is generated by the Randomize procedure which gets its entropy the system time and date which are very probabilistic and can be tested for quickly.

To generate random numbers that cannot be differentiated from pure chaos is a VERY difficult task on a computer, mainly because you rely on internal states that are often too predictable. The idea is to gather entropy from the least predictable states of the system and dillute that entropy inside a much larger pool. The pool I refer to is the internal state of the random number generator.

WHAT IT IS

There are important properties that have to be respected when generating random numbers. More specificaly, random numbers intended for encryption. The properties that implicated in this random number gerenartors design are strongly based on Bruce Schneier's Yarrow (www.counterpane.com).

The first property is to ensure there is always anought entropy in the pool before outputing random numbers so that the pool never enters a weakened state where the next random numbers that are output have predictible information.

The next property comes in handy if you're going to be using the generator to make session keys that will change multiple times during a chat session. It is important that one compromised key will not reveal any of the previous keys nor any of the next keys that will be used. To do this we need to eliminate the mathematical relationship between the random numbers that are output and the state of the pool.

The third desired property implies that enven if the entropy gathered from your sources is of poor quality (fairly predictable) the pool must not suffer for the low entropy and the output random numbers must not show any evidence of this.

I have tested this unit extensively. The final and most crucial test centered around the third property. To make an extreme case, I started the pool with nothing but zeros in it and generated ~12MB (100,000,000 bits). I used the DieHard battery of tests (http://stat.fsu.edu/~geo/diehard.html) and it passed all 15 with flying colors... without collecting any entropy. With this I am satisfied of the random number generator's performance and submit it to you to use as a secure alternative to what is commonly seen in programs.


HOW TO IT WORKS

two entropy gatherers are created:

a thread that tracks mouse movement at random intervals taking 4bits of entropy from the mouse position and state of the system's high-resolution timer.
a latency calculator that gets 4bits of entropy from the high-resolution timer when called by the main app (this is used by calling   TKeyGenerator.AddLatency on the OnKeyDown event of an edit box, to count harddrive latency, or irq latency)

When either of the entropy gatherers has accumulated 32bits, it sends it to the entropy pool.

The entroyp pool takes in entropy 32bits at a time and uses it to fill an entropy buffer of 256bits, when the buffer is full, a primary reseed is executed.

The primary reseed updates the primary pool (a Hash Context: internal state of a hash function) with the entropy and XORs it with the pool's seed (this seed is used similarly the way randomize generates randseed). After every primary reseed, the seed (with now 256bits of entropy) is ready to be used to output random numbers if the calling application so desires it, but it will continue to reseed and gather entropy regardless regardless of that. After 8 primary reseeds have taken place, a secondary reseed is executed.

The secondary reseed updates the secondary pool with the contents of the primary pool and then flushes the contents of the primary pool into a state with no entropy. The secondary pool is persistant in that it is never flushed and will carry entropy bits from various reseeds. A completly new seed is generated from the secondary reseed (where as the primary on modifies it with entropy). This secondary reseed prevents backtracking properties (gessing previous states of the pool) and ensures there is entropy in the pool even under conditions where new entropy is of poor quality.

When the calling application needs to generate a key it calls SafeGetKey which ensures that no more than 8 sets of 256bits of random numbers can be generated from a single reseed. To do this a key reserve counter is incremented every primary reseed, and cannot exceed 8. When a you generate a set of random numbers the key reserve is decremented and the function will return fasle if the key reserve is at 0. NOTE: an application can ignore the key reserve and call ForceGetKey. This is very risky practice and I seriously discourage you from using this function.

The random output created by GetKey is a generated with the entropy pool's seed. The seed is used as an encryption key and then permuted (with an expansion-compression). The new seed is used as data to be encrypted. It is encrypted with the previous seed and expanded-compressed in 64 rounds. These rounds ensure that it is impossible to determine the state of the seed, the primary pool, the secondary pool or the entorpy buffer; in turn, preventing anyone from finding the previous or next outputs.

NOTES

Assign a variable of type TKeyGenerator and call it's .Create. This will start the process. When you are done, call .Destropy.

You can use .KeyCount to find out the state of the key reserve (how many GetKey calls can be made before the next reseed). I strongly condone raising the value of MAX_KEY_RESERVE.

You can manipulate the speed at which entropy is gathered from the mouse by setting the MOUSE_INTERVAL constant (in milli-seconds). A value lower than 10 is unrecommended.

No error checking is done to ensure there is a high-frequency counter on the system, this should be verified by the calling application. If there is no such counter, the random number generator will work but will output non-random numbers.

The application must provide 32 BYTES of memory space in a variable to pass to the GetKey functions. No error checking is done here.

You may change KEY_BUILD_ROUNDS to any value greater than or equal to 32, but larger than 64 is quite useless.

IMPORTANT NOTE

The source bellow is part of a library in progress cummulating 3 years of my research. If you want to use it in a program, a little bit of credit would be nice.

NSCrypt.pas contains a pseudo random number generator that comes from an unknown source, and these implementations of Haval and Rijndael are [severe] modifications of David Barton's haval.pas and rijndael.pas found in the DCPcrypt 1.3 component suite.

Download NSCrypt.txt and rename it NSCrypt.pas (silly webhost) I've included the cryptographic functions sepperatly because they total 1300 lines together. My actual website is www.drmungkee.com

//you'll have to deal with the documentation above.

unit NoiseSpunge;

interface

uses Windows, Classes, Controls, NSCrypt;

const
  SEED_SIZE = 8;
  PRIMARY_RESEED = SEED_SIZE;
  SECONDARY_RESEED = SEED_SIZE;

  //parameters
  MAX_KEY_RESERVE = 8;
  KEY_BUILD_ROUNDS = 64;
  MOUSE_INTERVAL = 10;

type
  Key256 = array[0..SEED_SIZE - 1] of longword;

  TNoiseSpungeAddEntropy = procedure(Block: longword) of object;
  TNoiseSpungeProcedure = procedure of object;

  TMouseCollector = class(TThread)
  protected
    PCtx: Prng_CTX;
    x, y: integer;
    Block: longword;
    BitsGathered: longword;
    Interval, Frequency, ThisTime, LastTime: TLargeInteger;
    SendMouseEntropy: TNoiseSpungeAddEntropy;
  public
    constructor Create;
    procedure SyncSendMouseEntropy;
    procedure Execute; override;
  end;

  TLatencyCollector = class
  protected
    Block: longword;
    BitsGathered: longword;
    Time: TLargeInteger;
    SendLatencyEntropy: TNoiseSpungeAddEntropy;
  public
    constructor Create;
    procedure MeasureLatency;
  end;

  TEntropyPool = class
  protected
    Seed: Key256;
    EntropyBuffer: Key256;
    PrimaryPool: Haval_CTX;
    SecondaryPool: Haval_CTX;
    PrimaryReseedCount: byte;
    EntropyCount: byte;
    KeyReserve: byte;
    procedure PermuteSeed;
    procedure PrimaryReseed;
    procedure SecondaryReseed;
    procedure AddEntropy(Block: longword);
  public
    constructor Create;
  end;

  TKeyGenerator = class
  protected
    EntropyPool: TEntropyPool;
    MouseCollector: TMouseCollector;
    LatencyCollector: TLatencyCollector;
  public
    AddLatency: TNoiseSpungeProcedure;
    constructor Create;
    destructor Destroy; override;
    function KeyCount: byte;
    function SafeGetKey(var Key): boolean;
    procedure ForcedGetKey(var Key);
  end;

implementation

constructor TMouseCollector.Create;
begin
  inherited Create(true);
  Randomize;
  PrngInit(@PCtx, RandSeed);
  FreeOnTerminate := true;
  Priority := tpNormal;
  Resume;
end;

procedure TMouseCollector.SyncSendMouseEntropy;
begin
  SendMouseEntropy(Block);
end;

procedure TMouseCollector.execute;
var
  NilHandle: pointer;
  Idled: boolean;
begin
  NilHandle := nil;
  BitsGathered := 0;
  Idled := false;
  QueryPerformanceFrequency(Frequency);
  repeat
    if Idled = false then
    begin
      MsgWaitForMultipleObjects(0, NilHandle, false, MOUSE_INTERVAL, 0);
      Idled := true;
    end;
    QueryPerformanceCounter(ThisTime);
    if ThisTime - LastTime > Interval then
    begin
      if (x <> mouse.cursorpos.x) and (y <> mouse.cursorpos.y) then
      begin
        x := mouse.cursorpos.x;
        y := mouse.cursorpos.y;
        Inc(Block, (((x and 15) xor (y and 15)) xor (ThisTime and 15)) shl
          BitsGathered);
        Inc(BitsGathered, 4);
        if BitsGathered = 32 then
        begin
          PrngInit(@PCtx, Block);
          Synchronize(SyncSendMouseEntropy);
          Block := 0;
          BitsGathered := 0;
        end;
        Interval := ((((Prng(@PCtx) mod MOUSE_INTERVAL) div 2) + MOUSE_INTERVAL)
          * Frequency) div 1000;
        QueryPerformanceCounter(LastTime);
        Idled := false;
      end
      else
      begin
        QueryPerformanceCounter(LastTime);
        Idled := false;
      end;
    end;
  until Terminated = true;
end;

constructor TLatencyCollector.Create;
begin
  inherited Create;
  Block := 0;
  BitsGathered := 0;
end;

procedure TLatencyCollector.MeasureLatency;
begin
  QueryPerformanceCounter(Time);
  Inc(Block, (Time and 15) shl BitsGathered);
  Inc(BitsGathered, 4);
  if BitsGathered = 32 then
  begin
    SendLatencyEntropy(Block);
    Block := 0;
    BitsGathered := 0;
  end;
end;

constructor TEntropyPool.Create;
begin
  inherited Create;
  HavalInit(@PrimaryPool);
  HavalInit(@SecondaryPool);
  FillChar(Seed, SizeOf(Seed), 0);
  EntropyCount := 0;
  PrimaryReseedCount := 0;
  KeyReserve := 0;
end;

procedure TEntropyPool.PermuteSeed;
var
  TempBuffer: array[0..1] of Key256;
  PCtx: Prng_CTX;
  HCtx: Haval_CTX;
  i: byte;
begin
  for i := 0 to SEED_SIZE - 1 do
  begin
    PrngInit(@PCtx, Seed[i]);
    TempBuffer[0, i] := Prng(@PCtx);
    TempBuffer[1, i] := Prng(@PCtx);
  end;
  HavalInit(@HCtx);
  HavalUpdate(@HCtx, TempBuffer, SizeOf(TempBuffer));
  HavalOutput(@HCtx, Seed);
end;

procedure TEntropyPool.PrimaryReseed;
var
  TempSeed: Key256;
  i: byte;
begin
  HavalUpdate(@PrimaryPool, EntropyBuffer, SizeOf(EntropyBuffer));
  if PrimaryReseedCount
  begin
    HavalOutput(@PrimaryPool, TempSeed);
    for i := 0 to SEED_SIZE - 1 do
      Seed[i] := Seed[i] xor TempSeed[i];
    Inc(PrimaryReseedCount);
  end
else
  SecondaryReseed;
  FillChar(EntropyBuffer, SizeOf(EntropyBuffer), 0);
  if KeyReserve EntropyCount := 0;
end;

procedure TEntropyPool.SecondaryReseed;
begin
  HavalOutput(@PrimaryPool, Seed);
  HavalUpdate(@SecondaryPool, Seed, SizeOf(Seed));
  HavalOutput(@SecondaryPool, Seed);
  PermuteSeed;
  HavalInit(@PrimaryPool);
  PrimaryReseedCount := 0;
end;

procedure TEntropyPool.AddEntropy(Block: longword);
begin
  Move(Block, pointer(longword(@EntropyBuffer) + (EntropyCount * SizeOf(Block)))^,
    SizeOf(Block));
  Inc(EntropyCount, 1);
  if EntropyCount = PRIMARY_RESEED then
    PrimaryReseed;
end;

constructor TKeyGenerator.Create;
begin
  inherited Create;
  EntropyPool := TEntropyPool.Create;
  MouseCollector := TMouseCollector.Create;
  MouseCollector.SendMouseEntropy := EntropyPool.AddEntropy;
  LatencyCollector := TLatencyCollector.Create;
  LatencyCollector.SendLatencyEntropy := EntropyPool.AddEntropy;
  AddLatency := LatencyCollector.MeasureLatency;
end;

destructor TKeyGenerator.Destroy;
begin
  MouseCollector.terminate;
  LatencyCollector.destroy;
  EntropyPool.destroy;
  inherited Destroy;
end;

function TKeyGenerator.KeyCount: byte;
begin
  Result := EntropyPool.KeyReserve;
end;

function TKeyGenerator.SafeGetKey(var Key): boolean;
var
  TempSeed: Key256;
  TempBuffer: array[0..1] of Key256;
  RCtx: Rijndael_CTX;
  PCtx: Prng_CTX;
  HCtx: Haval_CTX;
  i, j: byte;
begin
  if EntropyPool.KeyReserve = 0 then
  begin
    Exit;
    Result := false;
  end
  else
    Result := true;
  Move(EntropyPool.Seed, TempSeed, SizeOf(TempSeed));
  EntropyPool.PermuteSeed;
  RijndaelInit(@RCtx, EntropyPool.Seed);
  for i := 0 to KEY_BUILD_ROUNDS - 1 do
  begin
    RijndaelEncrypt(@RCtx, TempSeed[0]);
    RijndaelEncrypt(@RCtx, TempSeed[4]);
    for j := 0 to SEED_SIZE - 1 do
    begin
      PrngInit(@pctx, TempSeed[j]);
      TempBuffer[0, j] := Prng(@PCtx);
      TempBuffer[1, j] := Prng(@PCtx);
    end;
    HavalInit(@HCtx);
    HavalUpdate(@HCtx, TempBuffer, SizeOf(TempBuffer));
    HavalOutput(@HCtx, TempSeed);
  end;
  Move(TempSeed, Key, SizeOf(TempSeed));
  Dec(EntropyPool.KeyReserve, 1);
end;

procedure TKeyGenerator.ForcedGetKey(var Key);
var
  TempSeed: Key256;
  TempBuffer: array[0..1] of Key256;
  RCtx: Rijndael_CTX;
  PCtx: Prng_CTX;
  HCtx: Haval_CTX;
  i, j: byte;
begin
  Move(EntropyPool.Seed, TempSeed, SizeOf(TempSeed));
  EntropyPool.PermuteSeed;
  RijndaelInit(@RCtx, EntropyPool.Seed);
  for i := 0 to KEY_BUILD_ROUNDS - 1 do
  begin
    RijndaelEncrypt(@RCtx, TempSeed[0]);
    RijndaelEncrypt(@RCtx, TempSeed[4]);
    for j := 0 to SEED_SIZE - 1 do
    begin
      PrngInit(@pctx, TempSeed[j]);
      TempBuffer[0, j] := Prng(@PCtx);
      TempBuffer[1, j] := Prng(@PCtx);
    end;
    HavalInit(@HCtx);
    HavalUpdate(@HCtx, TempBuffer, SizeOf(TempBuffer));
    HavalOutput(@HCtx, TempSeed);
  end;
  Move(TempSeed, Key, SizeOf(TempSeed));
  if EntropyPool.KeyReserve < 0 then
    Dec(EntropyPool.KeyReserve, 1);
end;

end.

Detect if the scrollbars of a TStringGrid are visible

Problem/Question/Abstract:

I have a TStringGrid on my form and enabled the horizontal scrollbar. This only appears when there are more cols than fit on the scroll. When it appears it covers the row at the bottom. I need to have one less row when it is shown. I cannot enable the vertical scrollbar. How do I test if it is visible?

Answer:

{ ... }
if (GetWindowLong(stringgrid.handle, GWL_STYLE) and WS_HSCROLL) <> 0 then
  { ... scrollbar is visible }

Get a color string in HTML format

Problem/Question/Abstract:

How can I receive the color string in HTML format

Answer:

If you want to create a HTML-file, you must define a tag for font color or backgroubd color. But you can't insert a Delphi's TColor value - you must convert the color into RGB-format.

function GetHTMLColor(cl: TColor; IsBackColor: Boolean): string;
var
  rgbColor: TColorRef;
begin
  if IsBackColor then
    Result := 'bg'
  else
    Result := '';
  rgbColor := ColorToRGB(cl);
  Result := Result + 'color="#' +
    Format('%.2x%.2x%.2x',
    [GetRValue(rgbColor),
    GetGValue(rgbColor),
      GetBValue(rgbColor)]) + '"';
end;

How to get the current row and column of a cursor in a TRichEdit

Problem/Question/Abstract:

How to get the current row and column of a cursor in a TRichEdit

Answer:

procedure TForm1.GetPosition(Sender: TRichEdit);
var
  aX, aY: Integer;
  TheRichEdit: TRichEdit;
begin
  aX := 0;
  aY := 0;
  TheRichEdit := TRichEdit(Sender);
  aY := SendMessage(TheRichEdit.Handle, EM_LINEFROMCHAR, TheRichEdit.SelStart, 0);
  aX := TheRichEdit.SelStart - SendMessage(TheRichEdit.Handle, EM_LINEINDEX, aY, 0);
  Panel1.Caption := IntToStr(aY + 1) + ':' + IntToStr(aX + 1);
end;

procedure TForm1.RichEditMouseDown(Sender: TObject; Button: TMouseButton;
  Shift: TShiftState; X, Y: Integer);
begin
  GetPosition(RichEdit);
end;

procedure TForm1.RichEditKeyUp(Sender: TObject; var Key: Word; Shift: TShiftState);
begin
  GetPosition(RichEdit);
end;

How to detect if you can run NT services

Problem/Question/Abstract:

How can I detect if I can install and run a service on the current operating system? I was just going to detect the operating system, but I figured it might be better to directly detect the service control - but not sure how to do that.

Answer:

After installing a service (using the -install command line parameter) you can use the following code to start the service:

function StartService(Name: string): boolean;
var
  Scm: SC_HANDLE;
  Service: SC_HANDLE;
  p: pChar;
begin
  Result := false;
  Scm := OpenSCManager(nil, nil, SC_MANAGER_ALL_ACCESS);
  if Scm <> 0 then
  begin
    Service := OpenService(Scm, pChar(Name), SC_MANAGER_ALL_ACCESS);
    if Service <> 0 then
    begin
      p := nil;
      if WinSvc.StartService(Service, 0, p) then
        Result := True;
      CloseServiceHandle(Service);
    end;
    CloseServiceHandle(Scm);
  end;
end;

Preload images

Problem/Question/Abstract:

I have a form with a TPageControl and a number of pages. On some pages, there is a TImage showing a JPEG picture. I want these images to be loaded when the form is created, not when they are going to be drawn. The problem is that it takes a long time to change page in the page control, if the new page hasn't been shown before.

Answer:

Try something like this:

procedure TForm1.FormCreate(Sender: TObject);
begin
  if Image1.Picture.Graphic is TJPEGImage then
  begin
    TJPEGImage(Image1.Picture.Graphic).DIBNeeded;
  end;
end;

It tells the JPEG to decode the image right away and not on demand as it otherwise would.

Automatically loading a form "on demand"

Problem/Question/Abstract:

How can I get my forms created automatically "on demand" (when they are referenced)?

Answer:

If you have programmed in Visual Basic, probably you know what we are talking about: when you reference a property or a method of form, it is automatically created if necessary. For example, the following code will generate an exception in Delphi if Form2 was not previously created:

Form2.Show;

However it would work perfectly well in Visual Basic (without the semicolon, of course), and we can make it work it Delphi too with this little trick:

unit Unit2;

interface

uses...;

type
  TForm2 = class(TForm)
    ...
  end;

function Form2: TForm2;

var
  // Form2: TForm2;

implementation

{$R *.DFM}

var
  RealForm2: TForm2;

function Form2: TForm2;
begin
  if RealForm2 <> nil then
    Form2 := RealForm2
  else
    Application.CreateForm(TForm2, Result);
end;

procedure TForm2.FormCreate(Sender: TObject);
begin
  RealForm2 := Self;
end;

procedure TForm2.FormDestroy(Sender: TObject);
begin
  RealForm2 := nil;
end;

initialization
  RealForm2 := nil;
end.

What we did was replacing the Form2 variable with a function with the same name and type. This function uses a "hidden" variable (declared in the implementation section) -RealForm2- to check if the form is created or not (and in the latter case, it will create it automatically). We set the value of this hidden variable in the OnCreate and OnDestroy events of the form to the address of the form or nil respectively.

Copyright (c) 2001 Ernesto De Spirito
Visit: http://www.latiumsoftware.com/delphi-newsletter.php

How to parse a TRichEdit for domain names

Problem/Question/Abstract:

How can I parse a TRichEdit for domains ending in .com, .net, .org?

Answer:

Solve 1:

Not extensively tested:

procedure TForm1.Button1Click(Sender: TObject);
const
  charsAllowedInDomain = ['a'..'z', '0'..'9', '.', '_']; {may be more}
  numExts = 4;
  domainExts: array[1..numExts] of Pchar = ('.com', '.net', '.org', '.gov'); {lower case!}
  lens: array[1..numExts] of Integer = (4, 4, 4, 4);
var
  S: string;
  pStartString, pScan, pStartDomain, pEndDomain: Pchar;
  domain: string;
  i: Integer;
begin
  S := AnsiLowerCase(richedit1.text);
  pStartString := PChar(S);
  pScan := pStartString;
  while pScan^ <> #0 do
  begin
    if pScan^ = '.' then
    begin
      for i := Low(domainExts) to High(domainExts) do
        if StrLComp(pScan, domainExts[i], lens[i]) = 0 then
        begin
          {we have a candidate}
          pStartDomain := pScan;
          pEndDomain := pScan + lens[i];
          if not (pEndDomain^ in charsAllowedInDomain) then
          begin
            while (pStartDomain > pStartString) and (pStartDomain[-1] in charsAllowedInDomain) do
              Dec(pStartDomain);
            SetString(domain, pStartDomain, pEndDomain - pStartDomain);
            listbox1.items.add(domain);
            pScan := pEndDomain - 1;
            break;
          end;
        end;
    end;
    Inc(pScan);
  end;
end;


Solve 2:

{ ... }
type {declared in richedit.pas D3}

  TCharRange = record
    cpMin: Longint;
    cpMax: LongInt;
  end;

  TFindTextExA = record {declared in richedit.pas D3}
    chrg: TCharRange;
    lpstrText: PAnsiChar;
    chrgText: TCharRange;
  end;

procedure REFindDomain(RE: TRichEdit; const Target: string; Strs: TStrings);
const
  {maybe more than these?}
  ValidChars: set of char = ['a'..'z', 'A'..'Z', '0'..'9', '.', '/', ':', '_', '-'];
var
  ftx: TFindTextExA;
  flags: longint;
  charpos: longint;
  s: string;
begin
  if (Target = '') then
    exit; {nothing to look for}
  {searches all of the RichEdit}
  ftx.chrg.cpMin := 0;
  ftx.chrg.cpMax := -1;
  ftx.lpstrText := PChar(Target);
  ftx.chrgText.cpMin := 0;
  ftx.chrgText.cpMax := 0;
  flags := 0;
  // EM_FINDTEXTEX = WM_USER + 79;  {declared in richedit.pas D3}
  while SendMessage(RE.Handle, WM_USER + 79, flags, longint(@ftx)) > -1 do
  begin
    RE.SelStart := ftx.chrgText.cpMin; {found at position}
    RE.SelLength := Length(Target);
    {get the line}
    if ftx.chrgText.cpMax >= 255 then
      s := Copy(RE.Lines.Text, ftx.chrgText.cpMax - 254, 255)
    else
      s := Copy(RE.Lines.Text, 1, ftx.chrgText.cpMax);
    {need to find start of domain name}
    charpos := Length(s);
    while (charpos > 1) and (s[charpos] in ValidChars) do
      Dec(charpos);
    if not (s[charpos] in ValidChars) then
      Inc(charpos);
    Strs.Add(Copy(s, charpos, Length(s)));
    ftx.chrg.cpMin := ftx.chrgText.cpMin + 1; {reset to found at pos}
  end;
end;

{ListBox1 contains 3 lines: '.com'  '.net'  '.org',   ListBox2 receives the results}

procedure TForm1.Button1Click(Sender: TObject);
var
  i: integer;
begin
  if ListBox1.Items.Count > 0 then
  begin
    ListBox2.Clear;
    for i := 0 to ListBox1.Items.Count - 1 do
    begin
      REFindDomain(RichEdit1, ListBox1.Items[i], ListBox2.Items);
    end;
    Label1.Caption := IntToStr(ListBox2.Items.Count);
  end;
end;

How to embed binary data in an executable (2)

Problem/Question/Abstract:

Is is possible to somehow embed an external executable file in a Delphi program? Or maybe another type of file for that matter like a zip file for instance. I want the file to be extractable from my program later on so that I can use it on another system.

Answer:

Here is a simple little component where you can save a file in the form file. You can add compression/decompression/encryption or whatever you like, but this demonstrates a possible storage process for data. Quick and simple to use.

unit Unit2;

interface

uses
  Classes, Sysutils;

type
  TFileResourceComponent = class(TComponent)
  private
    FStream: TMemoryStream;
    FFileName: TFileName;
    procedure SetFileName(const Value: TFileName);
    procedure ReadData(Stream: TStream);
    procedure WriteData(Stream: TStream);
  public
    procedure DefineProperties(Filer: TFiler); override;
    constructor Create(AOwner: TComponent); override;
    destructor Destroy; override;
  published
    property FileName: TFileName read FFileName write SetFileName;
  end;

procedure Register;

implementation

procedure Register;
begin
  RegisterComponents('REDSYS', [TFileResourceComponent]);
end;

{ TFileResourceComponent }

constructor TFileResourceComponent.Create(AOwner: TComponent);
begin
  inherited;
  FStream := TMemoryStream.Create;
end;

procedure TFileResourceComponent.DefineProperties(Filer: TFiler);
begin
  inherited;
  Filer.DefineBinaryProperty('Data', ReadData, WriteData, True);
end;

destructor TFileResourceComponent.Destroy;
begin
  inherited;
  FStream.Free;
end;

procedure TFileResourceComponent.ReadData(Stream: TStream);
begin
  if not (csDesigning in ComponentState) then
    FStream.CopyFrom(Stream, Stream.Size);
end;

procedure TFileResourceComponent.SetFileName(const Value: TFileName);
begin
  FFileName := Value;
end;

procedure TFileResourceComponent.WriteData(Stream: TStream);
var
  FS:
  TMemoryStream;
begin
  if FileExists(FFileName) then
  begin
    FS := TMemoryStream.Create;
    try
      FS.LoadFromFile(FFileName);
      Stream.CopyFrom(FS, FS.Size);
    finally
      FS.Free;
    end;
  end;
end;

end.

Init the BDE when it is located in another directory than the default one

Problem/Question/Abstract:

I need to use a BDE that is placed in another directory than default. How can I do it? DbiInit(pDbiEnv) doesn't work when pDbiEnv < > nil (not default).

Answer:

pDbiEnv := nil;
check(DbiInit(pDbiEnv));

or if you don't need the pointer simply

check(DbiInit(nil));

Load DOS text in a RichEdit

Problem/Question/Abstract:

Load OEM file (any DOS edited file) in a RichEdit.

Answer:

Use the following code, that translates the text through the OemToAnsiBuff function:


procedure TForm1.Button1Click(Sender: TObject);
var
  i: integer;
  linea: PChar;
  txt: TStringList;
begin
  txt := TStringList.Create;
  try
    txt.LoadFromFile('c:\Fichero\a\leer.txt');
    for i := 0 to txt.Count - 1 do
    begin
      linea := PChar(txt.strings[i]);
      OemToAnsiBuff(linea, linea, strlen(linea));
    end;
    RichEdit1.Lines.AddStrings(txt);
  finally
    txt.Free;
  end;
end;

Implode / Explode methods like in PHP

Problem/Question/Abstract:

In Delphi you can also use the implode and explode methods from PHP:

Answer:

type
  TDynStringArray = array of string;

function Implode(const Glue: string; const Pieces: array of string): string;
var
  I: Integer;
begin
  Result := '';
  for I := 0 to High(Pieces) do
    Result := Result + Glue + Pieces[I];
  Delete(Result, 1, Length(Glue));
end;

function Explode(const Separator, S: string; Limit: Integer = 0): TDynStringArray;
var
  SepLen: Integer;
  F, P: PChar;
begin
  SetLength(Result, 0);
  if (S = '') or (Limit < 0) then
    Exit;
  if Separator = '' then
  begin
    SetLength(Result, 1);
    Result[0] := S;
    Exit;
  end;
  SepLen := Length(Separator);

  P := PChar(S);
  while P^ <> #0 do
  begin
    F := P;
    P := AnsiStrPos(P, PChar(Separator));
    if (P = nil) or ((Limit > 0) and (Length(Result) = Limit - 1)) then
      P := StrEnd(F);
    SetLength(Result, Length(Result) + 1);
    SetString(Result[High(Result)], F, P - F);
    F := P;
    while (P^ <> #0) and (P - F < SepLen) do
      Inc(P); // n�chsten Anfang ermitteln
  end;
end;

Debug your ISAPI applications on IIS 5

Problem/Question/Abstract:

Debug your ISAPI applications on IIS 5 without messing around with the registry. Just as simple as it should be!

Answer:

Start IIS WWW service;

Open Internet Services Manager and start your web site;

Open the properties sheet of your scripts directory;

Choose Aplication Protection = Low;

Click on Configuration button and choose the App Debugging tab;

Enable both Debugging Flags;

Close Internet Services Manager and stop IIS WWW service (do not stop your web site before stoping IIS);

Set your Delphi ISAPI Run Parameters as follows:
- host application: C:\WINNT\system32\inetsrv\inetinfo.exe (fix the path if necessary);
- parameters: -e w3svc;

That's it!

Now start your application inside Delphi IDE and it'll start IIS. Open your browser and go to your application. Delphi should start it and "say" it's running.

Good luck!

How to read/ write a variable length string from/ to a TFileStream

Problem/Question/Abstract:

How to read/ write a variable length string from/ to a TFileStream

Answer:

Solve 1:

procedure WriteStringToFS(const s: string; const fs: TFileStream);
var
  i: integer;
begin
  i := 0;
  i := Length(s);
  if i > 0 then
    fs.WriteBuffer(s[1], i);
end;

function ReadStringFromFS(const fs: TFileStream): string;
var
  i: integer;
  s: string;
begin
  i := 0;
  s := '';
  fs.ReadBuffer(i, SizeOf(i));
  SetLength(s, i);
  fs.ReadBuffer(s, i);
  Result := s;
end;


Solve 2:

You should be using TWriter and TReader. They make this kind of thing really simple to do. Create a stream, writer and reader object at the form level, then instantiate them in the OnCreate and destroy them in the OnDestroy event.

Stream := TMemoryStream.Create; {Or whatever kind of stream}
Writer := TWriter.Create(Stream, 1024);
Reader := TReader.Create(Stream, 1024);

Once that's done, try something similar to the following...

procedure TForm1.WriteStringToFS(const S: string; Writer: TWriter);
begin
  try
    Writer.WriteString(S);
  except
    raise;
  end;
end;

function TForm1.ReadStringFromFS(Reader: TReader): string;
begin
  try
    Result := Reader.ReadString;
  except
    raise;
  end;
end;

No need to save the length of the string because the writer do this automatically. The only caveat is that you need to be sure to create the stream first and to destroy it last.

How to extract coordinates from a region

Problem/Question/Abstract:

I am trying to do regioning backwards. I am writing an application that will read in a bitmap, allow the user to set a transparent colour, and then calculate the point set that would be needed to make that region transparent. I then want to supply the user with the coordinates as a set of coordinates, i.e. I want to extract it from a region format. Why? Because that's how Winamp takes the data in to make its custom shaped forms. But I can't seem to figure out how to pull the data out.

Answer:

One thing I found is that you must create a region prior to GetWindowRgn. I thought that one was created by default. I made a function that does what you need:

procedure TForm1.ShowRgnInfo(Rgn: HRGN);
type
  RgnRects = array[0..1000] of TRect;
  PRgnRect = ^RgnRects;
var
  RgnData: PRgnData;
  Size: DWORD;
  i: Integer;
  R: TRect;
  RgnPtr: PRgnRect;
begin
  Size := GetRegionData(Rgn, 0, nil);
  Memo1.Lines.Add('Size = ' + IntToStr(Size));
  GetMem(RgnData, Size);
  GetRegionData(Rgn, Size, RgnData);
  Memo1.Lines.Add('Number of Rectangles = ' + IntToStr(RgnData.rdh.nCount));
  RgnPtr := @RgnData.Buffer;
  for i := 0 to RgnData.rdh.nCount - 1 do
  begin
    R := RgnPtr[i];
    Memo1.Lines.Add('Rect ' + IntToStr(i));
    Memo1.Lines.Add(IntToStr(R.Left) + ', ' + IntToStr(R.Top) + ', ' +
      IntToStr(R.Right) + ', ' + IntToStr(R.Bottom));
  end;
end;

Making a screen shot (Windows has trouble with big resolutions)

Problem/Question/Abstract:

I just want to give you an example of making a screen shot in "tiles" and pasting the results yourself.

Answer:

Sometimes you want to take a screen shot, however often Windows has trouble with big data amounts and becomes very slow. The simple solution is to make many small screen shots and paste the result together. It's not light speed, however often faster than taking the whole screen at once.

const
  cTileSize = 50;

function TForm1.GetScreenShot: TBitmap;
var
  Locked: Boolean;
  X, Y, XS, YS: Integer;
  Canvas: TCanvas;
  R: TRect;
begin
  Result := TBitmap.Create;
  Result.Width := Screen.Width;
  Result.Height := Screen.Height;
  Canvas := TCanvas.Create;
  Canvas.Handle := GetDC(0);
  Locked := Canvas.TryLock;
  try
    XS := Pred(Screen.Width div cTileSize);
    if Screen.Width mod cTileSize > 0 then
      Inc(XS);
    YS := Pred(Screen.Height div cTileSize);
    if Screen.Height mod cTileSize > 0 then
      Inc(YS);
    for X := 0 to XS do
      for Y := 0 to YS do
      begin
        R := Rect(
          X * cTileSize, Y * cTileSize, Succ(X) * cTileSize,
          Succ(Y) * cTileSize
          );
        Result.Canvas.CopyRect(R, Canvas, R);
      end;
  finally
    if Locked then
      Canvas.Unlock;
    ReleaseDC(0, Canvas.Handle);
    Canvas.Free;
  end;
end;

How to determine if a field's value has actually changed before posting the new value

Problem/Question/Abstract:

How to determine if a field's value has actually changed before posting the new value

Answer:

{ ... }
var
  sBeforeText: string;

  in the AfterEdit event of the table catch the value:

  SBeforeText := DataSet.FieldByName('Category').AsString;

  in the BeforePost or AfterPost Event(depending on your preference)you can compare the original with the current

  if (sBeforeText <> DataSet.FieldByName('Category').AsString) then
    ShowMessage('Different Values');

How to create a Starfield Simulation

Problem/Question/Abstract:

How to create a Starfield Simulation

Answer:

procedure TForm1.Button1Click(Sender: TObject);
var
  tmp: Integer;
begin
  for tmp := 1 to Num_Stars do {Num_Stars is an Integer value}
    Canvas.Pixels[Random(ClientWidth), Random(ClientHeight)] := clWhite;
end;

And you could get more fancy than that (i.e alter star color / greylevel for brightness, vary star
positions for galaxys).

Add a password to several Paradox tables in one step

Problem/Question/Abstract:

How to add a password to several Paradox tables in one step

Answer:

procedure BDEProtectTable(ATable: TTable; const APassword: string);
var
  CurPrp: CURProps;
  hDB: hDBIdb;
  TableDesc: CRTblDesc;
  DoEncrypt: boolean;
  bExcl, bOpen: boolean;
begin
  Check(DBIGetCursorProps(ATable.Handle, CurPrp));
  DoEncrypt := (APassword > '');
  with ATable do
  begin
    bOpen := Active;
    bExcl := Exclusive;
    if Active and not Exclusive then
      Close;
    if not Exclusive then
      Exclusive := True;
    if not Active then
      Open;
    {supply nulls (=default) for every optional parameter:}
    FillChar(TableDesc, SizeOf(CRTblDesc), 0);
    {supply indispensable parameters:}
    AnsiToNative(DBLocale, TableName, TableDesc.szTblName, DBIMAXTBLNAMELEN - 1);
    TableDesc.szTblType := CurPrp.szTableType;
    {supply parameters for our action here:}
    AnsiToNative(DBLocale, APassword, TableDesc.szPassword, 255);
    TableDesc.bProtected := DoEncrypt; {supply False to decrypt}
    hDB := DBHandle;
    Close;
    {do the restructure:}
    try
      Check(DBIDoRestructure(hDB, 1, @TableDesc, nil, nil, nil, False));
    finally
      Exclusive := bExcl;
      Active := bOpen;
    end;
  end;
end;

Send a file from a TServerSocket to a TClientSocket

Problem/Question/Abstract:

How i can send a file from a TServerSocket to a TClientSocket?

Answer:

unit Unit1;

interface

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

type
  TForm1 = class(TForm)
    ClientSocket1: TClientSocket;
    ServerSocket1: TServerSocket;
    btnTestSockets: TButton;
    procedure ClientSocket1Read(Sender: TObject; Socket: TCustomWinSocket);
    procedure FormCreate(Sender: TObject);
    procedure FormDestroy(Sender: TObject);
    procedure ClientSocket1Disconnect(Sender: TObject;
      Socket: TCustomWinSocket);
    procedure ClientSocket1Connect(Sender: TObject;
      Socket: TCustomWinSocket);
    procedure ServerSocket1ClientConnect(Sender: TObject;
      Socket: TCustomWinSocket);
    procedure btnTestSocketsClick(Sender: TObject);
  private
    FStream: TFileStream;

  public

  end;

var
  Form1: TForm1;

implementation

{$R *.dfm}

procedure TForm1.ClientSocket1Read(Sender: TObject;
  Socket: TCustomWinSocket);
var
  iLen: Integer;
  Bfr: Pointer;
begin
  iLen := Socket.ReceiveLength;
  GetMem(Bfr, iLen);
  try
    Socket.ReceiveBuf(Bfr^, iLen);
    FStream.Write(Bfr^, iLen);
  finally
    FreeMem(Bfr);
  end;
end;

procedure TForm1.FormCreate(Sender: TObject);
begin
  FStream := nil;
end;

procedure TForm1.FormDestroy(Sender: TObject);
begin
  if Assigned(FStream) then
  begin
    FStream.Free;
    FStream := nil;
  end;
end;

procedure TForm1.ClientSocket1Disconnect(Sender: TObject;
  Socket: TCustomWinSocket);
begin
  if Assigned(FStream) then
  begin
    FStream.Free;
    FStream := nil;
  end;
end;

procedure TForm1.ClientSocket1Connect(Sender: TObject;
  Socket: TCustomWinSocket);
begin
  FStream := TFileStream.Create('c:\temp\test.stream.html', fmCreate or
    fmShareDenyWrite);
end;

procedure TForm1.ServerSocket1ClientConnect(Sender: TObject;
  Socket: TCustomWinSocket);
begin
  Socket.SendStream(TFileStream.Create('c:\temp\test.html', fmOpenRead or
    fmShareDenyWrite));
end;

procedure TForm1.btnTestSocketsClick(Sender: TObject);
begin
  ServerSocket1.Active := True;
  ClientSocket1.Active := True;
end;

end.

Implement an inactivity timer with automatic logout

Problem/Question/Abstract:

Anyone have suggestions on how to implement an inactivity timer? My application has passwords for various functions, and I need to be able to automatically logout a user if they've been inactive for 10 minutes, etc.. I suppose I'd tie into the messaging queue, looking at keyboard and mouse events. The implementation should cover activity related to any form in my application, but not any activity outside the application.

Answer:

In your main form, add the integer variables "ShutdownCounter" and "ShutDownDelay". Add a TApplicationEvents and a TTimer control. Set the timer interval to, say, 5000 mSecs. In the form's OnCreate event handler, add:

{ ... }
    {Set up the automatic log off routine. Get the users auto logoff time,
                which defaults to 20 minutes. 0 is never autologoff}
shutDownDelay := UserIni.ReadInteger('Settings', 'Auto Shutdown Delay', 20);
shutDownDelay := shutDownDelay * 60;
ShutdownCounter := 0;
if shutDownDelay > 0 then
  timShutDown.Enabled := true;
    {Enable the timer if you want to use a timeout for this user}

This format allows you to add different logoff times for different users, or completely disable autologoff - I do this on my development system.

In the TApplicationEvents OnMessage event handler, add code to check for keypresses, or left mouse button clicks (or any other message you want to use to keep the app running). Whenever any of these messages are received by the application, reset the ShutDownCounter to zero.

procedure TfrmAutoProMain.ApplicationEvents1Message(var Msg: tagMSG;
  var Handled: Boolean);
begin
  case Msg.message of
    WM_KEYDOWN, WM_LBUTTONDOWN:
      ShutdownCounter := 0;
  end;
end;

In the TTimer OnTimer event handler, add code to compare the current value of ShutDownCounter against the ShutDownDelay for this user. If the counter is larger than the delay, then we need to exit the application. In my apps, I actually show another window with a 30 second decrementing progress bar which gives the user notification that the app is about to shutdown, and gives him a chance to keep the app alive - that's the references to dlgAutoLogOff .

procedure TfrmAutoProMain.timShutDownTimer(Sender: TObject);
begin
  Inc(ShutdownCounter, 5);
    {Increase counter by 5 seconds (if TTimer interval was 5000)}
  if ShutdownCounter >= shutDownDelay then
  begin
    timShutDown.Enabled := false;
    {The next block handles a "last chance" warning dialog to allow the user
                to stay alive}
    dlgAutoLogOff := TdlgAutoLogOff.Create(self);
    try
      dlgAutoLogOff.Show;
      repeat
        Application.ProcessMessages;
      until
        (dlgAutoLogOff.ModalResult = mrOK) or (dlgAutoLogOff.ModalResult = mrAbort);
      if dlgAutoLogOff.ModalResult = mrOK then
      begin
        ShutdownCounter := 0;
        timShutDown.Enabled := true;
      end
      else
        Application.Terminate;
    finally
      dlgAutoLogOff.Free;
    end;
  end;
end;

How to determine which combinations of rows and columns have been checked off in an array of TCheckBoxes

Problem/Question/Abstract:

I have a form with checkboxes in 8 rows and 7 columns. I want to be able to determine which combinations of rows and columns have been checked off. Is the best way to do this using a 2-D array? How would I declare this array for the checkboxes?

Answer:

FArray: array[0..7, 0..6] of TCheckBox;

You also you have to create Checkboxes at runtime, like:

FArray[i, j] := TCheckBox.Create(Self);

I would suggest to use the Tag property instead. Assign the same OnClick event handler to all checkboxes and code the Tag for each checkbox. Say 23 (second column, third row), you know like matrix indices in math:

....OnClick(Sender: TObject);
var
  ATag: Integer;
begin
  if (Sender is TComponent) then
  begin
    ATag := TComponent(Sender).Tag;
    ShowMessage(Format('Column %d, Row %d', [ATag div 10, ATag mod 10]));
  end;
end;

How to identify detail tables linked to a master table

Problem/Question/Abstract:

How can I retrieve the name of the detail tables of some master table? How can I know if a table has a detail table linked? Is there any property or function in the table or query to get the details they have?

Answer:

One way to identify linked detail tables is to scan the form or data module's components array:

for I := 0 to Pred(Component.Count) do
  if Components[I] is TTable then
    if TTable(Components[I]).DataSource <> nil then
      { do whatever }

How to embed binary data in an executable (3)

Problem/Question/Abstract:

Does anyone have experience using Delphi to create program that can create standalone exe that contains code and data like Picture2exe? This program creates a stand alone executable exe file that contains image and sound data that plays them in a slideshow. What is the approach and techniques used?

Answer:

Try this code where discclone.res includes the file you want to include:

procedure TMain.mnuCreateClick(Sender: TObject);
var
  MyFile: TFileStream;
  MyAppend: TMemoryStream;
begin
  if diagOpenSelf.Execute then
  begin
    if diagCreateSelf.Execute then
    begin
      CopyFile(PChar(ExtractFilePath(ParamStr(0)) + '\Extractor.exe'),
        PChar(diagCreateSelf.FileName), False);
      {Create a filestream object for the extractor executable}
      MyFile := TFileStream.Create(diagCreateSelf.FileName, $0002);
      try
        MyAppend := TMemoryStream.Create;
        try
          MyAppend.LoadFromFile(diagOpenSelf.FileName);
          MyFile.Seek(0, soFromEnd);
          MyFile.CopyFrom(MyAppend, 0);
          MessageBox(0, 'File was successfully created.', 'File Created',
            MB_OK + MB_ICONINFORMATION);
        finally
          MyAppend.Free;
        end;
      finally
        MyFile.Free;
      end;
    end;
  end;
end;

program Extractor;

{$R DiscClone.res}

uses
  Windows, Classes, ShellAPI, Sysutils;

const
  FileSize = 64512;
  {Or 60416. You may have to change to this number to the size of the
        compiled Extractor executable - minus the appended executable of course.}
var
  {MyExtract: TFileStream;}
  MyFile: TMemoryStream;
  TempStream: TMemoryStream;
  FileExe: string;
  Buffer: array[0..260] of Char;
  Count: DWord;
  Buf: Pointer;
  G: THandle;
  Res: LongBool;
begin
  { ... }
  {ask to make sure}
  { ... }
  {check floppy in drive}
  { ... }
  TempStream := TMemoryStream.Create;
  {Create the memory stream which will hold a copy of this executable in memory}
  MyFile := TMemoryStream.Create;
  try
    SetString(FileExe, Buffer, GetModuleFileName(0, Buffer,
      SizeOf(Buffer))); {What is the name of this executable?}
    MyFile.LoadFromFile(FileExe); {Load a copy of the executable into memory}
    {A filestream which will eventually create the HelloWorld program}
    // MyExtract := TFileStream.Create('dummy.floppy', fmCreate);
    try
      MyFile.Seek(FileSize, 0);
      Move the stream pointer to the start of the appended executable}
        {Copy the appended data to our filestream buffer - this creates the file}
    // MyExtract.CopyFrom(MyFile, MyFile.Size - FileSize);
      TempStream.CopyFrom(MyFile, MyFile.Size - FileSize);
    finally
      //  MyExtract.Free;  {Free the filestream object}
    end;
    {Tell the user that extraction went well and ask to run HelloWorld}
    G := CreateFile('\\.\A:', GENERIC_READ or GENERIC_WRITE, 0, nil, OPEN_EXISTING,
                          FILE_ATTRIBUTE_NORMAL, 0);
    //  F := CreateFile(PChar('\\.\' + location), GENERIC_READ or GENERIC_WRITE,
                0, nil, OPEN_EXISTING, FILE_ATTRIBUTE_NORMAL, 0);
    GetMem(Buf,1457664);  {1457664}
    //  SetFilePointer(F, 0, nil, FILE_BEGIN);
    //  ReadFile(F, Buf^, 1457664, Count, nil);
    //  Buf:=@MyExtract; //new
    WriteFile(G, Pointer(TempStream)^, 1457664, Count, nil);
    //  WriteFile(G, Buf^, 1457664, Count, nil);
    //  ShowMessage(IntToStr(GetLastError));
    FreeMem(Buf);
    //  CloseHandle(F);
    CloseHandle(G);
    
      {  G := CreateFile(PChar('\\.\C:\Work\Boot\TestCenter\Fred.txt'),
                                GENERIC_READ or GENERIC_WRITE, 0, nil, OPEN_ALWAYS,
                                FILE_ATTRIBUTE_NORMAL, 0);}
    G := CreateFile('\\.\A:', GENERIC_READ or GENERIC_WRITE, 0, nil, OPEN_EXISTING,
      FILE_ATTRIBUTE_NORMAL, 0);
    GetMem(Buf, 1474560);
    TempStream.Position := 0;
    TempStream.Read(Buf^, 1474560);
    res := WriteFile(G, Buf^, 1474560, Count, nil);
    if not res then
      MessageBox(0, PChar(IntToStr(GetLastError)),
        PChar(SysErrorMessage(GetLastError)),
        MB_OK);
    CloseHandle(G);
    FreeMem(Buf);
    //  FlushFileBuffers(MyFileStream.Handle);
    MessageBox(0, PChar(IntToStr(TempStream.size)), 'Extraction successful!',
      MB_OK + MB_ICONQUESTION)
  finally
    {Free the memoerystream object}
    MyFile.Free;
  end;
  TempStream.Free;
end.