String Grid to HTML file

Problem/Question/Abstract:

Procedure to dump the contents of a TStringGrid to HTML format file.

StrGridToHTML(const FileName: string;
StrGrid: TStringGrid;
const Heading: string = '';
TextColor: TColor = clBlack;
TableBgColor: TColor = clAqua);

Arguments

FileName : String containing Path and Filename of output file.
StrGrid : TStringGrid component to dup to file.
Heading : HTML Table Header Text. (optional default = nullstr)
TextColor : TColor denoting color of HTML table text (default = clblack)
TableBgColor : TColor denoting background color of HTML table (default = clAqua)

Example of Syntax

StrGridToHTML('c:\temp\test.htm', StringGrid1, 'Account Code', clBlue, clWhite);

Answer:

procedure StrGridToHTML(const FileName: string;
StrGrid: TStringGrid;
const Heading: string = '';
TextColor: TColor = clBlack;
TableBgColor: TColor = clAqua);
var
Txt: TextFile;
i, ii: integer;
BgColor, TxColor: string;
begin
// Convert TColor to HTML Hex Color
BgColor := IntToHex(GetRValue(TableBgColor), 2) +
IntToHex(GetGValue(TableBgColor), 2) +
IntToHex(GetBValue(TableBgColor), 2);

TxColor := IntToHex(GetRValue(TextColor), 2) +
IntToHex(GetGValue(TextColor), 2) +
IntToHex(GetBValue(TextColor), 2);

// Create output file
AssignFile(Txt, FileName);
Rewrite(Txt);

// HTML Header Info
WriteLn(Txt, '<HTML>');
WriteLn(Txt, '<HEAD>');
WriteLn(Txt, '<TITLE>' + ExtractFileName(FileName) + '</TITLE>');
WriteLn(Txt, '</HEAD>');
WriteLn(Txt);
WriteLn(Txt, '<BODY TEXT=#' + TxColor + ' BGCOLOR=#CCCCCC>');
WriteLn(Txt, '<H1>' + Heading + '</H1>');
WriteLn(Txt, '<TABLE WIDTH=100% CELLPADDING=2 CELLSPACING=2 ' +
'BGCOLOR=#' + BgColor + ' BORDER=1>');

// Column Descriptions
WriteLn(Txt, '    <TR>');
for i := 0 to StrGrid.ColCount - 1 do
WriteLn(Txt, '        <TH>' + StrGrid.Cells[i, 0] + '</TH>');
WriteLn(Txt, '    </TR>');

// Write out the Grid Data
for i := 1 to StrGrid.RowCount - 1 do
begin
WriteLn(Txt, '    <TR>');
for ii := 0 to StrGrid.ColCount - 1 do
WriteLn(Txt, '    <TD>' + StrGrid.Cells[ii, i] + '</TD>');
WriteLn(Txt, '    </TR>');
end;

// Footer
WriteLn(Txt, '<TABLE>');
WriteLn(Txt, '<P>');
WriteLn(Txt, '<H3>' + IntToStr(StrGrid.ColCount) + ' Rows</H3>');
WriteLn(Txt, '</BODY>');
WriteLn(Txt, '</HTML>');

CloseFile(Txt);
end;

how to transfer an object over a socket

Problem/Question/Abstract:

how to transfer an object over a socket

Answer:
In my project, I have to be able to transfer an object between clients and servers. I have tried to write some codes. Unluckily, there is always an exception "out of memory while expanding memory stream". I dont know why. Hope someone can help me. thanks. By the way, I use Indy to build connections.

unit Data;

interface

uses
Classes;

Type

TData = class(TComponent)
private
FStr : String;

public
constructor Create(AnOwner : TComponent); override;
destructor Destroy; override;

published
property Str : String read FStr write FStr;
end;

implementation

constructor TData.Create(AnOwner : TComponent);
begin
inherited Create(AnOwner);
FStr := 'It is created!!!';
end;

destructor TData.Destroy;
begin
inherited Destroy;
end;

end.

??????????????????????????????????????????????????????????????????????
implementation

{$R *.dfm}

uses
Data;

procedure TForm1.Button1Click(Sender: TObject);
begin
IdTCPServer1.Active := true;
end;

procedure TForm1.IdTCPServer1Connect(AThread: TIdPeerThread);
begin
Button1.Caption := 'a client';
end;

procedure TForm1.IdTCPServer1Execute(AThread: TIdPeerThread);
var
FData : TData;
FStream : TMemoryStream;
begin
FData := TData.Create(nil);
FStream := TMemoryStream.Create;
AThread.Connection.ReadStream(FStream);
FStream.ReadComponent(FData); // Here the exception comes up!!!
Edit1.Text := FData.Str;
FStream.Free;
FData.Free;
end;

end.


????????????????????????????????????????????????????????????????????

implementation

uses Data;

{$R *.dfm}

procedure TForm1.Button1Click(Sender: TObject);
begin
IdTCPClient1.Connect();
Button1.Caption := 'OK';
end;

procedure TForm1.Button2Click(Sender: TObject);
var
FData : TData;
FStream : TMemoryStream;
begin
FData := TData.Create(nil);
FStream := TMemoryStream.Create;
FStream.WriteComponent(FData);
IdTCPClient1.WriteStream(FStream);
FStream.Free;
FData.Free;
end;

end.

Get all installed components?

Problem/Question/Abstract:

How to get all installed components?

Answer:

uses ToolsApi;

{....}

var
a, i: Integer;
begin
with (BorlandIDEServices as IOTAPackageServices) do
begin
for a := 0 to GetPackageCount - 1 do
begin
for i := 0 to GetComponentCount(a) - 1 do
begin
{get each component name with GetComponentName(a, i);}
end;
end;
end;
end;

URL highlighting in TRichEdit

Problem/Question/Abstract:

URL highlighting in TRichEdit

Answer:

This functionality is implemented in
RichEdit from Microsoft (and MS Outlook use this feature, for example) and
only Borland's developers didn't publish it for us.)

{....}

protected

procedure WndProc(var Message: TMessage); override;

{....}

uses Richedit, ShellApi;

procedure TForm1.FormCreate(Sender: TObject);
var
mask: Word;
begin
mask := SendMessage(RichEdit1.Handle, EM_GETEVENTMASK, 0, 0);
SendMessage(RichEdit1.Handle, EM_SETEVENTMASK, 0, mask or ENM_LINK);
SendMessage(RichEdit1.Handle, EM_AUTOURLDETECT, Integer(True), 0);

//Some text in RichEdit
RichEdit1.Text := 'Scalabium Software'#13#10 +
' Site is located at www.scalabium.com. Welcome to our site.';
end;

procedure TForm1.WndProc(var Message: TMessage);
var
p: TENLink;
strURL: string;
begin
if (Message.Msg = WM_NOTIFY) then
begin
if (PNMHDR(Message.lParam).code = EN_LINK) then
begin
p := TENLink(Pointer(TWMNotify(Message).NMHdr)^);
if (p.Msg = WM_LBUTTONDOWN) then
begin
SendMessage(RichEdit1.Handle, EM_EXSETSEL, 0, Longint(@(p.chrg)));
strURL := RichEdit1.SelText;
ShellExecute(Handle, 'open', PChar(strURL), 0, 0, SW_SHOWNORMAL);
end
end
end;

inherited;
end;

Parse an XML file

Problem/Question/Abstract:

Another method to parse an XML file

Answer:

Here I will show one way to parse XML document

The main concept of XML is using containers for XML objects - so we will use Tree concept while building our XML object from XML document.

XML text uses containers (<TAG ... >...</TAG>) or simple definitions (<TAG ... />)  in each TAG we can use parameters (<TAG key1="value1" key2="value2">... <SIMPLE key3="value3"> ...</TAG>)

Finally we will have an array of objects, describing XML tags. Every object of this class will have an array of children if needed, and a hash to describe properties of it.


For example if we have a text

<UL name="xxx">
<LI name="xxx1"/>
<LI name="xxx2"/>
<LI name="xxx3"/>
<LI name="xxx4"/>
</UL>

we will have one root object (named "UL") in wich we will have 4 children (named "LI" with different sets of properties - from "NAME"="xxx1" to "NAME"="xxx4")

This is not a trivial task - so we will make a unit to solve this... I will try to comment some here...

unit YZXMLParser;

interface

uses
SysUtils, ComCtrls;

type
THashElement = record
Key, Value: string;
end;

type
THashElementArr = array of THashElement;

// here  we declare a THash class to use in our parser
// The concept of THash is to retreive named values from an array
// Hash is an array where index is a string (example V[Key]=value,
// whehe Key and Value are of type string)

// The main purpose of this class is to rerurn a value of a String-named key
//(example: s:=hash['someValue'])

// the description of a hash element we use

type
THash = class(TObject)
private
Arr: THashElementArr;
function GetValue(Key: string): string;
procedure SetValue(Key: string; const VValue: string);
function GetKeys: StrArr;
function GetValues: StrArr;
function GetCount: Integer;
function Getempty: Boolean;
public
property Value[Key: string]: string read GetValue write SetValue; default;
property Values: StrArr read GetValues;
property Keys: StrArr read GetKeys;
property Count: Integer read GetCount;
property Empty: Boolean read Getempty;
procedure Clear;
constructor Create;
destructor Destroy; override;
end;

TYZHash = THash;

type

// Here we declare some definitions for our parser to know what
// identifier we would receive next in our text
// these  values will be used in the result of WhatNext() function which will scan text for keys

TYZXMLMarker = (xmlOpenTag, xmlCloseTagShort, xmlCloseTag, xmlCloseTagLong,
xmlEOF, xmlIdentifier, xmlunknown);
/ *

Because we use recursive definition of our class(as TreeView, where we declare
children of
the same type in opur type
declaration)we must use forward declaration
* /

// The definition of a TAG class

TYZXMLTag = class;
TYZXMLTags = array of TYZXMLTag;

TYZXMLTag = class(TObject)
private
FData: TYZHash;
FParent: TYZXMLTag;
FName: string;

function GetValue(AName: string): string;
procedure SetName(const Value: string);
procedure SetValue(AName: string; const Value: string);
function GetCount: Integer;
function GetValueNames: strarr;

public
Children: TYZXMLTags; // these are our child nodes
Text: string;

property Name: string read FName write SetName; // name of a tag
property Values[AName: string]: string read GetValue write SetValue;
default; // values of properties of a tag (hash values)
property ValueNames: strarr read GetValueNames;
// array of strings returniong names of all props of this tag
property Count: Integer read GetCount;
// a count of children of a tag (if this tag is a container)

function SkipSpaces(var AData: string; var APos: Integer;
RememberBreaks: Boolean = False): Char;
// internal. for skip spaces (also CR or LF or other non-text chars) while parsing text

function ParseValue(var AData: string; var APos: Integer): Boolean;
// parse value (calling when found a parameter of a tag)
function ParseName(var AData: string; var APos: Integer): Boolean;
// parse key of parameter in a tag

// these two procs used to parse any text found while parsing XML
function ParseString(var AData: string; var APos: Integer;
RememberBreaks: Boolean = False): string;
function ParseQuotedString(var AData: string; var APos: Integer;
QIndef: Char = '"'): string;

// returnes the type of next identifier in XML
function WhatNext(var AData: string; var APos: Integer;
var ANext: Integer; RememberBreaks: Boolean = False): TYZXMLMarker;

// This is a main procedure of our class - AData is a string,
// containing all XML data (you can use TMemo.Text, for example, as a parameter of AData)
function ParseXML(var AData: string; var APos: Integer): Boolean;

// This function returnes a text string, built based on data, stored in an object.
function GenerateXML(var AData: string; ATab: string = ''): Boolean;

// returnes char from string at specified pos (#0 if not in range)
function CharAt(var S: string; APos: Integer): Char;

function TagNameExists(AName: string): Boolean;

// Adds a child to children array of a current tag

function AddChild: TYZXMLTag;

// Initializes current tag and deletes all existing children
procedure Clear; virtual;

constructor Create(AParent: TYZXMLTag); virtual;
destructor Destroy; virtual;
end;

type
TYZXMLParser = class(TYZXMLTag)
private
Header: TYZHash;
procedure _BuildTreeView(ATreeView: TTreeView; ANode: TTreeNode; ATag: TYZXMLTag);
public
property HeaderValues: TYZHash read Header;

procedure BuildTreeView(ATreeView: TTreeView);
function Parse(AData: string): Boolean;
function Generate(var AData: string): Boolean;
constructor Create;
destructor Destroy;
end;

implementation

//==============================================================================

{ TYZXMLTag }

function TYZXMLTag.AddChild: TYZXMLTag;
begin
setlength(children, Length(children) + 1);
Result := TYZXMLTag.Create(Self);
children[Length(children) - 1] := Result;
end;

//------------------------------------------------------------------------------

procedure TYZXMLTag.Clear;
var
i: Integer;
begin
for i := 0 to Count - 1 do
if children[i] <> nil then
Children[i].Destroy;
setlength(children, 0);
FData.Clear;
Text := '';
end;

//------------------------------------------------------------------------------

constructor TYZXMLTag.Create(AParent: TYZXMLTag);
begin
inherited Create;
FData := TYZHash.Create;
FParent := AParent;
Clear;
end;

//------------------------------------------------------------------------------

destructor TYZXMLTag.Destroy;
begin
Clear;
FData.Destroy;
end;

//------------------------------------------------------------------------------

function TYZXMLTag.GetCount: Integer;
begin
Result := Length(children);
end;

//------------------------------------------------------------------------------

function TYZXMLTag.GetValue(AName: string): string;
begin
Result := FData[AName];
end;

//------------------------------------------------------------------------------

function TYZXMLTag.ParseName(var AData: string; var APos: Integer): Boolean;
begin
Result := False;
FName := ParseString(AData, APos);
if fname = '' then
Exit;
Result := True;
end;

//------------------------------------------------------------------------------

function TYZXMLTag.ParseQuotedString(var AData: string; var APos: Integer;
QIndef: Char = '"'): string;
var
i: Integer;
skipnext: Boolean;
z: Char;
begin
Result := '';
if CharAt(AData, APos) <> QIndef then
Exit;
i := apos;
skipnext := True;
repeat
if not skipnext then
begin
if charat(AData, I) = '\' then
SkipNext := True
else
begin
z := charat(AData, I);
if (Z = QIndef) or (z = #0) then
begin
Result := Copy(AData, aPos + 1, I - APos - 1);
//          result:=exch(result,'\','');
APos := I + 1;
Exit;
end;
end;
end
else
skipnext := False;
Inc(i);
until False;
end;

//------------------------------------------------------------------------------

function TYZXMLTag.ParseString(var AData: string; var APos: Integer;
RememberBreaks: Boolean = False): string;
const
extsym: string = '=<>;?*/';
var
nxt: Char;
x1, x2, i: Integer;
begin
Result := '';
nxt := SkipSpaces(AData, APos, RememberBreaks);
if nxt = #0 then
Exit;
if (nxt = '"') or (nxt = '''') then
begin
Result := ParseQuotedString(AData, APos);
Exit;
end;
x1 := APos;
i := x1;
nxt := CharAt(AData, i);
while ((Ord(nxt) <= 32) or (Pos(nxt, extsym) > 0)) and (nxt <> #0) do
begin
Inc(i);
nxt := CharAt(AData, i);
end;
APos := i;
X1 := APos;
while (Ord(nxt) > 32) and (Pos(nxt, extsym) <= 0) do
begin
Inc(i);
nxt := CharAt(AData, i);
end;
x2 := i - x1;
Result := Copy(AData, x1, x2);
APos := i;
end;

//------------------------------------------------------------------------------

function TYZXMLTag.ParseValue(var AData: string; var APos: Integer): Boolean;
var
n, v: string;
i, x: Integer;
begin
Result := False;
n := parseString(AData, APos);
if n = '' then
Exit;
if skipspaces(AData, APos) <> '=' then
Exit;
Inc(apos);
V := parseString(AData, APos);
fdata[n] := dequote(v);
Result := True;
end;

//------------------------------------------------------------------------------

function TYZXMLTag.ParseXML(var AData: string; var APos: Integer): Boolean;
var
N: TYZXMLMarker;
nxt: Integer;
isLong: Boolean;
inTag: Boolean;
begin
isLong := False;
Result := False;
Clear;
if WhatNext(AData, APos, nxt) <> xmlOpenTag then
Exit;
APos := nxt;
if WhatNext(AData, APos, nxt) <> xmlIdentifier then
Exit;
Result := ParseName(AData, APos);
if not Result then
Exit;
intag := True;
Result := False;
while True do
begin
N := WhatNext(AData, APos, nxt, (not intag and islong and (Count > 0)));
case N of
xmlEOF: Exit;
xmlCloseTagLong:
begin
Result := True;
if islong then
APos := nxt;
if (Text <> '') and (Count > 0) then
begin
Text := exch(Text, #13#10#13#10, #13#10);
end;

Exit;
end;
xmlCloseTagShort:
begin
Result := (not IsLong) and intag;
if Result then
APos := nxt;
Exit;
end;
xmlOpenTag:
begin
if islong then
Result := AddChild.ParseXML(AData, APos)
else
begin
Result := False;
Exit;
end;
if not Result then
Exit;
end;
xmlCloseTag:
begin
IsLong := True;
APos := nxt;
intag := False;
end;
xmlIdentifier:
begin
if intag then
parsevalue(AData, APos)
else
Text := Text + ParseString(AData, APos, True)
end;
xmlUnknown:
begin
Result := True;
Exit;
end;
end;
end;
end;

//------------------------------------------------------------------------------

procedure TYZXMLTag.SetName(const Value: string);
begin
FName := Value;
end;

//------------------------------------------------------------------------------

procedure TYZXMLTag.SetValue(AName: string; const Value: string);
begin
FData[AName] := Value;
end;

//------------------------------------------------------------------------------

function TYZXMLTag.SkipSpaces(var AData: string; var APos: Integer;
RememberBreaks: Boolean = False): Char;
var
L: Integer;
P: Char;
begin
L := Length(AData);
while APos <= L do
begin
P := AData[APos];
if Ord(p) > 32 then
begin
Result := p;
Exit;
end
else if rememberbreaks then
begin
if Pos(p, #13#9' ') > 0 then
Text := Text + ' ';
end;
Inc(APos);
end;
Result := #0;
end;

//------------------------------------------------------------------------------

function TYZXMLTag.CharAt(var S: string; APos: Integer): Char;
begin
Result := #0;
if (Length(s) < APos) or (apos < 1) then
Exit;
Result := s[APos];
end;

//------------------------------------------------------------------------------

function TYZXMLTag.WhatNext(var AData: string; var APos: Integer;
var ANext: Integer; RememberBreaks: Boolean = False): TYZXMLMarker;
var
s: string;
C: Char;
P: Integer;
begin
Result := xmlEOF;
P := APos;
C := SkipSpaces(AData, APos);
P := APos;
ANext := P;
if C = #0 then
Exit;

if C = '<' then
if CharAt(AData, P + 1) = '/' then
begin
Inc(P, 2);
s := parsestring(AData, P);
if (uppercase(s) = uppercase(FName)) and (SkipSpaces(AData, P) = '>') then
begin
ANext := P + 1;
Result := xmlCloseTagLong;
Exit;
end
else
begin
if TagNameExists(s) then
begin
Result := xmlCloseTagLong;
ANext := APos;
Exit;
end;
ANext := P + 1;
Result := xmlCloseTagLong;
Exit;
end;
end;

if C = '<' then
begin
ANext := P + 1;
Result := xmlOpenTag;
Exit;
end;

if C = '>' then
begin
ANext := P + 1;
Result := xmlCloseTag;
Exit;
end;
if C = '/' then
if CharAt(AData, P + 1) = '>' then
begin
ANext := P + 2;
Result := xmlCloseTagShort;
Exit;
end;
ANext := P;
parsestring(AData, ANext);
Result := xmlIdentifier;
end;

//------------------------------------------------------------------------------

function TYZXMLTag.GetValueNames: strarr;
begin
Result := FData.Keys;
end;

//------------------------------------------------------------------------------

function TYZXMLTag.GenerateXML(var AData: string; ATab: string = ''): Boolean;
var
valDelimiter: string;
spc: string;
i: Integer;
a: strarr;
begin
spc := ATab + #9;
if FData.Count < 5 then
valDelimiter := ' '
else
valDelimiter := #13#10 + spc;
AData := AData + #13#10 + ATab + '<' + FName;
a := FData.keys;
for i := 0 to Length(a) - 1 do
begin
AData := AData + valDelimiter + a[i] + ' = "' + EnQuote(values[a[i]]) + '"';
end;
if (Count > 0) or (Text <> '') then
begin
AData := AData + '>' + Text;
for i := 0 to Count - 1 do
begin
Children[i].GenerateXML(AData, ATab + #9);
end;
AData := AData + #13#10 + ATab + '</' + FName + '>';
end
else
AData := AData + '/>';
Result := True;
end;

//------------------------------------------------------------------------------

function TYZXMLTag.TagNameExists(AName: string): Boolean;
begin
Result := AnsiUpperCase(AName) = AnsiUpperCase(Self.FName);
if Self.FParent = nil then
Exit;
if not Result then
Result := fparent.TagNameExists(AName);
end;

//==============================================================================

{ TYZXMLParser }

constructor TYZXMLParser.Create;
begin
Header := TYZHash.Create;
inherited Create(nil);
end;

//------------------------------------------------------------------------------

destructor TYZXMLParser.Destroy;
begin
inherited;
Header.Destroy;
end;

//------------------------------------------------------------------------------

procedure TYZXMLParser.BuildTreeView(ATreeView: TTreeView);
var
i: Integer;
begin
//  clear;
ATreeView.Items.Clear;
for i := 0 to Count - 1 do
_BuildTreeView(ATreeView, nil, children[i]);
end;

//------------------------------------------------------------------------------

procedure TYZXMLParser._BuildTreeView(ATreeView: TTreeView; ANode: TTreeNode;
ATag: TYZXMLTag);
var
i: Integer;
N: TTreeNode;
begin
N := ATreeView.Items.AddChildObject(ANode, ATag.Name + ' ' + FData['ID'],
Pointer(ATag));
for i := 0 to ATag.Count - 1 do
begin
if ATag.children[i] <> nil then
_BuildTreeView(ATreeView, N, ATag.children[i])
else
ATreeView.Items.AddChild(N, 'nil');
end;
N.Expanded := True;
end;

//------------------------------------------------------------------------------

function TYZXMLParser.Parse(AData: string): Boolean;
var
x1, x2, X, i: Integer;
s: string;
tmp: TYZXMLTag;
a: strarr;
N: TYZXMLMarker;
begin
X := 1;
Self.SkipSpaces(AData, X);
x2 := -1;
Result := False;
Clear;
Header.Clear;
x1 := Pos('<?', AData);
if x1 >= X then
begin
x2 := Pos('?>', AData);
if x2 < X then
Exit;
s := uppercase(Copy(AData, x1 + 2, 4));
if Pos('XML ', s) <> 1 then
Exit;
s := '<xml ' + Copy(AData, x1 + 6, x2 - x1 - 6) + '/>';
tmp := TYZXMLTag.Create(nil);
tmp.ParseXML(s, x);
a := tmp.ValueNames;
for i := 0 to Length(a) - 1 do
Header[a[i]] := tmp.Values[a[i]];
tmp.Destroy;
x := x2 + 2;
end;
Result := True;
repeat
N := whatnext(AData, X, x1);
case N of
xmlOpenTag: Result := Result and AddChild.ParseXML(AData, X);
xmlIdentifier:
begin
if Text <> '' then
Text := Text + ' ';
Text := Text + parsestring(AData, X, True);
end;
else
Parsestring(AData, X);
end;
until skipspaces(adata, x) = #0;
//  if not result then ShowMessage('Error Parsing: '+inttostr(X));
end;

function TYZXMLParser.Generate(var AData: string): Boolean;
var
i: Integer;
a: strarr;
begin
Header['Date'] := DateTimeToStr(now);
a := header.Keys;

AData := '<?xml';
for i := 0 to Length(a) - 1 do
AData := AData + ' ' + a[i] + '="' + Header[a[i]] + '"';

AData := AData + '?>'#13#10 + Text;
Result := True;
for i := 0 to Length(children) - 1 do
begin
Result := Result and children[i].generatexml(AData);
end;
end;

//==============================================================================

// procedures of THash class

//==============================================================================

{THASH CLASS}

procedure THash.Clear;
begin
SetLength(Arr, 0);
end;

constructor THash.Create;
begin
inherited;
Clear;
end;

//------------------------------------------------------------------------------

destructor THash.Destroy;
begin
Clear;
inherited;
end;

//------------------------------------------------------------------------------

function THash.GetCount: Integer;
begin
Result := Length(Arr);
end;

//------------------------------------------------------------------------------

function THash.Getempty: Boolean;
begin
Result := Length(Arr) = 0;
end;

function THash.GetKeys: StrArr;
var
i: Integer;
begin
SetLength(Result, Length(arr));
for i := 0 to Length(Result) - 1 do
Result[i] := arr[i].Key;
end;

//------------------------------------------------------------------------------

function THash.GetValue(Key: string): string;
var
i: Integer;
r: Boolean;
begin
Result := '';
i := 0;
r := False;
while (i < Length(Arr)) and (not r) do
begin
if AnsiUpperCase(arr[i].key) = AnsiUpperCase(Key) then
begin
Result := Arr[i].Value;
r := True;
end;
i := i + 1;
end;
end;

//------------------------------------------------------------------------------

function THash.GetValues: StrArr;
var
i: Integer;
begin
SetLength(Result, Length(arr));
for i := 0 to Length(Result) - 1 do
Result[i] := arr[i].Value;
end;

//------------------------------------------------------------------------------

procedure THash.SetValue(Key: string; const VValue: string);
var
i, j: Integer;
r: Boolean;
E: THashElementArr;
begin
if VValue <> '' then
begin
i := 0;
r := False;
while (i < Length(Arr)) and not r do
begin
if AnsiUpperCase(arr[i].key) = AnsiUpperCase(Key) then
begin
Arr[i].Value := VValue;
r := True;
end;
i := i + 1;
end;
if not r then
begin
SetLength(Arr, Length(arr) + 1);
arr[Length(arr) - 1].Key := Key;
arr[Length(arr) - 1].Value := Vvalue;
end;
end;

SetLength(E, Length(Arr));
for i := 0 to Length(arr) - 1 do
E[i] := Arr[i];
SetLength(arr, 0);
for i := 0 to Length(E) - 1 do
if (E[i].Key <> '') and (E[i].Value <> '') then
begin
j := Length(arr);
setlength(arr, j + 1);
arr[j] := E[i];
end;
end;

end.

Windows DNA multi-tier: a service-oriented approach

Problem/Question/Abstract:

Windows DNA multi-tier: a service-oriented approach

Answer:

Introduction

The Windows platform comes well equipped with a set of tools that permits the creation of scalable distributed systems, multi-vendor database access, load balancing and high level of security. All these techologies are commonly grouped under the name Windows DNA (Distributed iNternet Architecture). COM+, ADO, MSMQ, SOAP and XML are some of the core technologies on which a Windows DNA system is built upon.

In this series of articles I will analyze each of those technologies and try to demonstrate how you can practically use them to build multi-tier systems. I will do this by using an real life, A to Z example which is not too complex but neither too easy. My goal is to provide the reader with an understanding that goes beyond the hot technology topic of the day. It won't be only about SOAP, it won't only explain how you remotely access a COM object trought SOAP, it won't only show you how to parse an XML document.

My primary goal is to show how you can use all these technologies togheter to solve a business problem in a practical, efficient and easy-to-maintain manner. It will be more about design than implementation. I will show you what I learnt during years of practice, the design I prefer and sometimes I will also go against some of the teachings that are spread over the net about design patters and so called "correct" object-oriented designs.

The second goal I have is to demonstrate that in order to build enterprise-ready distributed systems you don't need to spend hundreds of thousands dollars like some companies would like you to belive. Specifically I will only use 3 products: Delphi 6 Professional, Windows 2000 and SQL Server 2000. Delphi 5 Professional could be used as well but you will need to translate my examples with whichever ADO component set you are using or, in case you are using Delphi 5 Enterprise, you are ready to go. Interbase could be used instead of SQL Server as well but there are a few issues that would make your life more complicated.

But what matters are the principles. Almost any technology can get the job done . The difference is how you prefer to do it.

A final note: this series of articles will be a big effort for me given the tied-up schedule I have like the rest of you. I cannot promise *when* these articles will be completed nor they will. The only thing I can promise is that I will do my best to finish the job.

The golden rules

We live in a world in which practically time-to-market is more important than quality. It is simple to understand why. If you don't get out there soon-enough, somebody else will. Then you can have the most beautiful system ever made by human kind but you won't make a penny out of it.

But obviously if your product is not well thought or too many corners have been cut, you may end up spending more in maintenance than in adding new functionality. The result may be even worse than not having sold the product in the first place: in top of not gaining you will end up with a ton of tedious work to do, nasty attourney's threats to dribble and a frustration level that spreads as quickly as an epidemic disease.

So what's the solution? Well, if you ask me, the solution is to follow a very short and general list of principles:

Understand the big picture

Keep it simple: only do what's required but have a good-enough understanding of what's coming next

Don't get fooled by hype

Don't overspend nor underspend money

Be ready and happy to refactor code

If you have read books about Extreme Programming or have heard about the Agile Software Development you should see many similarities. Take a look at Manifesto for Agile Software Development if you are new to this. It's eye-opening reading material in my opinion.

I am not an advocate of XP or Agile methodologies. I think all past, present and future methodologies have some value. At the very end the perfect approach is a personal decision that should be based on common sense and understanding of the situation in which we work in rather than "infallible" thomes of paper.

A simple business scenario

Imagine you are asked to build a warehouse management system. The system will need to do a number of things:

Return a list of customers of the warehouse

Allow the user to insert new customers

Return a list of orders and the details of each of them

Insert a new order

Return an inventory of stored items

I call each of these subfunctions a "service". Each service does one thing and one thing only. A service can either:

Read data

Write data

Invoke a series of other services to do something (workflow )

Now, what's important to us is how you design and implement these services. There could be many different ways to achieve our goal.

Best of breed OOP or pure RAD?

Some people advocate having an class for everything. For instance an order would be a class and each item in the order would be wrapped in another class. The header and the footer will be other classes as well along with a collection class that holds all the items togheter. And then why not, let's make the customer a class as well, it's address another one and so on... Where does this end? Probabily when the budget for your product ends and you are out of business or when you start taking shortcuts and everything falls apart because you are mixing approaches.

OOP is good. OOP is your friend. There are no objections to this but balance is in my opinion a better friend.

Delphi (or Visual Studio or the .Net framework for that matter) provides us with a number of very useful classes that have a clear objective: minimize our efforts and help us building maintainable systems. The first object that comes to mind can be the Borland TDataset or the Microsoft _Recorset. Those are great classes but at the same time they are very dangerous. They can help you build systems at lightening speeds but if not used properly they can generate so much chaos and mess that will make you wish of getting another job or finding another company.

I am making a joke out of this but this is a serious problem and probabily each and everyone of you witnessed the results of this at least once.

Perfectly engineered OOP projects cost a lot of money. The amount of detail that has to be put in up-front design is tremendous. This doesn't mean you should just start coding from day 1 or avoid doing such things. It means that practically few companies can afford it done right. Quite honestly, there's an big amount of risk involved in trying to figure out all the factes of a system before starting to implement it. It's a life fact: customers always change their minds and never know what they want.

At the same time starting beliveing that the OnClick or the OnBeforePost is the solution to the world's problems will put you in even more serious trouble.

What I hope I will be able to demonstrate is that there's something in between the two approaches that is much more effective, cost-effective and realistic. It's what I call a "service-oriented approach".

In the next articles I will try to define the architecture of our sample system and define our goals. I will discuss about server clusters and web farms, about stress testing, about quality assurance, COM+, security, transactions and databases plus a lot more.

Well, stay tuned and keep an eye on other articles that may come in the meantime!

What is a DRF file? Why is there a problem creating it?

Problem/Question/Abstract:

I just ran in a problem rebuilding the latest version of the TMultiLang package.
This is done by a batch file which invokes the command line compiler DCC32.EXE
I got this error message:

E:\Projects\MultiLang\mle>dcc32 multilang.dpk
Delphi for Win32 Version 10.0 Copyright (c) 1983,97 Borland International
MultiLang.dpk(40) Fatal: Could not create output file 'MultiLang.drf'

What is this DRF file? Why did I get this message?

Answer:

When you compile with packages, you can specify which packages should be considered for linkage. The package requirements of the project get stored into a temporary Windows resource file with a .DRF extension.

In my case I got this error message from DCC32 because my environment variable %TEMP% pointed to an not existing directory after I had cleaned up too much :-)

Variety of Floating point functions

Problem/Question/Abstract:

Variety of Floating point functions

Answer:

// FloatDecimals

function FloatDecimals(Value, decimals: extended): extended;
var
  Factor: extended;
begin
  Factor := Power(10, Decimals);
  Value := Value * Factor;
  Value := Round(Value);
  Value := Value / Factor;
  Result := Value;
end;

// FloatRound ( Same as FloatDecimals but more aqurate )

function FloatRound(Value, Digits: extended): extended;
var
  Factor: extended;
begin
  Factor := Power(10, Digits);
  Result := (Value * Factor) + 0.5;
  Result := Trunc(Result) / Factor;
end;

// FloatCompare

function FloatCompare(Value1, Value2: Extended): Boolean;
begin
  Result := False;
  if abs(Value1 - Value2) < 0.00001 then
    Result := True;
end;

// FloatLessEqual

function FloatLessEqual(Value1, Value2: extended): Boolean;
begin
  Result := False;
  if (abs(Value1 - Value2) < 0.00001) or (Value1 < Value2) then
    Result := True;
end;

// FloatGreateEqual

function FloatGreaterEqual(Value1, Value2: extended): Boolean;
begin
  Result := False;
  if (abs(Value1 - Value2) < 0.00001) or (Value1 > Value2) then
    Result := True;
end;

// FloatStr (Format a extended value towards a string with 2 decimals )

function FloatStr(Value: extended): string;
begin
  Result := FloatToStrF(Value, ffFixed, 18, 2);
end;

// FloatStr ( Format a extended value towards a string with specified decimals )

function FloatStr(Value: extended; Digits: Byte): string;
begin
  Result := FloatToStrF(Value, ffFixed, 18, Digits);
end;

Add a New Menu Item to the System Menu of an Application

Problem/Question/Abstract:

How can I add my own custom menu item to another application - one I haven't written?

Answer:

This tip is something that I've wanted to do for awhile, but kept on forgetting to write the article for it. It involves adding a menu choice to the system menu of an application. For the most part, you'll never have a need to do this. But there are some things like setting a form style, or some other action that is more system oriented than application oriented that just belong in the system menu. Well, here it is folks, and as usual, it's pretty incredibly easy to implement.

If you've tried to do this before but couldn't, it's because there is no way to add a menu item with standard Delphi calls. You have to trap Windows the windows message WM_SYSCOMMAND and evaluate the wParam message element to see if your added menu item was selected. Really folks, it's not that hard, and a little digging in the API help was all I needed to do find out how to implement this in a program. Basically, what you have to do is this:

Create a new form.
Override the OnMessage event by assigning a new event handler procedure for the OnMessage event.
Create a constant that will be used as the ordinal identifier for your menu choice.
In the FormCreate, make your menu choice with the AppendMenu API call.

Here's the code to show you how to do it:

unit sysmenu;

interface

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

type
  TForm1 = class(TForm)
    procedure FormCreate(Sender: TObject);
  private
    { Private declarations }
  public
    {This declaration is of the type TMessageEvent which
     is a pointer to a procedure that takes two variable
     arguments of type TMsg and Boolean, respectively}

    procedure WinMsgHandler(var Msg: TMsg;
      var Handled: Boolean);
  end;

var
  Form1: TForm1;

const
  MyItem = 100; {Here's the menu identifier.
  It can be any WORD value}

implementation

{$R *.DFM}

procedure TForm1.FormCreate(Sender: TObject);
begin

  {First, tell the application that its message
  handler is different from the default}
  Application.OnMessage := WinMsgHandler;

  {Add a separator}
  AppendMenu(GetSystemMenu(Self.Handle, False),
    MF_SEPARATOR, 0, '');

  {Add your menu choice. Since the Item ID is high,
  using the MF_BYPOSITION constant will place
   it last on the system menu}
  AppendMenu(GetSystemMenu(Self.Handle, False),
    MF_BYPOSITION, MyItem, 'My Men&u Choice');

end;

procedure TForm1.WinMsgHandler(var Msg: TMsg;
  var Handled: Boolean);
begin
  {if the message is a system one...}
  if Msg.Message = WM_SYSCOMMAND then
    if Msg.wParam = MyItem then
      {Put handling code here. I've opted for
       a ShowMessage for demonstration purposes}
      ShowMessage('You picked my menu!!!');
end;

end.

As you can see, this is fairly straight-forward. Granted, the tip is not very complicated. However, it does open up many doors to things you can do. In anticipation of some questions you might have later, The AppendMenu command can also be used with minimized apps. For instance, if you minimize your app, the icon represents the application, not your form. Therefore in order to make the system menu with your changes visible when in minimized form you would use Application.Handle instead of Self.Handle to deal with the application's system menu.

Get outlookexpress directory

Problem/Question/Abstract:

Did you ever wonder how to retrieve the outlookexpress directory. Down below the answer ..

Answer:

function GetOutlookExpressDir: string;
var
  Reg: TRegistry;
  ts, userID: string;
begin
  ts := '';
  Reg := TRegistry.Create;
  try
    Reg.RootKey := HKEY_CURRENT_USER;
    if Reg.OpenKey('\Software\Microsoft\Outlook Express', False) then
      ts := Reg.ReadString('Store Root');
    if ts = '' then
    begin
      if Reg.OpenKey('\Identities', False) then
      begin
        userID := Reg.ReadString('Default User ID');
        if Reg.OpenKey('\Identities\' + userID +
          '\Software\Microsoft\Outlook Express\5.0', False) then
          ts := Reg.ReadString('Store Root');
      end;
    end;
  finally
    if (ts <> '') then
    begin
      SetLength(userID, 1024);
      if (ExpandEnvironmentStrings(pointer(ts), @userID[1], 1024) > 0) then
        result := pchar(userID)
      else
        result := ts;
    end;
    Reg.CloseKey;
    Reg.Free;
  end;
end;

How to check for any lower case or space in a string

Problem/Question/Abstract:

How to check for any lower case or space in a string

Answer:

function ContainsLowerCaseOrSpace(AString: string): boolean;
var
  MySet: set of char;
  Len, Counter: integer;
begin
  MySet := ['a'..'z', ' '];
  Len := Length(AString);
  Result := Len <> 0;
  Counter := 1;
  while (not Result) and (Counter <= Len) do
  begin
    if AString[Counter] in MySet then
      Result := True
    else
      Inc(Counter);
  end;
end;

procedure AddSpaceBeforeUpperCaseCharOrNumber(var AString: string);
var
  Counter: integer;
  bLastIsNumber: boolean;
  bLastIsUpper: boolean;
begin
  Counter := Length(AString);
  bLastIsUpper := False; {Assume the last character will never be an upper case}
  bLastIsNumber := AString[Counter] in ['0'..'9'];
  dec(Counter);
  while Counter > 1 do
  begin
    if AString[Counter] in ['0'..'9'] then
    begin
      if not bLastIsNumber then
        Insert(' ', AString, Counter + 1);
      bLastIsNumber := True;
    end
    else
    begin
      if bLastIsNumber or bLastIsUpper then
      begin
        Insert(' ', AString, Counter + 1);
        bLastIsNumber := False;
      end;
      bLastIsUpper := AString[Counter] in ['A'..'Z'];
    end;
    dec(Counter);
  end;
end;

How to create isometric maps

Problem/Question/Abstract:

I'm planning to make an isometric map based game. Now, to do this, I need to know if the user clicked on one (or more) squares, for example, a building or a creature. I cannot figure out how to do this.

Answer:

Create a new project. On the form, create a TImage and align it to client. Also assign the form's OnCreate event, and the Image's OnMouseUp and OnMouseDown events. Paste this code into Unit1 and run. A 10x10 grid will be drawn. Click in it to highlight a square.


unit Unit1;

interface

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

type
  TForm1 = class(TForm)
    Image1: TImage;
    procedure FormCreate(Sender: TObject);
    procedure Image1MouseDown(Sender: TObject; Button: TMouseButton;
      Shift: TShiftState; X, Y: Integer);
    procedure Image1MouseUp(Sender: TObject; Button: TMouseButton;
      Shift: TShiftState; X, Y: Integer);
    procedure Image1MouseMove(Sender: TObject; Shift: TShiftState; X, Y: Integer);
  private
  public
  end;

var
  Form1: TForm1;

implementation

uses
  Math;

{$R *.DFM}

var
  XC: Integer;
  YC: Integer;
  LastX: Single;
  LastY: Single;

const
  Scale = 20;

procedure Map(const WorldX: Single; const WorldY: Single; out DisplayX: Integer;
  out DisplayY: Integer);
begin
  DisplayX := Round(XC + Scale * (WorldX - WorldY) * 0.5 * Sqrt(3));
  DisplayY := Round(YC + Scale * (WorldX + WorldY) * 0.5);
end;

procedure UnMap(const DisplayX: Integer; const DisplayY: Integer; out WorldX: Single;
  out WorldY: Single);
var
  Sum: Single;
  Diff: Single;
begin
  Diff := (DisplayX - XC) / (0.5 * Scale * Sqrt(3));
  Sum := (DisplayY - YC) / (0.5 * Scale);
  WorldY := (Sum - Diff) / 2;
  WorldX := Sum - WorldY;
end;

procedure TForm1.FormCreate(Sender: TObject);
var
  I: Integer;
  X1: Integer;
  Y1: Integer;
  X2: Integer;
  Y2: Integer;
begin
  XC := ClientWidth div 2;
  YC := ClientHeight div 2;
  with Image1.Picture.Bitmap do
  begin
    Width := Image1.Width;
    Height := Image1.Height;
  end;
  for I := -5 to 5 do
  begin
    Map(I, 5, X1, Y1);
    Map(I, -5, X2, Y2);
    with Image1.Picture.Bitmap.Canvas do
    begin
      MoveTo(X1, Y1);
      LineTo(X2, Y2);
    end;
    Map(5, I, X1, Y1);
    Map(-5, I, X2, Y2);
    with Image1.Picture.Bitmap.Canvas do
    begin
      MoveTo(X1, Y1);
      LineTo(X2, Y2);
    end;
  end;
end;

procedure ColorizeCell(const Color: TColor);
var
  PolygonData: array[0..3] of TPoint;
begin
  if ((Abs(LastX) < 5) and (Abs(LastY) < 5)) then
  begin
    Map(Floor(LastX), Floor(LastY), PolygonData[0].X, PolygonData[0].Y);
    Map(Floor(LastX), Ceil(LastY), PolygonData[1].X, PolygonData[1].Y);
    Map(Ceil(LastX), Ceil(LastY), PolygonData[2].X, PolygonData[2].Y);
    Map(Ceil(LastX), Floor(LastY), PolygonData[3].X, PolygonData[3].Y);
    with Form1.Image1.Picture.Bitmap.Canvas do
    begin
      Brush.Style := bsSolid;
      Brush.Color := Color;
      Polygon(PolygonData);
    end;
  end;
end;

procedure TForm1.Image1MouseDown(Sender: TObject; Button: TMouseButton;
  Shift: TShiftState; X, Y: Integer);
begin
  Unmap(X, Y, LastX, LastY);
  ColorizeCell(clRed);
end;

procedure TForm1.Image1MouseUp(Sender: TObject; Button: TMouseButton;
  Shift: TShiftState; X, Y: Integer);
begin
  ColorizeCell(clWhite);
end;

procedure TForm1.Image1MouseMove(Sender: TObject; Shift: TShiftState; X, Y: Integer);
begin
  ColorizeCell(clWhite);
  Unmap(X, Y, LastX, LastY);
  ColorizeCell(clYellow);
end;

end.

How to store a text file in a resource and display the lines in a TStringGrid at runtime

Problem/Question/Abstract:

I am trying to work out how to store approximately 1000 lines of text (3 columns, 30 chars each) inside an application. I want to read the values and then display them in a TStringGrid and do some further manipulation.

Answer:

If you want to read the data into a stringgrid a way to do that without building a class around the resource data would be this. You start by placing the data into a file and the file into a resource as detailed in Tip Number 1004. Loading this data into a TStringGrid would work like this:


procedure LoadResourceIntoGrid(grid: TStringGrid);
var
  rs: TResourceStream;
  numElements: Integer;
  datarec: TFileData;
  i: Integer;
begin
  rs := TResourceStream.Create(hInstance, 'FILEDATA', RT_RCDATA);
  try
    numElements := rs.Size div Sizeof(numElements);
    grid.Perform(WM_SETREDRAW, 0, 0);
    try
      grid.RowCount := numElements + 1; {assuming a header row}
      {following assumes grids colcount has been set correctly already}
      for i := 1 to numElements do
      begin
        rs.ReadBuffer(datarec, sizeof(datarec));
        grid.Cells[grid.FixedCols, i] := datarec.col1;
        grid.Cells[grid.FixedCols + 1, i] := datarec.col2;
        grid.Cells[grid.FixedCols + 2, i] := datarec.col3;
      end;
    finally
      grid.Perform(WM_SETREDRAW, 1, 0);
      grid.Invalidate;
    end;
  finally
    rs.free
  end;
end;

How to pick from a list of TPanels in a TListBox and display the selected panel

Problem/Question/Abstract:

How to pick from a list of TPanels in a TListBox and display the selected panel

Answer:

unit Unit1;

interface

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

type
  TForm1 = class(TForm)
    ListBox1: TListBox;
    procedure ListBox1Click(Sender: TObject);
  private
    { Private declarations }
    FPanelList: TList;
    FActivePanel: TPanel;
  public
    { Public declarations }
    constructor Create(AOwner: TComponent); override;
    destructor Destroy; override;
  end;

var
  Form1: TForm1;

implementation

{$R *.DFM}

{TForm1}

constructor TForm1.Create(AOwner: TComponent);
var
  i: integer;
  TempPanel: TPanel;
begin
  inherited;
  FPanelList := TList.Create;
  for i := 0 to 20 do
  begin
    TempPanel := TPanel.Create(self);
    TempPanel.Caption := 'TPanel' + IntToStr(i);
    Listbox1.Items.Add(TempPanel.Caption);
    FPanelList.Add(TempPanel);
  end;
end;

destructor TForm1.Destroy;
var
  i: integer;
begin
  for i := FPanelList.Count - 1 downto 0 do
    TPanel(FPanelList[i]).Free;
  FPanelList.Free;
  inherited;
end;

procedure TForm1.ListBox1Click(Sender: TObject);
begin
  if FActivePanel <> nil then
    FActivePanel.Parent := nil;
  FActivePanel := FPanelList[ListBox1.ItemIndex];
  FActivePanel.Parent := self;
end;

end.