Problem/Question/Abstract:
How to add items to a TRadioGroup without adding one item at a time
Answer:
{ ... }
with RadioGroup1.Items do
begin
Delimiter := ';';
DelimitedText := 'Apples;Bananas;Oranges';
end;
{ ... }
2005. december 31., szombat
2005. december 30., péntek
Subclassing a versatile TList
Problem/Question/Abstract:
You can use a TList almost for everything, so an own class leads to better design and maintainability therefore the article shows how and why.
Answer:
A certain view is that the TList class in Object Pascal (OP) is not a class from which we can descend, so the choice lies between subclassing (inheritance) or delegation (means create a separate class which holds the TList instance). But you can combine the two OO-technologies, especially you have multiple objects to store:
Subclass the TList that exposes only function equivalents of TList
Create a separate class that uses a TList instance
Some Advantages and Tricks of TList:
TList, which stores an dynamic array of pointers, is often used to maintain lists of objects or records. TList introduces properties and methods to
Add or delete the objects in the list.
Rearrange the objects in the list.
Locate and access objects in the list.
Sort the objects in the list.
The Items of a TList are numbered from 0 to Count-1, that means zero based. Above D5 and Kylix, Borland changed the operation of TList with the introduction of a new descendant called TObjectList. They changed only the mechanism of freeing objects in a TList.
If the OwnsObjects property of a TObjectList is set to True (the default), TObjectList controls the memory of its objects (by a new virtual method Notify), freeing an object when its index is reassigned or or when the TObjectList instance is itself destroyed, but the more items in the TList, the longer it takes. The worse is that a TList gets slower, so write always like in the following example your own Free-method (as it was with pre-Delphi 5 TList)!
var
Childs: TSubTList;
for i := 0 to Childs.count - 1 do
BusinessClass(Childs[i]).Free;
Childs.Free
BusinessClass(Childs[i]).Free calls every object on the list and frees the memory of every object or record that we add on the list.
Then Child.Free calls Destroy and then it calls Clear of TList but Clear only empties the Items array and set the Count to 0. Clear frees the memory used to store the Items array and sets the Capacity to 0. Be care about Delete, Delete does not free any memory associated with the item.
Gain speed with TList
The TList Sort mechanism is implemented with a quicksort algorithm, means we're fast enough, but how about the access?
The normal way of accessing an object or item in a TList is the Items property in a default manner like theList[i]. The performance problem is the reading or writing, cause the compiler in OP inserts code to call getter or setter-methods, like theList.get[i] which checks the index between 0 and Count -1. If we want gain speed and get rid of the getter/setter we can call direct a variable of type PPointerList (named List), but no validation takes place.
Childs.List^[i];
You then takes responsability of making sure reading or writing can't be beyond the ends of an array of the TList.
Example
The subclassing is like a wrapper class with simle one-line calls to the corresponding methods of the inherited TList without typecasts. The example shows how to add a record but with an object you have to change only the type and instead of Dispose use Free.
The Method Add always inserts the Item pointer at the end of the Items array, even if the Items array contains nil pointers:
var
Childs: TSubTList; //or TBrokerList
Childs.Add(BusinessClass.create(self));
Not all of the entries in the Items array need to contain references to objects. Some of the entries may be NIL pointers. To remove the NIL pointers and reduce the size of the Items array to the number of objects, call the Pack method.
type
TBrokerRec = record
intVal: integer;
strVal: string;
ptrStr: pChar;
end;
PBrok = ^TBrokerRec;
TBrokerList = class(TList)
protected
procedure freeElement(elem: PBrok);
function GetItems(Index: Integer): PBrok;
procedure SetItems(Index: Integer; item: PBrok);
public
destructor destroy; override;
function Add(Item: PBrok): Integer;
procedure Delete(index: integer);
function First: PBrok;
function indexOf(item: PBrok): Integer;
procedure Insert(index: integer; item: PBrok);
function Last: PBrok;
procedure pClear;
function Remove(item: PBrok): Integer;
property Items[Index: Integer]: PBrok read GetItems write SetItems;
end;
TBrokerList
destructor TBrokerList.destroy;
begin
clear;
inherited Destroy;
end;
function TBrokerList.Add(Item: PBrok): Integer;
begin
result := inherited Add(Item);
end;
procedure TBrokerList.Delete(index: integer);
begin
freeElement(items[index]);
inherited delete(index);
end;
function TBrokerList.First: PBrok;
begin
result := inherited First;
end;
procedure TBrokerList.freeElement(elem: PBrok);
begin
if elem <> nil then
dispose(elem);
end;
function TBrokerList.indexOf(item: PBrok): Integer;
begin
result := inherited indexOf(item);
end;
procedure TBrokerList.Insert(index: integer; item: PBrok);
begin
inherited insert(index, item);
end;
function TBrokerList.Last: PBrok;
begin
result := inherited Last;
end;
procedure TBrokerList.pClear; //instead of Free from outer class
var
x: Integer;
begin
for x := 0 to count - 1 do
freeElement(items[x]);
inherited clear;
end;
function TBrokerList.Remove(item: PBrok): Integer;
begin
result := indexOf(item);
if Result <> -1 then
delete(result);
end;
function TBrokerList.GetItems(Index: Integer): PBrok;
begin
result := inherited get(index);
end;
procedure TBrokerList.SetItems(Index: Integer; item: PBrok);
begin
inherited put(index, item);
end;
You can use a TList almost for everything, so an own class leads to better design and maintainability therefore the article shows how and why.
Answer:
A certain view is that the TList class in Object Pascal (OP) is not a class from which we can descend, so the choice lies between subclassing (inheritance) or delegation (means create a separate class which holds the TList instance). But you can combine the two OO-technologies, especially you have multiple objects to store:
Subclass the TList that exposes only function equivalents of TList
Create a separate class that uses a TList instance
Some Advantages and Tricks of TList:
TList, which stores an dynamic array of pointers, is often used to maintain lists of objects or records. TList introduces properties and methods to
Add or delete the objects in the list.
Rearrange the objects in the list.
Locate and access objects in the list.
Sort the objects in the list.
The Items of a TList are numbered from 0 to Count-1, that means zero based. Above D5 and Kylix, Borland changed the operation of TList with the introduction of a new descendant called TObjectList. They changed only the mechanism of freeing objects in a TList.
If the OwnsObjects property of a TObjectList is set to True (the default), TObjectList controls the memory of its objects (by a new virtual method Notify), freeing an object when its index is reassigned or or when the TObjectList instance is itself destroyed, but the more items in the TList, the longer it takes. The worse is that a TList gets slower, so write always like in the following example your own Free-method (as it was with pre-Delphi 5 TList)!
var
Childs: TSubTList;
for i := 0 to Childs.count - 1 do
BusinessClass(Childs[i]).Free;
Childs.Free
BusinessClass(Childs[i]).Free calls every object on the list and frees the memory of every object or record that we add on the list.
Then Child.Free calls Destroy and then it calls Clear of TList but Clear only empties the Items array and set the Count to 0. Clear frees the memory used to store the Items array and sets the Capacity to 0. Be care about Delete, Delete does not free any memory associated with the item.
Gain speed with TList
The TList Sort mechanism is implemented with a quicksort algorithm, means we're fast enough, but how about the access?
The normal way of accessing an object or item in a TList is the Items property in a default manner like theList[i]. The performance problem is the reading or writing, cause the compiler in OP inserts code to call getter or setter-methods, like theList.get[i] which checks the index between 0 and Count -1. If we want gain speed and get rid of the getter/setter we can call direct a variable of type PPointerList (named List), but no validation takes place.
Childs.List^[i];
You then takes responsability of making sure reading or writing can't be beyond the ends of an array of the TList.
Example
The subclassing is like a wrapper class with simle one-line calls to the corresponding methods of the inherited TList without typecasts. The example shows how to add a record but with an object you have to change only the type and instead of Dispose use Free.
The Method Add always inserts the Item pointer at the end of the Items array, even if the Items array contains nil pointers:
var
Childs: TSubTList; //or TBrokerList
Childs.Add(BusinessClass.create(self));
Not all of the entries in the Items array need to contain references to objects. Some of the entries may be NIL pointers. To remove the NIL pointers and reduce the size of the Items array to the number of objects, call the Pack method.
type
TBrokerRec = record
intVal: integer;
strVal: string;
ptrStr: pChar;
end;
PBrok = ^TBrokerRec;
TBrokerList = class(TList)
protected
procedure freeElement(elem: PBrok);
function GetItems(Index: Integer): PBrok;
procedure SetItems(Index: Integer; item: PBrok);
public
destructor destroy; override;
function Add(Item: PBrok): Integer;
procedure Delete(index: integer);
function First: PBrok;
function indexOf(item: PBrok): Integer;
procedure Insert(index: integer; item: PBrok);
function Last: PBrok;
procedure pClear;
function Remove(item: PBrok): Integer;
property Items[Index: Integer]: PBrok read GetItems write SetItems;
end;
TBrokerList
destructor TBrokerList.destroy;
begin
clear;
inherited Destroy;
end;
function TBrokerList.Add(Item: PBrok): Integer;
begin
result := inherited Add(Item);
end;
procedure TBrokerList.Delete(index: integer);
begin
freeElement(items[index]);
inherited delete(index);
end;
function TBrokerList.First: PBrok;
begin
result := inherited First;
end;
procedure TBrokerList.freeElement(elem: PBrok);
begin
if elem <> nil then
dispose(elem);
end;
function TBrokerList.indexOf(item: PBrok): Integer;
begin
result := inherited indexOf(item);
end;
procedure TBrokerList.Insert(index: integer; item: PBrok);
begin
inherited insert(index, item);
end;
function TBrokerList.Last: PBrok;
begin
result := inherited Last;
end;
procedure TBrokerList.pClear; //instead of Free from outer class
var
x: Integer;
begin
for x := 0 to count - 1 do
freeElement(items[x]);
inherited clear;
end;
function TBrokerList.Remove(item: PBrok): Integer;
begin
result := indexOf(item);
if Result <> -1 then
delete(result);
end;
function TBrokerList.GetItems(Index: Integer): PBrok;
begin
result := inherited get(index);
end;
procedure TBrokerList.SetItems(Index: Integer; item: PBrok);
begin
inherited put(index, item);
end;
2005. december 29., csütörtök
Get and set the BuiltinDocumentProperty of a Word document
Problem/Question/Abstract:
How to get and set the BuiltinDocumentProperty of a Word document
Answer:
{ ... }
var
VDoc, PropName, DocName: OleVariant;
{ ... }
VDoc := Word.ActiveDocument;
{Get a built in property}
ShowMessage(VDoc.BuiltInDocumentProperties['Title'].Value);
{Get a custom property}
PropName := 'MyOpinionOfThisDocument';
VDoc.CustomDocumentProperties.Add(PropName, False, msoPropertyTypeString,
'Hey', EmptyParam);
Caption := VDoc.CustomDocumentProperties[PropName].Value;
{ ... }
How to get and set the BuiltinDocumentProperty of a Word document
Answer:
{ ... }
var
VDoc, PropName, DocName: OleVariant;
{ ... }
VDoc := Word.ActiveDocument;
{Get a built in property}
ShowMessage(VDoc.BuiltInDocumentProperties['Title'].Value);
{Get a custom property}
PropName := 'MyOpinionOfThisDocument';
VDoc.CustomDocumentProperties.Add(PropName, False, msoPropertyTypeString,
'Hey', EmptyParam);
Caption := VDoc.CustomDocumentProperties[PropName].Value;
{ ... }
2005. december 28., szerda
Append HTML Text to a TWebbrowser Document
Problem/Question/Abstract:
How to append HTML Text to a TWebbrowser Document?
Answer:
uses
MSHTML;
procedure TForm1.Button1Click(Sender: TObject);
var
Range: IHTMLTxtRange;
begin
Range := ((WebBrowser1.Document as IHTMLDocument2).body as
IHTMLBodyElement).createTextRange;
Range.collapse(False);
Range.pasteHTML('<br><b>Hello!</b>');
end;
procedure TForm1.Button2Click(Sender: TObject);
begin
Webbrowser1.Navigate('www.google.ch');
end;
How to append HTML Text to a TWebbrowser Document?
Answer:
uses
MSHTML;
procedure TForm1.Button1Click(Sender: TObject);
var
Range: IHTMLTxtRange;
begin
Range := ((WebBrowser1.Document as IHTMLDocument2).body as
IHTMLBodyElement).createTextRange;
Range.collapse(False);
Range.pasteHTML('<br><b>Hello!</b>');
end;
procedure TForm1.Button2Click(Sender: TObject);
begin
Webbrowser1.Navigate('www.google.ch');
end;
2005. december 27., kedd
Component templates
Problem/Question/Abstract:
Do you usually drop a TDatabase component, associated with a TTable and a query... or a TEdit associated with a TButton... or some components that you usually put togheter in some of your projects?...
Answer:
Well... there's a very cool feature in Delphi that allows you to put togheter some Components (EVEN WITH THE CODE OF THE EVENTS!), so that you can reuse them all later with a single click, like dropping one component, but it will drop the group of components (TEMPLATE) in your form
here's how:
In Delphi, start a new application
Drop as many components as you want on the main form, and set their properties and/or events
Select all the components that you want on your template
Choose from the Delphi menu Component | Create Component Template
Specify a name for your template , as a Delphi rule you may want to keep the "T" at the beginning of the name and change the rest to whatever you want
Specify the Palette page where you want your new template to be, if you put a non existant palette page, Delphi will create a new one for you
Delphi even lets you assign a new icon for your template
Click OK
You're set!!
you just created a template which appears on the palette of components, and you can drop on a form as many times as you want and they will be linked (like if you chose a TTable linked to a TDatabase) as you specified, and will have all the code that you put on the events, all with a single click
Do you usually drop a TDatabase component, associated with a TTable and a query... or a TEdit associated with a TButton... or some components that you usually put togheter in some of your projects?...
Answer:
Well... there's a very cool feature in Delphi that allows you to put togheter some Components (EVEN WITH THE CODE OF THE EVENTS!), so that you can reuse them all later with a single click, like dropping one component, but it will drop the group of components (TEMPLATE) in your form
here's how:
In Delphi, start a new application
Drop as many components as you want on the main form, and set their properties and/or events
Select all the components that you want on your template
Choose from the Delphi menu Component | Create Component Template
Specify a name for your template , as a Delphi rule you may want to keep the "T" at the beginning of the name and change the rest to whatever you want
Specify the Palette page where you want your new template to be, if you put a non existant palette page, Delphi will create a new one for you
Delphi even lets you assign a new icon for your template
Click OK
You're set!!
you just created a template which appears on the palette of components, and you can drop on a form as many times as you want and they will be linked (like if you chose a TTable linked to a TDatabase) as you specified, and will have all the code that you put on the events, all with a single click
2005. december 26., hétfő
Here is a method for retrieving a list of installed applications on a particular machine running a Windows OS.
Problem/Question/Abstract:
Here is a method for retrieving a list of installed applications on a particular machine running a Windows OS.
Answer:
1. Start up Delphi.
2. Select File | New Application.
3. Add Registry to the uses of your new Unit.
4. Place a TListBox (ListBox1) component on your form.
5. Place a TButton (Button1) in your form.
6. Place the following code in the OnClick event of the Button1:
~~~~~~~~~~~~~~~~~~~~~~~~~
procedure TForm1.Button1Click(Sender: TObject) ;
const
REGKEYAPPS = '\SOFTWARE\Microsoft\Windows\
CurrentVersion\Uninstall';
var
reg : TRegistry;
List1 : TStringList;
List2 : TStringList;
j, n : integer;
begin
reg := TRegistry.Create;
List1 := TStringList.Create;
List2 := TStringList.Create;
{Load all the subkeys}
with reg do
begin
RootKey := HKEY_LOCAL_MACHINE;
OpenKey(REGKEYAPPS, false) ;
GetKeyNames(List1) ;
end;
{Load all the Value Names}
for j := 0 to List1.Count -1 do
begin
reg.OpenKey(REGKEYAPPS + '' + List1.Strings[j],false) ;
reg.GetValueNames(List2) ;
{We will show only if there is 'DisplayName'}
n := List2.IndexOf('DisplayName') ;
if (n <> -1) and
(List2.IndexOf('UninstallString') <> -1) then
begin
ListBox1.Items.Add(
(reg.ReadString(List2.Strings[n]))) ;
end;
end;
List.Free;
List2.Free;
reg.CloseKey;
reg.Destroy;
end;
Here is a method for retrieving a list of installed applications on a particular machine running a Windows OS.
Answer:
1. Start up Delphi.
2. Select File | New Application.
3. Add Registry to the uses of your new Unit.
4. Place a TListBox (ListBox1) component on your form.
5. Place a TButton (Button1) in your form.
6. Place the following code in the OnClick event of the Button1:
~~~~~~~~~~~~~~~~~~~~~~~~~
procedure TForm1.Button1Click(Sender: TObject) ;
const
REGKEYAPPS = '\SOFTWARE\Microsoft\Windows\
CurrentVersion\Uninstall';
var
reg : TRegistry;
List1 : TStringList;
List2 : TStringList;
j, n : integer;
begin
reg := TRegistry.Create;
List1 := TStringList.Create;
List2 := TStringList.Create;
{Load all the subkeys}
with reg do
begin
RootKey := HKEY_LOCAL_MACHINE;
OpenKey(REGKEYAPPS, false) ;
GetKeyNames(List1) ;
end;
{Load all the Value Names}
for j := 0 to List1.Count -1 do
begin
reg.OpenKey(REGKEYAPPS + '' + List1.Strings[j],false) ;
reg.GetValueNames(List2) ;
{We will show only if there is 'DisplayName'}
n := List2.IndexOf('DisplayName') ;
if (n <> -1) and
(List2.IndexOf('UninstallString') <> -1) then
begin
ListBox1.Items.Add(
(reg.ReadString(List2.Strings[n]))) ;
end;
end;
List.Free;
List2.Free;
reg.CloseKey;
reg.Destroy;
end;
2005. december 25., vasárnap
TTreeView easy way to add item
Problem/Question/Abstract:
TTreeView easy way to add item
Answer:
{
Here is a simple procedure that add Item in TreeView component
classed by level ... usefull for a "debug" ttreeview
}
{Add in the Public declaration}
DebugNode : Array [ 0..9 ] Of TTreeNode;
Procedure AddDebug ( Level : Integer; Text : String );
{Add between Implementation and End.}
Procedure TForm1.AddDebug ( Level : Integer; Text : String );
Begin
If Level = 0 Then
DebugNode [ 0 ] := TreeView1.Items.Add ( Nil, Text )
Else
DebugNode [ Level ] := TreeView1.Items.AddChild ( DebugNode [ Level - 1 ], Text );
End;
TTreeView easy way to add item
Answer:
{
Here is a simple procedure that add Item in TreeView component
classed by level ... usefull for a "debug" ttreeview
}
{Add in the Public declaration}
DebugNode : Array [ 0..9 ] Of TTreeNode;
Procedure AddDebug ( Level : Integer; Text : String );
{Add between Implementation and End.}
Procedure TForm1.AddDebug ( Level : Integer; Text : String );
Begin
If Level = 0 Then
DebugNode [ 0 ] := TreeView1.Items.Add ( Nil, Text )
Else
DebugNode [ Level ] := TreeView1.Items.AddChild ( DebugNode [ Level - 1 ], Text );
End;
2005. december 24., szombat
Callback function with a DLL
Problem/Question/Abstract:
How to make a DLL like a controller and how to write a callback-function with a DLL
Answer:
Callback function with a DLL
First a brief definition: A callback function is a function which you write, but is called by some other program or module, such as windows or DLL's.
For example a DLL (like a watchdog) controls many clients, so when a certain event occurs from the DLL that you called once, the callback function in the client is called (being passed any parameters or signals you need) and when the DLL-callback has completed, control is passed back to the controller-DLL or the client.
By the way, there is almost no possibilitie to make it more OO-like with a class, cause a callback is always an address of a standard procedure or function.
So the reason for this is that windows does not pass back any reference to SELF (means the instance of the class), which is used by classes when deciding which method from the instance to work with.
Let's get back to the framework and create a callback function, you must first:
declare a function type
the function itself
define the DLL reference
then implement the function in the client
and call the DLL:
Callback example in client unit
1.
interface...
TCallBackFunction = function(sig: integer): boolean;
2.
function callME(sig: integer): boolean;
3.
implement...
procedure TestCallBack(myCBFunction: TCallBackFunction); register;
external('watchcom.dll');
4.
function callMe(sig: integer): boolean;
begin
{whatever you need to do, case of...}
showmessage('I was called with' + inttostr(sig));
end;
5.
procedure TForm1.Button1Click(sender: TObject);
begin
testCallBack(callMe); //subscribe function in DLL
end;
Callback in the DLL
In the DLL you would also declare a function type and a procedure (or function) itself, so use it like this:
type
TCallBackFunction = function(sig: integer): boolean;
procedure TestCallBack(clientFunc: TCallBackFunction);
var
sigAlive: boolean;
begin
{timer stuff...
set the signal...}
if (clientFunc(55)) then
sigalive := true;
end;
exports TestCallBack;
Simple Sequence Diagram
Client DLL
¦ TestCallBack(clientFunc) ¦
¦---------------------------------------------->¦
¦ clientFunc.callMe(sig) ¦
¦<----------------------------------------------¦
¦ true (or something to return) ¦
¦---------------------------------------------->¦
How to make a DLL like a controller and how to write a callback-function with a DLL
Answer:
Callback function with a DLL
First a brief definition: A callback function is a function which you write, but is called by some other program or module, such as windows or DLL's.
For example a DLL (like a watchdog) controls many clients, so when a certain event occurs from the DLL that you called once, the callback function in the client is called (being passed any parameters or signals you need) and when the DLL-callback has completed, control is passed back to the controller-DLL or the client.
By the way, there is almost no possibilitie to make it more OO-like with a class, cause a callback is always an address of a standard procedure or function.
So the reason for this is that windows does not pass back any reference to SELF (means the instance of the class), which is used by classes when deciding which method from the instance to work with.
Let's get back to the framework and create a callback function, you must first:
declare a function type
the function itself
define the DLL reference
then implement the function in the client
and call the DLL:
Callback example in client unit
1.
interface...
TCallBackFunction = function(sig: integer): boolean;
2.
function callME(sig: integer): boolean;
3.
implement...
procedure TestCallBack(myCBFunction: TCallBackFunction); register;
external('watchcom.dll');
4.
function callMe(sig: integer): boolean;
begin
{whatever you need to do, case of...}
showmessage('I was called with' + inttostr(sig));
end;
5.
procedure TForm1.Button1Click(sender: TObject);
begin
testCallBack(callMe); //subscribe function in DLL
end;
Callback in the DLL
In the DLL you would also declare a function type and a procedure (or function) itself, so use it like this:
type
TCallBackFunction = function(sig: integer): boolean;
procedure TestCallBack(clientFunc: TCallBackFunction);
var
sigAlive: boolean;
begin
{timer stuff...
set the signal...}
if (clientFunc(55)) then
sigalive := true;
end;
exports TestCallBack;
Simple Sequence Diagram
Client DLL
¦ TestCallBack(clientFunc) ¦
¦---------------------------------------------->¦
¦ clientFunc.callMe(sig) ¦
¦<----------------------------------------------¦
¦ true (or something to return) ¦
¦---------------------------------------------->¦
2005. december 23., péntek
Print a TMemo, TStringlist, TStrings
Problem/Question/Abstract:
How to print a TMemo, TStringlist or TStrings?
Answer:
The following example project shows how to print a memos lines, but you can as well use listbox.items, it will work with every TStrings descendent, even a TStirnglist.
unit PrintStringsUnit1;
interface
uses
Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms,
Dialogs,
StdCtrls;
type
TForm1 = class(TForm)
Memo1: TMemo;
Button1: TButton;
procedure Button1Click(Sender: TObject);
private
{ Private declarations }
procedure PrintHeader(aCanvas: TCanvas; aPageCount: integer;
aTextrect: TRect; var Continue: boolean);
procedure PrintFooter(aCanvas: TCanvas; aPageCount: integer;
aTextrect: TRect; var Continue: boolean);
public
{ Public declarations }
end;
var
Form1: TForm1;
implementation
uses Printers;
{$R *.DFM}
type
THeaderFooterProc =
procedure(aCanvas: TCanvas; aPageCount: integer;
aTextrect: TRect; var Continue: boolean) of object;
{ Prototype for a callback method that PrintString will call
when it is time to print a header or footer on a page. The
parameters that will be passed to the callback are:
aCanvas : the canvas to output on
aPageCount: page number of the current page, counting from 1
aTextRect : output rectangle that should be used. This will be
the area available between non-printable margin and
top or bottom margin, in device units (dots). Output
is not restricted to this area, though.
continue : will be passed in as True. If the callback sets it
to false the print job will be aborted. }
{+------------------------------------------------------------
| Function PrintStrings
|
| Parameters :
| lines:
| contains the text to print, already formatted into
| lines of suitable length. No additional wordwrapping
| will be done by this routine and also no text clipping
| on the right margin!
| leftmargin, topmargin, rightmargin, bottommargin:
| define the print area. Unit is inches, the margins are
| measured from the edge of the paper, not the printable
| area, and are positive values! The margin will be adjusted
| if it lies outside the printable area.
| linesPerInch:
| used to calculate the line spacing independent of font
| size.
| aFont:
| font to use for printout, must not be Nil.
| measureonly:
| If true the routine will only count pages and not produce any
| output on the printer. Set this parameter to false to actually
| print the text.
| OnPrintheader:
| can be Nil. Callback that will be called after a new page has
| been started but before any text has been output on that page.
| The callback should be used to print a header and/or a watermark
| on the page.
| OnPrintfooter:
| can be Nil. Callback that will be called after all text for one
| page has been printed, before a new page is started. The callback
| should be used to print a footer on the page.
| Returns:
| number of pages printed. If the job has been aborted the return
| value will be 0.
| Description:
| Uses the Canvas.TextOut function to perform text output in
| the rectangle defined by the margins. The text can span
| multiple pages.
| Nomenclature:
| Paper coordinates are relative to the upper left corner of the
| physical page, canvas coordinates (as used by Delphis Printer.Canvas)
| are relative to the upper left corner of the printable area. The
| printorigin variable below holds the origin of the canvas coordinate
| system in paper coordinates. Units for both systems are printer
| dots, the printers device unit, the unit for resolution is dots
| per inch (dpi).
| Error Conditions:
| A valid font is required. Margins that are outside the printable
| area will be corrected, invalid margins will raise an EPrinter
| exception.
| Created: 13.05.99 by P. Below
+------------------------------------------------------------}
function PrintStrings(Lines: TStrings;
const leftmargin, rightmargin,
topmargin, bottommargin: single;
const linesPerInch: single;
aFont: TFont;
measureonly: Boolean;
OnPrintheader,
OnPrintfooter: THeaderFooterProc): Integer;
var
continuePrint: Boolean; { continue/abort flag for callbacks }
pagecount: Integer; { number of current page }
textrect: TRect; { output area, in canvas coordinates }
headerrect: TRect; { area for header, in canvas
coordinates }
footerrect: TRect; { area for footes, in canvas
coordinates }
lineheight: Integer; { line spacing in dots }
charheight: Integer; { font height in dots }
textstart: Integer; { index of first line to print on
current page, 0-based. }
{ Calculate text output and header/footer rectangles. }
procedure CalcPrintRects;
var
X_resolution: Integer; { horizontal printer resolution, in dpi }
Y_resolution: Integer; { vertical printer resolution, in dpi }
pagerect: TRect; { total page, in paper coordinates }
printorigin: TPoint; { origin of canvas coordinate system in
paper coordinates. }
{ Get resolution, paper size and non-printable margin from
printer driver. }
procedure GetPrinterParameters;
begin
with Printer.Canvas do
begin
X_resolution := GetDeviceCaps(Handle, LOGPIXELSX);
Y_resolution := GetDeviceCaps(Handle, LOGPIXELSY);
printorigin.X := GetDeviceCaps(Handle, PHYSICALOFFSETX);
printorigin.Y := GetDeviceCaps(Handle, PHYSICALOFFSETY);
pagerect.Left := 0;
pagerect.Right := GetDeviceCaps(Handle, PHYSICALWIDTH);
pagerect.Top := 0;
pagerect.Bottom := GetDeviceCaps(Handle, PHYSICALHEIGHT);
end; { With }
end; { GetPrinterParameters }
{ Calculate area between the requested margins, paper-relative.
Adjust margins if they fall outside the printable area.
Validate the margins, raise EPrinter exception if no text area
is left. }
procedure CalcRects;
var
max: integer;
begin
with textrect do
begin
{ Figure textrect in paper coordinates }
Left := Round(leftmargin * X_resolution);
if Left < printorigin.x then
Left := printorigin.x;
Top := Round(topmargin * Y_resolution);
if Top < printorigin.y then
Top := printorigin.y;
{ Printer.PageWidth and PageHeight return the size of the
printable area, we need to add the printorigin to get the
edge of the printable area in paper coordinates. }
Right := pagerect.Right - Round(rightmargin * X_resolution);
max := Printer.PageWidth + printorigin.X;
if Right > max then
Right := max;
Bottom := pagerect.Bottom - Round(bottommargin *
Y_resolution);
max := Printer.PageHeight + printorigin.Y;
if Bottom > max then
Bottom := max;
{ Validate the margins. }
if (Left >= Right) or (Top >= Bottom) then
raise
EPrinter.Create('PrintString: the supplied margins are too large, there
' +
'is no area to print left on the page.');
end; { With }
{ Convert textrect to canvas coordinates. }
OffsetRect(textrect, -printorigin.X, -printorigin.Y);
{ Build header and footer rects. }
headerrect := Rect(textrect.Left, 0,
textrect.Right, textrect.Top);
footerrect := Rect(textrect.Left, textrect.Bottom,
textrect.Right, Printer.PageHeight);
end; { CalcRects }
begin { CalcPrintRects }
GetPrinterParameters;
CalcRects;
lineheight := round(Y_resolution / linesPerInch);
end; { CalcPrintRects }
{ Print a page with headers and footers. }
procedure PrintPage;
procedure FireHeaderFooterEvent(event: THeaderFooterProc; r: TRect);
begin
if Assigned(event) then
begin
event(Printer.Canvas,
pagecount,
r,
ContinuePrint);
{ Revert to our font, in case event handler changed
it. }
Printer.Canvas.Font := aFont;
end; { If }
end; { FireHeaderFooterEvent }
procedure DoHeader;
begin
FireHeaderFooterEvent(OnPrintHeader, headerrect);
end; { DoHeader }
procedure DoFooter;
begin
FireHeaderFooterEvent(OnPrintFooter, footerrect);
end; { DoFooter }
procedure DoPage;
var
y: integer;
begin
y := textrect.Top;
while (textStart < Lines.Count) and
(y <= (textrect.Bottom - charheight)) do
begin
{ Note: use TextRect instead of TextOut to effect clipping
of the line on the right margin. It is a bit slower,
though. The clipping rect would be
Rect( textrect.left, y, textrect.right, y+charheight). }
printer.Canvas.TextOut(textrect.Left, y, Lines[textStart]);
Inc(textStart);
Inc(y, lineheight);
end; { While }
end; { DoPage }
begin { PrintPage }
DoHeader;
if ContinuePrint then
begin
DoPage;
DoFooter;
if (textStart < Lines.Count) and ContinuePrint then
begin
Inc(pagecount);
Printer.NewPage;
end; { If }
end;
end; { PrintPage }
begin { PrintStrings }
Assert(Assigned(afont),
'PrintString: requires a valid aFont parameter!');
continuePrint := True;
pagecount := 1;
textstart := 0;
Printer.BeginDoc;
try
CalcPrintRects;
{$IFNDEF WIN32}
{ Fix for Delphi 1 bug. }
Printer.Canvas.Font.PixelsPerInch := Y_resolution;
{$ENDIF }
Printer.Canvas.Font := aFont;
charheight := printer.Canvas.TextHeight('�y');
while (textstart < Lines.Count) and ContinuePrint do
PrintPage;
finally
if continuePrint and not measureonly then
Printer.EndDoc
else
begin
Printer.Abort;
end;
end;
if continuePrint then
Result := pagecount
else
Result := 0;
end; { PrintStrings }
procedure TForm1.Button1Click(Sender: TObject);
begin
ShowMessage(Format('%d pages printed',
[PrintStrings(memo1.Lines,
0.75, 0.5, 0.75, 1,
6,
memo1.Font,
False,
PrintHeader, PrintFooter)
]));
end;
procedure TForm1.PrintFooter(aCanvas: TCanvas; aPageCount: integer;
aTextrect: TRect; var Continue: boolean);
var
S: string;
res: integer;
begin
with aCanvas do
begin
{ Draw a gray line one point wide below the text }
res := GetDeviceCaps(Handle, LOGPIXELSY);
pen.Style := psSolid;
pen.Color := clGray;
pen.Width := Round(res / 72);
MoveTo(aTextRect.Left, aTextRect.Top);
LineTo(aTextRect.Right, aTextRect.Top);
{ Print the page number in Arial 8pt, gray, on right side of
footer rect. }
S := Format('Page %d', [aPageCount]);
Font.Name := 'Arial';
Font.Size := 8;
Font.Color := clGray;
TextOut(aTextRect.Right - TextWidth(S), aTextRect.Top + res div
18,
S);
end;
end;
procedure TForm1.PrintHeader(aCanvas: TCanvas; aPageCount: integer;
aTextrect: TRect; var Continue: boolean);
var
res: Integer;
begin
with aCanvas do
begin
{ Draw a gray line one point wide 4 points above the text }
res := GetDeviceCaps(Handle, LOGPIXELSY);
pen.Style := psSolid;
pen.Color := clGray;
pen.Width := Round(res / 72);
MoveTo(aTextRect.Left, aTextRect.Bottom - res div 18);
LineTo(aTextRect.Right, aTextRect.Bottom - res div 18);
{ Print the company name in Arial 8pt, gray, on left side of
footer rect. }
Font.Name := 'Arial';
Font.Size := 8;
Font.Color := clGray;
TextOut(aTextRect.Left, aTextRect.Bottom - res div 10 -
TextHeight('W'),
'W. W. Shyster & Cie.');
end;
end;
end.
How to print a TMemo, TStringlist or TStrings?
Answer:
The following example project shows how to print a memos lines, but you can as well use listbox.items, it will work with every TStrings descendent, even a TStirnglist.
unit PrintStringsUnit1;
interface
uses
Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms,
Dialogs,
StdCtrls;
type
TForm1 = class(TForm)
Memo1: TMemo;
Button1: TButton;
procedure Button1Click(Sender: TObject);
private
{ Private declarations }
procedure PrintHeader(aCanvas: TCanvas; aPageCount: integer;
aTextrect: TRect; var Continue: boolean);
procedure PrintFooter(aCanvas: TCanvas; aPageCount: integer;
aTextrect: TRect; var Continue: boolean);
public
{ Public declarations }
end;
var
Form1: TForm1;
implementation
uses Printers;
{$R *.DFM}
type
THeaderFooterProc =
procedure(aCanvas: TCanvas; aPageCount: integer;
aTextrect: TRect; var Continue: boolean) of object;
{ Prototype for a callback method that PrintString will call
when it is time to print a header or footer on a page. The
parameters that will be passed to the callback are:
aCanvas : the canvas to output on
aPageCount: page number of the current page, counting from 1
aTextRect : output rectangle that should be used. This will be
the area available between non-printable margin and
top or bottom margin, in device units (dots). Output
is not restricted to this area, though.
continue : will be passed in as True. If the callback sets it
to false the print job will be aborted. }
{+------------------------------------------------------------
| Function PrintStrings
|
| Parameters :
| lines:
| contains the text to print, already formatted into
| lines of suitable length. No additional wordwrapping
| will be done by this routine and also no text clipping
| on the right margin!
| leftmargin, topmargin, rightmargin, bottommargin:
| define the print area. Unit is inches, the margins are
| measured from the edge of the paper, not the printable
| area, and are positive values! The margin will be adjusted
| if it lies outside the printable area.
| linesPerInch:
| used to calculate the line spacing independent of font
| size.
| aFont:
| font to use for printout, must not be Nil.
| measureonly:
| If true the routine will only count pages and not produce any
| output on the printer. Set this parameter to false to actually
| print the text.
| OnPrintheader:
| can be Nil. Callback that will be called after a new page has
| been started but before any text has been output on that page.
| The callback should be used to print a header and/or a watermark
| on the page.
| OnPrintfooter:
| can be Nil. Callback that will be called after all text for one
| page has been printed, before a new page is started. The callback
| should be used to print a footer on the page.
| Returns:
| number of pages printed. If the job has been aborted the return
| value will be 0.
| Description:
| Uses the Canvas.TextOut function to perform text output in
| the rectangle defined by the margins. The text can span
| multiple pages.
| Nomenclature:
| Paper coordinates are relative to the upper left corner of the
| physical page, canvas coordinates (as used by Delphis Printer.Canvas)
| are relative to the upper left corner of the printable area. The
| printorigin variable below holds the origin of the canvas coordinate
| system in paper coordinates. Units for both systems are printer
| dots, the printers device unit, the unit for resolution is dots
| per inch (dpi).
| Error Conditions:
| A valid font is required. Margins that are outside the printable
| area will be corrected, invalid margins will raise an EPrinter
| exception.
| Created: 13.05.99 by P. Below
+------------------------------------------------------------}
function PrintStrings(Lines: TStrings;
const leftmargin, rightmargin,
topmargin, bottommargin: single;
const linesPerInch: single;
aFont: TFont;
measureonly: Boolean;
OnPrintheader,
OnPrintfooter: THeaderFooterProc): Integer;
var
continuePrint: Boolean; { continue/abort flag for callbacks }
pagecount: Integer; { number of current page }
textrect: TRect; { output area, in canvas coordinates }
headerrect: TRect; { area for header, in canvas
coordinates }
footerrect: TRect; { area for footes, in canvas
coordinates }
lineheight: Integer; { line spacing in dots }
charheight: Integer; { font height in dots }
textstart: Integer; { index of first line to print on
current page, 0-based. }
{ Calculate text output and header/footer rectangles. }
procedure CalcPrintRects;
var
X_resolution: Integer; { horizontal printer resolution, in dpi }
Y_resolution: Integer; { vertical printer resolution, in dpi }
pagerect: TRect; { total page, in paper coordinates }
printorigin: TPoint; { origin of canvas coordinate system in
paper coordinates. }
{ Get resolution, paper size and non-printable margin from
printer driver. }
procedure GetPrinterParameters;
begin
with Printer.Canvas do
begin
X_resolution := GetDeviceCaps(Handle, LOGPIXELSX);
Y_resolution := GetDeviceCaps(Handle, LOGPIXELSY);
printorigin.X := GetDeviceCaps(Handle, PHYSICALOFFSETX);
printorigin.Y := GetDeviceCaps(Handle, PHYSICALOFFSETY);
pagerect.Left := 0;
pagerect.Right := GetDeviceCaps(Handle, PHYSICALWIDTH);
pagerect.Top := 0;
pagerect.Bottom := GetDeviceCaps(Handle, PHYSICALHEIGHT);
end; { With }
end; { GetPrinterParameters }
{ Calculate area between the requested margins, paper-relative.
Adjust margins if they fall outside the printable area.
Validate the margins, raise EPrinter exception if no text area
is left. }
procedure CalcRects;
var
max: integer;
begin
with textrect do
begin
{ Figure textrect in paper coordinates }
Left := Round(leftmargin * X_resolution);
if Left < printorigin.x then
Left := printorigin.x;
Top := Round(topmargin * Y_resolution);
if Top < printorigin.y then
Top := printorigin.y;
{ Printer.PageWidth and PageHeight return the size of the
printable area, we need to add the printorigin to get the
edge of the printable area in paper coordinates. }
Right := pagerect.Right - Round(rightmargin * X_resolution);
max := Printer.PageWidth + printorigin.X;
if Right > max then
Right := max;
Bottom := pagerect.Bottom - Round(bottommargin *
Y_resolution);
max := Printer.PageHeight + printorigin.Y;
if Bottom > max then
Bottom := max;
{ Validate the margins. }
if (Left >= Right) or (Top >= Bottom) then
raise
EPrinter.Create('PrintString: the supplied margins are too large, there
' +
'is no area to print left on the page.');
end; { With }
{ Convert textrect to canvas coordinates. }
OffsetRect(textrect, -printorigin.X, -printorigin.Y);
{ Build header and footer rects. }
headerrect := Rect(textrect.Left, 0,
textrect.Right, textrect.Top);
footerrect := Rect(textrect.Left, textrect.Bottom,
textrect.Right, Printer.PageHeight);
end; { CalcRects }
begin { CalcPrintRects }
GetPrinterParameters;
CalcRects;
lineheight := round(Y_resolution / linesPerInch);
end; { CalcPrintRects }
{ Print a page with headers and footers. }
procedure PrintPage;
procedure FireHeaderFooterEvent(event: THeaderFooterProc; r: TRect);
begin
if Assigned(event) then
begin
event(Printer.Canvas,
pagecount,
r,
ContinuePrint);
{ Revert to our font, in case event handler changed
it. }
Printer.Canvas.Font := aFont;
end; { If }
end; { FireHeaderFooterEvent }
procedure DoHeader;
begin
FireHeaderFooterEvent(OnPrintHeader, headerrect);
end; { DoHeader }
procedure DoFooter;
begin
FireHeaderFooterEvent(OnPrintFooter, footerrect);
end; { DoFooter }
procedure DoPage;
var
y: integer;
begin
y := textrect.Top;
while (textStart < Lines.Count) and
(y <= (textrect.Bottom - charheight)) do
begin
{ Note: use TextRect instead of TextOut to effect clipping
of the line on the right margin. It is a bit slower,
though. The clipping rect would be
Rect( textrect.left, y, textrect.right, y+charheight). }
printer.Canvas.TextOut(textrect.Left, y, Lines[textStart]);
Inc(textStart);
Inc(y, lineheight);
end; { While }
end; { DoPage }
begin { PrintPage }
DoHeader;
if ContinuePrint then
begin
DoPage;
DoFooter;
if (textStart < Lines.Count) and ContinuePrint then
begin
Inc(pagecount);
Printer.NewPage;
end; { If }
end;
end; { PrintPage }
begin { PrintStrings }
Assert(Assigned(afont),
'PrintString: requires a valid aFont parameter!');
continuePrint := True;
pagecount := 1;
textstart := 0;
Printer.BeginDoc;
try
CalcPrintRects;
{$IFNDEF WIN32}
{ Fix for Delphi 1 bug. }
Printer.Canvas.Font.PixelsPerInch := Y_resolution;
{$ENDIF }
Printer.Canvas.Font := aFont;
charheight := printer.Canvas.TextHeight('�y');
while (textstart < Lines.Count) and ContinuePrint do
PrintPage;
finally
if continuePrint and not measureonly then
Printer.EndDoc
else
begin
Printer.Abort;
end;
end;
if continuePrint then
Result := pagecount
else
Result := 0;
end; { PrintStrings }
procedure TForm1.Button1Click(Sender: TObject);
begin
ShowMessage(Format('%d pages printed',
[PrintStrings(memo1.Lines,
0.75, 0.5, 0.75, 1,
6,
memo1.Font,
False,
PrintHeader, PrintFooter)
]));
end;
procedure TForm1.PrintFooter(aCanvas: TCanvas; aPageCount: integer;
aTextrect: TRect; var Continue: boolean);
var
S: string;
res: integer;
begin
with aCanvas do
begin
{ Draw a gray line one point wide below the text }
res := GetDeviceCaps(Handle, LOGPIXELSY);
pen.Style := psSolid;
pen.Color := clGray;
pen.Width := Round(res / 72);
MoveTo(aTextRect.Left, aTextRect.Top);
LineTo(aTextRect.Right, aTextRect.Top);
{ Print the page number in Arial 8pt, gray, on right side of
footer rect. }
S := Format('Page %d', [aPageCount]);
Font.Name := 'Arial';
Font.Size := 8;
Font.Color := clGray;
TextOut(aTextRect.Right - TextWidth(S), aTextRect.Top + res div
18,
S);
end;
end;
procedure TForm1.PrintHeader(aCanvas: TCanvas; aPageCount: integer;
aTextrect: TRect; var Continue: boolean);
var
res: Integer;
begin
with aCanvas do
begin
{ Draw a gray line one point wide 4 points above the text }
res := GetDeviceCaps(Handle, LOGPIXELSY);
pen.Style := psSolid;
pen.Color := clGray;
pen.Width := Round(res / 72);
MoveTo(aTextRect.Left, aTextRect.Bottom - res div 18);
LineTo(aTextRect.Right, aTextRect.Bottom - res div 18);
{ Print the company name in Arial 8pt, gray, on left side of
footer rect. }
Font.Name := 'Arial';
Font.Size := 8;
Font.Color := clGray;
TextOut(aTextRect.Left, aTextRect.Bottom - res div 10 -
TextHeight('W'),
'W. W. Shyster & Cie.');
end;
end;
end.
2005. december 22., csütörtök
Create an interfaced object with no automatic destruction
Problem/Question/Abstract:
If I want automatic garbage collection with interfaces, I use TInterfacedObject as base class. What should I use, if I don't want automatic destruction? Is there a similar common base class or do I have to implement the IInterface methods myself?
Answer:
{BaseNonRefcountIntfObjU:
This unit provides a base class with a non-reference counted
implementation of IUnknown.
Author: Dr. Peter Below
Version 1.0, created 28 M�rz 2002
Last modified: 28 M�rz 2002}
unit BaseNonRefcountIntfObjU;
interface
type
{Derive classes that need a non-reference counted IUNknown
implementation from this class.}
TNonRefcountInterfacedObject = class(TObject, IUnknown)
protected
{IUnknown}
function QueryInterface(const IID: TGUID; out Obj): HResult; stdcall;
function _AddRef: Integer; stdcall;
function _Release: Integer; stdcall;
end;
implementation
uses
Windows;
function TNonRefcountInterfacedObject.QueryInterface(const IID: TGUID; out Obj):
HResult;
begin
if GetInterface(IID, Obj) then
Result := S_OK
else
Result := E_NOINTERFACE;
end;
function TNonRefcountInterfacedObject._AddRef: Integer;
begin
Result := -1; {-1 indicates no reference counting is taking place}
end;
function TNonRefcountInterfacedObject._Release: Integer;
begin
Result := -1; {-1 indicates no reference counting is taking place}
end;
end.
If I want automatic garbage collection with interfaces, I use TInterfacedObject as base class. What should I use, if I don't want automatic destruction? Is there a similar common base class or do I have to implement the IInterface methods myself?
Answer:
{BaseNonRefcountIntfObjU:
This unit provides a base class with a non-reference counted
implementation of IUnknown.
Author: Dr. Peter Below
Version 1.0, created 28 M�rz 2002
Last modified: 28 M�rz 2002}
unit BaseNonRefcountIntfObjU;
interface
type
{Derive classes that need a non-reference counted IUNknown
implementation from this class.}
TNonRefcountInterfacedObject = class(TObject, IUnknown)
protected
{IUnknown}
function QueryInterface(const IID: TGUID; out Obj): HResult; stdcall;
function _AddRef: Integer; stdcall;
function _Release: Integer; stdcall;
end;
implementation
uses
Windows;
function TNonRefcountInterfacedObject.QueryInterface(const IID: TGUID; out Obj):
HResult;
begin
if GetInterface(IID, Obj) then
Result := S_OK
else
Result := E_NOINTERFACE;
end;
function TNonRefcountInterfacedObject._AddRef: Integer;
begin
Result := -1; {-1 indicates no reference counting is taking place}
end;
function TNonRefcountInterfacedObject._Release: Integer;
begin
Result := -1; {-1 indicates no reference counting is taking place}
end;
end.
2005. december 21., szerda
make a flickerless animation using CopyRect
Problem/Question/Abstract:
Make a flickerless animation using CopyRect
You will need an image, called ImageSprite, containing a sprite bitmap with
black as the background (the transparent part). You will also need an image,
called ImageMask, containing a black silouette of the sprite with white as the
background and an Image called ImageBackground containing the background
image. All these images are set to visible := false. Image1 is the image you
will see and is the same size as the background image.
Answer:
var
Form1: TForm1;
x, y, xvel, yvel, xold, yold: Integer;
implementation
{$R *.dfm}
{You will need an image, called ImageSprite, containing a sprite bitmap with
black as the background (the transparent part). You will also need an image,
called ImageMask, containing a black silouette of the sprite with white as the
background and an Image called ImageBackground containing the background
image. All these images are set to visible := false. Image1 is the image you
will see and is the same size as the background image.}
procedure TForm1.Button1Click(Sender: TObject);
var
ARect: TRect; // Destination/Source rectangles
begin
//Initialize sprites position/velocity
x := 0;
y := 100;
xvel := 3;
yvel := 2;
xold := 0;
yold := 0;
// copy background to the image
ARect := Rect(0, 0, ImageBackground.Width, ImageBackground.Height);
with Image1.Canvas do
begin
CopyMode := cmSrcCopy;
CopyRect(ARect, ImageBackground.Canvas, ARect);
end;
// start animation
Timer1.Enabled := True;
end;
procedure TForm1.Timer1Timer(Sender: TObject);
var
Dest, Sour: TRect; // Destination/Source rectangles
begin
// Erase sprite from old position
Sour := Rect(xold, yold, xold + ImageMask.Width, yold + ImageMask.Height);
with Image1.Canvas do
begin
CopyMode := cmSrcCopy;
CopyRect(Sour, ImageBackground.Canvas, Sour);
end;
// Draw new sprite
Sour := Rect(0, 0, ImageMask.Width, ImageMask.Height);
Dest := Rect(x, y, x + ImageMask.Width, y + ImageMask.Height);
with Image1.Canvas do
begin
// Place mask onto image
CopyMode := cmSrcAnd;
CopyRect(Dest, ImageMask.Canvas, Sour);
// Place sprite into mask
CopyMode := cmSrcPaint;
CopyRect(Dest, ImageSprite.Canvas, Sour);
end;
{if multiple sprites are being used, then erase them all before drawing them
all. Do not erase and draw each sprite in turn}
// store sprites old position before updating
xold := x;
yold := y;
{ Update sprites position (equations to describe movement of sprite }
Inc(x, xvel);
Inc(y, yvel);
if (x > ImageBackground.Width - ImageMask.Width) or (x < 0) then
xvel := -xvel;
if (y > ImageBackground.Height - ImageMask.Height) or (y < 0) then
yvel := -yvel;
end;
Make a flickerless animation using CopyRect
You will need an image, called ImageSprite, containing a sprite bitmap with
black as the background (the transparent part). You will also need an image,
called ImageMask, containing a black silouette of the sprite with white as the
background and an Image called ImageBackground containing the background
image. All these images are set to visible := false. Image1 is the image you
will see and is the same size as the background image.
Answer:
var
Form1: TForm1;
x, y, xvel, yvel, xold, yold: Integer;
implementation
{$R *.dfm}
{You will need an image, called ImageSprite, containing a sprite bitmap with
black as the background (the transparent part). You will also need an image,
called ImageMask, containing a black silouette of the sprite with white as the
background and an Image called ImageBackground containing the background
image. All these images are set to visible := false. Image1 is the image you
will see and is the same size as the background image.}
procedure TForm1.Button1Click(Sender: TObject);
var
ARect: TRect; // Destination/Source rectangles
begin
//Initialize sprites position/velocity
x := 0;
y := 100;
xvel := 3;
yvel := 2;
xold := 0;
yold := 0;
// copy background to the image
ARect := Rect(0, 0, ImageBackground.Width, ImageBackground.Height);
with Image1.Canvas do
begin
CopyMode := cmSrcCopy;
CopyRect(ARect, ImageBackground.Canvas, ARect);
end;
// start animation
Timer1.Enabled := True;
end;
procedure TForm1.Timer1Timer(Sender: TObject);
var
Dest, Sour: TRect; // Destination/Source rectangles
begin
// Erase sprite from old position
Sour := Rect(xold, yold, xold + ImageMask.Width, yold + ImageMask.Height);
with Image1.Canvas do
begin
CopyMode := cmSrcCopy;
CopyRect(Sour, ImageBackground.Canvas, Sour);
end;
// Draw new sprite
Sour := Rect(0, 0, ImageMask.Width, ImageMask.Height);
Dest := Rect(x, y, x + ImageMask.Width, y + ImageMask.Height);
with Image1.Canvas do
begin
// Place mask onto image
CopyMode := cmSrcAnd;
CopyRect(Dest, ImageMask.Canvas, Sour);
// Place sprite into mask
CopyMode := cmSrcPaint;
CopyRect(Dest, ImageSprite.Canvas, Sour);
end;
{if multiple sprites are being used, then erase them all before drawing them
all. Do not erase and draw each sprite in turn}
// store sprites old position before updating
xold := x;
yold := y;
{ Update sprites position (equations to describe movement of sprite }
Inc(x, xvel);
Inc(y, yvel);
if (x > ImageBackground.Width - ImageMask.Width) or (x < 0) then
xvel := -xvel;
if (y > ImageBackground.Height - ImageMask.Height) or (y < 0) then
yvel := -yvel;
end;
2005. december 20., kedd
Intercept Internet Explorer messages
Problem/Question/Abstract:
How to intercept Internet Explorer messages?
Answer:
This component allows you to intercept Internet Explorer messages such as "StatusTextChangeEvent", "DocumentCompleteEvent" and so on.
Component Download: http://www.baltsoft.com/files/dkb/attachment/IEEVENTS.ziphttp://www.baltsoft.com/files/dkb/attachment/IEEVENTS.zip
How to intercept Internet Explorer messages?
Answer:
This component allows you to intercept Internet Explorer messages such as "StatusTextChangeEvent", "DocumentCompleteEvent" and so on.
Component Download: http://www.baltsoft.com/files/dkb/attachment/IEEVENTS.ziphttp://www.baltsoft.com/files/dkb/attachment/IEEVENTS.zip
2005. december 19., hétfő
Copy an Excel range into a two-dimensional array
Problem/Question/Abstract:
How to copy an Excel range into a two-dimensional array
Answer:
Copy it to a variant, then read the resulting variant array. This will be much faster than reading from each Excel cell individually, and it will avoid an Excel resource leak that can be critical on Win9x systems.
{ ... }
var
ArrV: OleVariant;
{ ... }
ArrV := WS.UsedRange[LCID].Value2;
for Row := 1 to VarArrayHighBound(ArrV, 1) - 1 do
for Col := 1 to VarArrayHighBound(ArrV, 2) - 1 do
Memo1.Lines.Add(Format('Row: %d Col: %d %s', [Row, Col, VarToStr(ArrV[Row,
Col])]));
end;
{ ... }
How to copy an Excel range into a two-dimensional array
Answer:
Copy it to a variant, then read the resulting variant array. This will be much faster than reading from each Excel cell individually, and it will avoid an Excel resource leak that can be critical on Win9x systems.
{ ... }
var
ArrV: OleVariant;
{ ... }
ArrV := WS.UsedRange[LCID].Value2;
for Row := 1 to VarArrayHighBound(ArrV, 1) - 1 do
for Col := 1 to VarArrayHighBound(ArrV, 2) - 1 do
Memo1.Lines.Add(Format('Row: %d Col: %d %s', [Row, Col, VarToStr(ArrV[Row,
Col])]));
end;
{ ... }
2005. december 18., vasárnap
Word wrapped TButton
Problem/Question/Abstract:
Word wrapped TButton
Answer:
If you want to have your TButton objects displayed with wrapped caption, you will notice that this is not possible - not possible without a little trick.
Of course, you could search the web for some third-party component, but there's an easier way to accomplish this. Just follow these steps:
Put a TButton with empty caption on your form;
Create a TLabel with your desired caption and place it anywhere on the form;
Display the form as text (Alt+F12) and it will look as on the left side in the table;
Move the TLabel declaration into the TButton and change the coordinates since it is now relative to the button;
(idea from Richard B. Winston:) Select the button and then "Component|Create Component Template". After you choose a name and palette page for the template, you will be able to select the button with embedded label from the component palette and use it just like any other component.
(before step 4)
(after step 4)
object Button1: TButton
Left = 176
Top = 184
Width = 75
Height = 25
Caption = ''
TabOrder = 2
end
object Label1: TLabel
Left = 200
Top = 168
Width = 32
Height = 13
Caption = 'My long caption'
WordWrap = True
end
object Button1: TButton
Left = 176
Top = 184
Width = 75
Height = 25
Caption = ''
TabOrder = 2
object Label1: TLabel
Left = 2
Top = 2
Width = 32
Height = 13
Caption = 'My long caption'
WordWrap = True
end
end
2005. december 17., szombat
Various SQL / MS SQL Server Routines
Problem/Question/Abstract:
This is a bit of a departure from my normal style of Q & A, but I thought it would be useful for those of you who do a lot of database-related stuff.
Answer:
General Purpose Stuff
Face it, code reuse is big issue irrespective of programming in an object-oriented environment. Especially, with database application programming, the stuff you do over and over again can be a bit tedious. So, I've created a bunch of general purpose functions that I use in my code - a lot.
An On-the-Fly SELECT Statement Generator
The first function CreateSelect creates a SELECT or SELECT DISTINCT statement that can be used in whenever you create a TQuery for querying against a local table like Paradox. It's most useful for when you want to create a query from a table at runtime, but don't know the fields you want to include. For instance, I created an adhoc querying tool where users could select the fields they wanted displayed in a graph by dragging the field names from on list box into another. From there, I passed the selected fields list to CreateSelect and constructed a SELECT statement on the fly. It was a one-line call as opposed to the multiple lines I'd normally have to write for a query. Here's the code:
{==========================================================
This function will create a SELECT or SELECT DISTINCT SQL
statement given input from a TStrings descendant like a
list. It will properly format the list into field decla-
rations of a SQL statement then, using the supplied
TableNm parameter, will construct an entire statement that
can be assigned to the SQL property of a TQuery.
Params: Distinct SELECT DISTINCT or regular SELECT
TableNm Table name: Should either be a fully
qualified table name, or preceeded by
an alias (ie, ':DbName:MyTable.db')
FieldList Any TStrings descendant will work here,
like the Items property of a TListBox.
==========================================================}
function CreateSelect(Distinct: Boolean;
TableNm: string;
const FieldList: TStrings)
: TStrings;
var
Sql: TStringList;
I: Integer;
buf,
QueryType: string;
begin
//First, instantiate the SQL lines list
Sql := TStringList.Create;
//Determine whether or no this is a regular SELECT
//or a SELECT DISTINCT query.
if Distinct then
QueryType := 'SELECT '
else
QueryType := 'SELECT DISTINCT ';
buf := QueryType;
try
//Now add the fields to the select statement
//Notice that if we're on the last item,
//we don't want to add a trailing comma.
for I := 0 to (FieldList.Count - 1) do
if (I <> FieldList.Count - 1) then
buf := buf + FieldList[I] + ', '
else
buf := buf + FieldList[I];
//Now, put the query together
Sql.Add(buf);
Sql.Add('FROM "' + TableNm + '"');
Result := Sql;
finally
Sql.Free;
end;
end;
Here's a code snippet from one of my programs that implements the function:
var
qry: TQuery;
begin
qry := TQuery.Create(nil);
with qry do
begin
Active := False;
DatabaseName := 'MyLocalDatabase';
SQL := CreateSelect(True, ExtractFilePath(ParamStr(0))
+ 'Process.DB', lbSelectedFlds.Items);
try
Open;
....other code....
finally
Free;
end;
end;
end;
WHERE It Is....
I use a lot of TStrings types in my code because they make it easy to pass a bunch of values at once. Especially with selection criteria in queries, having the capability to select on multiple values is a boon to efficiency. The three functions below can be added to a WHERE clause in a SQL statement for multiple-value searching. All you need to do is assemble the search criteria into a TStrings type like a TStringList or use even the Items property of a TListBox to be able to use these functions. Respectively, they allow you to create a basic multiple-value criteria statement (i.e. (fldName = 'thisvalue') OR (fldName = 'thatvalue'); an IN selection criteria statement; and a multiple-value LIKE selection criteria statement. Here they are:
{Returns a '(FldName = FldValue) OR (FldName = FldValue)' etc string from
a list of values. Useful for translating TListBox values into SQL strings
IsValString is a boolean to test if the list values are a value string; that is,
it contains spaces, in which case, you would want double-quotes.}
function BuildSQLSetString(fldName: string; const List: TStrings;
IsValString: Boolean): string;
var
I: Integer;
buf: string;
begin
Result := '';
for I := 0 to (List.Count - 1) do
begin
if IsValString then
buf := '(' + fldName + ' = ''' + List[I] + ''') OR '
else
buf := '(' + fldName + ' = ' + List[I] + ') OR ';
Result := Result + buf;
end;
Result := Copy(Result, 1, Length(Result) - 4);
end;
//This will build an IN statement
function BuildSQLINString(fldName: string; const List: TStrings;
IsValString: Boolean): string;
var
I: Integer;
buf: string;
begin
Result := '';
for I := 0 to (List.Count - 1) do
if IsValString then
buf := buf + '''' + List[I] + ''', '
else
buf := buf + List[I] + ', ';
buf := Copy(buf, 1, Length(TrimRight(buf)) - 1);
Result := fldName + ' IN (' + buf + ')';
end;
//This will build a LIKE statement
function BuildSQLLikeString(fldName: string; const List: TStrings;
IsValString: Boolean): string;
var
I: Integer;
buf: string;
begin
Result := '';
for I := 0 to (List.Count - 1) do
begin
if IsValString then
buf := '(' + fldName + ' LIKE ''' + TrimRight(List[I]) + '%'') OR '
else
buf := '(' + fldName + ' LIKE ' + List[I] + '%) OR ';
Result := Result + buf;
end;
Result := Copy(Result, 1, Length(Result) - 4);
end;
Notice that in addition to the field name and value list, there's a parameter in each function called IsValString. Set this to true if the field you're searching on is a string field. Remember, discrete string values in SQL must be delimited by single quotes.
Some MS SQL Server Stuff
A little over a year ago, I moved completely away from doing local table processing with Paradox and started doing all my processing under a Client/Server environment using MS SQL Server. I was in for a big surprise when I made the switch because many of the things that I could do with Paradox tables that I took for granted, weren't as easily done in SQL Server. Yikes! So, what I did was create some generic routines specifically for Client/Server applications to make my life much easier. Let's see what I've got...
How Many Was That?
For those of you who work with local tables, you know how easy it is to get the number of records in a table: Simply connect a TTable object to the table in question and query the RecordCount property. Well, in SQL Server, that's not so easy because the idea of a "record" is non-existent in this set-based data environment. But, just because you can't get the information from the table directly, doesn't mean that it doesn't exist. In fact, the information is stored in the system tables. Here's a function that will get you the number of rows contained in a SQL Server table:
// =============================================================================
// Returns the SQL DB path of the specified BDE alias.
// =============================================================================
function GetSQLDBPath(const AliasName: ShortString): ShortString;
var
ParamList: TStrings; // List of parms from the BDE
Path: ShortString; // Path returned from the BDE
begin
Result := '';
ParamList := TStringList.Create;
try
Session.GetAliasParams(AliasName, ParamList);
Path := ParamList[0];
Result := Copy(Path, Pos('=', Path) + 1, Length(Path) - Pos('=', Path) + 1);
finally
ParamList.Free;
end;
end;
function GetSQLTableRows(SesName: string; DB: TDatabase; TableName: string): Integer;
var
qry: TQuery;
begin
qry := TQuery.Create(nil);
with qry do
begin
Active := False;
SessionName := sesName;
DatabaseName := DB.DatabaseName;
SQL.Add('SELECT DISTINCT I.Rows');
SQL.Add('FROM ' + GetSQLDBPath(DB.DatabaseName) + '..SysIndexes AS I INNER JOIN');
SQL.Add(' ' + GetSQLDBPath(DB.DatabaseName)
+ '..SysObjects AS O ON (I.ID = O.ID)');
SQL.Add('WHERE (O.Type = ''U'') AND (O.Name = ''' + TableName + ''')');
try
Open;
Result := FieldByName('Rows').AsInteger;
finally
Free;
end;
end;
end;
Some of you might be wondering: "Of what use is this function?" Well, for some of you, indeed, it might be of no use whatsoever. But in the type of applications I write that query datasets with records numbering in the several millions, in some steps, I only want to continue processing if my result sets aren't empty. This function gives me a quick way of checking if I need to continue or not. So there!
To Transact or Not To Transact (SQL, that is)
If you're using SQL Server, but not using Transact SQL, you're missing out on a lot of functionality. I know, I know, there are those cross-platform junkies out there that will only write the most generic code so they can deploy their DB apps on other servers. That's all well and good, but for the most of us, we only have a single server platform, and to not use its native functionality is to deprive ourselves of a lot of functionality. For instance, how many of you create temporary tables when doing a series of queries? C'mon, raise yer hands high! Using strict ANSI SQL with Delphi, you would have to create three objects: a TQuery to perform the query, a TBatchMove to move the result table, and a TTable to receive the results. Yikes! But with SQL Server, you can perform a SELECT INTO query use only a single object: a TQuery. Check out the code snippet from one of my programs below:
var
qry: TQuery;
begin
qry := TQuery.Create(nil);
with qry do
begin
Active := False;
SessionName := ClassSession.SessionName;
DatabaseName := DBName;
SQL.Add('SELECT DISTINCT T.PatientID, T.Symptom);
SQL.Add('INTO ' + EvalTemp1);
SQL.Add('FROM ' + SymptomTable + ' T (TABLOCK), HoldingTable H (TABLOCK)');
SQL.Add('WHERE (H.PatientID = T.PatientID) AND (Age > 65) ');
SQL.Add('AND (Thiazides_Now IS NULL) AND (GOUT IS NULL)');
try
ExecSQL;
finally
Free;
end;
end;
// ....the rest of the code....
This simple query above accomplishes with one object using Transact-SQL that it normally takes three objects to do with standard ANSI SQL. Notice that the query is executed using ExecSQL as opposed to Open. If you're using Transact-SQL, everything happens on the server, so you get no cursors back. That might present a problem in some circumstances, but for the most part, since you're doing nothing but set logic, having a cursor to a result set isn't necessary.
Not only does Transact-SQL make it shorter to do extracts, it has some cool syntax that allows you to really short-circuit both code and performance. For instance, one of the things that has always irked me about SQL is doing a two-table update; that is, updating a field in a table from values contained in another table. In Paradox, it's simple QBE query with matching example elements. In ANSI SQL, it involves a subquery. Let's look at an example:
Standard ANSI SQL two-table update:
UPDATE ClaimsTbl
SET History = (SELECT Activity
FROM ActivityTbl AS A
WHERE (ClaimsTbl.Patient = A.Patient))
Not too complex, but let me tell you, it's as slow as molasses on SQL Server. On the other hand, the following Transact-SQL UPDATE statement works lickety-split!
UPDATE ClaimsTbl
FROM ClaimsTbl C, Activity A
SET C.History = A.Activity
WHERE (C.Patient = A.Patient)
Not much different from the example above, but since SQL Server is equipped to deal with this syntax in an optimized fashion, it works much faster.
Why have I spent so much time covering this stuff? Well, I'm a real proponent of creating systems that run in the most optimized fashion I can make them. And that means that I use all the tools available to me. Yes, it can be argued that I'm locking myself into a specific platform's functionality, but since I only have one platform that I'm dealing with, why not use it? I realize that I haven't covered hardly any of the Transact-SQL syntax. If you've got it, I'll leave it up to you to go hunting for the information (BTW, a great source is the SQL Server Books Online reference that comes with the software). The bottom line is this: If you're building systems that address a single server platform, make the best use of that server's capabilities.
But Wait! There's More!
Below are some general purpose routines that I use on a regular basis for accessing my SQL Server databases. Check 'em out:
//Uses Session.GetTableNames to get a list of tables from the specified database
procedure GetTableList(DBName: string; const TableList: TStrings);
var
db: TDatabase;
begin
db := TDatabase.Create(Application);
with db do
begin
DatabaseName := DBName;
LoginPrompt := False;
Connected := True;
end; { with }
try
Session.GetTableNames(db.DatabaseName, '', False, False, TableList);
db.Close;
finally
db.Free;
end;
end;
//Uses GetTableList to see if a particular table exists in database.
function TableExists(var ProcSession: TSession; var DB: TDatabase;
TableName: string): Boolean;
var
TableList: TStrings;
begin
Result := False;
TableList := TStringList.Create;
try
ProcSession.GetTableNames(DB.DatabaseName, '', False, False, TableList);
if (TableList.IndexOf(TableName) > 0) then
Result := True;
finally
TableList.Free;
end;
end;
//Performs a series of drops for all table names contained in the input array.
//Very useful for cleaning up a bunch of temporary tables at once.
procedure CleanMSSQLTbl(var ProcSession: TSession; DBName: string;
TableNames: array of string); overload;
var
sqlEI: TQuery;
I: Integer;
begin
for I := Low(TableNames) to High(TableNames) do
begin
sqlEI := TQuery.Create(nil);
with sqlEI do
begin
SessionName := ProcSession.SessionName;
DatabaseName := DBName;
with SQL do
begin
Add('if exists (select * from sysobjects where ' +
'id = object_id(''' + TableNames[I] + ''') and sysstat & 0xf = 3)');
Add('drop table ' + TableNames[I]);
try
ExecSQL;
finally
Free;
end;
end;
end;
end;
end;
//Will return a TStrings list containing the results of a query
function SQLLoadList(SesName, TblName, FldName: string): TStrings;
var
qry: TQuery;
begin
Result := TStringList.Create;
qry := TQuery.Create(nil);
with qry do
begin
Active := False;
if (SesName <> '') then
SessionName := SesName;
DatabaseName := ExtractFilePath(TblName);
SQL.Add('SELECT DISTINCT ' + FldName);
SQL.Add('FROM "' + TblName + '"');
try
Open;
while not EOF do
begin
Result.Add(FieldByName(FldName).AsString);
Next;
end;
finally
Free;
end;
end;
end;
Notice in most of the functions above, that they either require a TSession or a TSession.SessionName as one of their formal parameters. This is because these functions are thread-safe. In order to use these in a multi- threaded system, you need to create a TSession instance for every thread, and database access within the scope of the thread require a session name to operate under. Otherwise you'll get access violations. Not good.
Well, that's it for now. I encourage you to use these functions and concepts in your own code. Believe me, they've saved me a lot of time!
2005. december 16., péntek
Valid disk in drive A: ?
Problem/Question/Abstract:
Valid disk in drive A: ?
Answer:
This function returns whether a drive's state = whether it contains
no disk
an unformatted disk
an empty disk
a disk with files
type
TDriveState = (DSNODISK, DSUNFORMATTEDDISK, DSEMPTYDISK, DSDISK_WITHFILES);
function DriveState(driveletter: Char): TDriveState;
var
mask: string[6];
sRec: TSearchRec;
oldMode: Cardinal;
retcode: Integer;
begin
oldMode: = SetErrorMode(SEM_FAILCRITICALERRORS);
mask := '?:\*.*';
mask[1] := driveletter;
{$I-}
retcode := FindFirst(mask, faAnyfile, SRec);
FindClose(SRec);
{$I+}
case retcode of
0: Result := DSDISK_WITHFILES; { at least one file was found }
-18: Result := DSEMPTYDISK; { no files, but disk is ok }
-21, -3: Result := DSNODISK; { DOS ERRORNOTREADY in WinNT,
ERRORPATH_NOTFOUND in 3.1 }
else
Result := DSUNFORMATTEDDISK; { unformatted disk in drive }
end;
SetErrorMode(oldMode);
end; { DriveState }
2005. december 15., csütörtök
Take Full Control Over ICQ
Problem/Question/Abstract:
Hi,
this is a full component source code that you can used to connect to ICQ© servers and do whatever you want, please notice, this is the code that is used by all programs available at http://www.8th-wonder.net .
Please do not ask me HOW to use the code, and notice that i posted here for EDUCATIONAL PORPUSES ONLY !!!
Answer:
unit IcqUdp;
{$TYPEDADDRESS OFF} // Unit must be compiled without type-checked pointers.
interface
uses Windows, ActiveX, Classes, Graphics, OleServer, OleCtrls, StdVCL;
const
// TypeLibrary Major and minor versions
IcqUdpCtlMajorVersion = 1;
IcqUdpCtlMinorVersion = 0;
LIBID_IcqUdpCtl: TGUID = '{0A563493-2028-11D5-A2A7-00105A8619E7}';
IID__IcqUdp: TGUID = '{0A56349F-2028-11D5-A2A7-00105A8619E7}';
DIID___IcqUdp: TGUID = '{0A5634A2-2028-11D5-A2A7-00105A8619E7}';
IID__proppgGeneral: TGUID = '{0A5634AB-2028-11D5-A2A7-00105A8619E7}';
CLASS_proppgGeneral: TGUID = '{0A5634AC-2028-11D5-A2A7-00105A8619E7}';
IID__clsIcqUtilities: TGUID = '{0A563494-2028-11D5-A2A7-00105A8619E7}';
CLASS_clsIcqUtilities: TGUID = '{0A563495-2028-11D5-A2A7-00105A8619E7}';
CLASS_IcqUdp: TGUID = '{0A5634A0-2028-11D5-A2A7-00105A8619E7}';
type
enumInfoGender = TOleEnum;
const
icqMale = $00000002;
icqFemale = $00000001;
icqNotSpecified = $00000000;
// Constants for enum enumMessageType
type
enumMessageType = TOleEnum;
const
icqMsgText = $00000001;
icqMsgChatReq = $00000002;
icqMsgFile = $00000003;
icqMsgURL = $00000004;
icqMsgAuthReq = $00000006;
icqMsgAuthDecline = $00000007;
icqMsgAuthAccept = $00000008;
icqMsgAdded = $0000000C;
icqMsgWebpager = $0000000D;
icqMsgExpress = $0000000E;
icqMsgContact = $00000013;
// Constants for enum enumOnlineState
type
enumOnlineState = TOleEnum;
const
icqOnline = $00000000;
icqAway = $00000001;
icqNa = $00000005;
icqOccupied = $00000011;
icqDND = $00000013;
icqChat = $00000020;
icqInvisible = $00000100;
// Constants for enum enumUseTCP
type
enumUseTCP = TOleEnum;
const
icqNoTCP = $00000001;
icqTCPSendOnly = $00000002;
icqTCPSendRecv = $00000004;
// Constants for enum enumRandomGroup
type
enumRandomGroup = TOleEnum;
const
icqGrpGeneral = $00000001;
icqGrpRomance = $00000002;
icqGrpGames = $00000003;
icqGrpStudents = $00000004;
icqGrp20Something = $00000006;
icqGrp30Something = $00000007;
icqGrp40Something = $00000008;
icqGrp50Over = $00000009;
icqGrpManRequestWoman = $0000000A;
icqGrpWomanRequestMan = $0000000B;
// Constants for enum enumConnectionSate
type
enumConnectionSate = TOleEnum;
const
icqDisconnected = $00000000;
icqRegistering = $00000001;
icqLogin = $00000002;
icqConnected = $00000003;
// Constants for enum enumSearchResult
type
enumSearchResult = TOleEnum;
const
icqSearchUserFound = $00000000;
icqSearchDone = $00000001;
icqSearchTooMany = $00000002;
// Constants for enum enumInfoType
type
enumInfoType = TOleEnum;
const
icqNewUser = $00000000;
icqBasic = $00000001;
icqMain = $00000002;
icqMore = $00000003;
icqMetaMore = $0000000B;
icqWork = $00000004;
icqInterest = $00000005;
icqAffiliations = $00000006;
icqAbout = $00000007;
icqSecurity = $00000008;
icqHPCategory = $00000009;
icqall = $0000000A;
// Constants for enum enumErrorConstant
type
enumErrorConstant = TOleEnum;
const
icqErrNotConnected = $00000001;
icqErrWrongPassword = $00000002;
icqErrTryAgain = $00000003;
icqErrGoAway = $00000004;
icqErrInvalidUIN = $00000005;
type
// *********************************************************************//
// Forward declaration of types defined in TypeLibrary
// *********************************************************************//
_IcqUdp = interface;
_IcqUdpDisp = dispinterface;
__IcqUdp = dispinterface;
_proppgGeneral = interface;
_proppgGeneralDisp = dispinterface;
_clsIcqUtilities = interface;
_clsIcqUtilitiesDisp = dispinterface;
// *********************************************************************//
// Declaration of CoClasses defined in Type Library
// (NOTE: Here we map each CoClass to its Default Interface)
// *********************************************************************//
proppgGeneral = _proppgGeneral;
clsIcqUtilities = _clsIcqUtilities;
IcqUdp = _IcqUdp;
// *********************************************************************//
// Declaration of structures, unions and aliases.
// *********************************************************************//
typContactInfo = packed record
lngUIN: Integer;
strNickname: WideString;
strFirstName: WideString;
strLastName: WideString;
strEmail: WideString;
strEmail2: WideString;
strEmail3: WideString;
strCity: WideString;
strState: WideString;
strPhone: WideString;
strFax: WideString;
strStreet: WideString;
strCellular: WideString;
lngZip: Integer;
intCountryCode: Smallint;
byteTimeZone: Byte;
bEmailHide: WordBool;
intAge: Smallint;
byteGender: Byte;
strHomepageURL: WideString;
byteBirthYear: Byte;
byteBirthMonth: Byte;
byteBirthDay: Byte;
byteLanguage1: Byte;
byteLanguage2: Byte;
byteLanguage3: Byte;
strAboutInfo: WideString;
strWorkCity: WideString;
strWorkState: WideString;
strWorkPhone: WideString;
strWorkFax: WideString;
strWorkAddress: WideString;
lngWorkZip: Integer;
intWorkCountry: Smallint;
strWorkName: WideString;
strWorkDepartment: WideString;
strWorkPosition: WideString;
intWorkOccupation: Smallint;
strWorkWebURL: WideString;
byteInterestTotal: Byte;
intInterestCategory: array[0..3] of Smallint;
strInterestName: array[0..3] of WideString;
byteBackgroundTotal: Byte;
intBackgroundCategory: array[0..3] of Smallint;
strBackgroundName: array[0..3] of WideString;
byteOrganizationTotal: Byte;
intOrganizationCategory: array[0..3] of Smallint;
strOrganizationName: array[0..3] of WideString;
byteHPCategoryTotal: Byte;
intHPCategoryCategory: array[0..3] of Smallint;
strHPCategoryName: array[0..3] of WideString;
bAuthorize: WordBool;
bWebPresence: WordBool;
bPublishIP: WordBool;
end;
// *********************************************************************//
// Interface: _IcqUdp
// Flags: (4560) Hidden Dual NonExtensible OleAutomation Dispatchable
// GUID: {0A56349F-2028-11D5-A2A7-00105A8619E7}
// *********************************************************************//
_IcqUdp = interface(IDispatch)
['{0A56349F-2028-11D5-A2A7-00105A8619E7}']
procedure Connect; safecall;
procedure Disconnect; safecall;
procedure Register(var Password: WideString); safecall;
procedure ChangePassword(var Password: WideString); safecall;
function SendAdded(uin: Integer; var Nickname: WideString; var EmailAddress:
WideString): Smallint; safecall;
procedure ContactAdd(var UINList: PSafeArray); safecall;
procedure VisibleAdd(var UINList: PSafeArray); safecall;
procedure InvisibleAdd(var UINList: PSafeArray); safecall;
procedure VisibleRemove(var UINList: PSafeArray); safecall;
procedure InvisibleRemove(var UINList: PSafeArray); safecall;
procedure InfoRequestBasic(uin: Integer); safecall;
procedure InfoRequestMore(uin: Integer); safecall;
procedure InfoRequestAll(uin: Integer); safecall;
procedure InfoUpdate(InfoUpdateType: enumInfoType; var InfoDetail: TGUID);
safecall;
procedure SearchUin(uin: Integer); safecall;
procedure SearchName(const Nickname: WideString; const Firstname: WideString;
const Lastname: WideString); safecall;
procedure SearchEmail(const EmailAddress: WideString); safecall;
function SendText(uin: Integer; const Message: WideString): Smallint; safecall;
function SendURL(uin: Integer; const URLAddress: WideString; const URLDescription:
WideString): Smallint; safecall;
function SendAuthReq(uin: Integer; const Nickname: WideString; const Firstname:
WideString;
const Lastname: WideString; const EmailAddress: WideString;
const Reason: WideString): Smallint; safecall;
function SendAuthAccept(uin: Integer): Smallint; safecall;
function SendAuthDecline(uin: Integer; const Reason: WideString): Smallint;
safecall;
function SendContact(uin: Integer; UINList: OleVariant; NickList: OleVariant):
Smallint; safecall;
function SendUserAdd(uin: Integer): Smallint; safecall;
function Get_UserUin: Integer; safecall;
procedure Set_UserUin(Param1: Integer); safecall;
function Get_UserPassword: WideString; safecall;
procedure Set_UserPassword(const Param1: WideString); safecall;
function Get_LocalIP: WideString; safecall;
procedure Set_LocalIP(const Param1: WideString); safecall;
function Get_LocalRealIP: WideString; safecall;
procedure Set_LocalRealIP(const Param1: WideString); safecall;
function Get_LocalPort: Smallint; safecall;
procedure Set_LocalPort(Param1: Smallint); safecall;
function Get_RemoteHost: WideString; safecall;
procedure Set_RemoteHost(const Param1: WideString); safecall;
function Get_RemotePort: Smallint; safecall;
procedure Set_RemotePort(Param1: Smallint); safecall;
function Get_UseTCP: enumUseTCP; safecall;
procedure Set_UseTCP(Param1: enumUseTCP); safecall;
function Get_SocketState: enumConnectionSate; safecall;
procedure Set_SocketState(Param1: enumConnectionSate); safecall;
function Get_OnlineState: enumOnlineState; safecall;
procedure Set_OnlineState(Param1: enumOnlineState); safecall;
procedure ShowAboutBox; safecall;
property UserUin: Integer read Get_UserUin write Set_UserUin;
property UserPassword: WideString read Get_UserPassword write Set_UserPassword;
property LocalIP: WideString read Get_LocalIP write Set_LocalIP;
property LocalRealIP: WideString read Get_LocalRealIP write Set_LocalRealIP;
property LocalPort: Smallint read Get_LocalPort write Set_LocalPort;
property RemoteHost: WideString read Get_RemoteHost write Set_RemoteHost;
property RemotePort: Smallint read Get_RemotePort write Set_RemotePort;
property UseTCP: enumUseTCP read Get_UseTCP write Set_UseTCP;
property SocketState: enumConnectionSate read Get_SocketState write
Set_SocketState;
property OnlineState: enumOnlineState read Get_OnlineState write Set_OnlineState;
end;
// *********************************************************************//
// DispIntf: _IcqUdpDisp
// Flags: (4560) Hidden Dual NonExtensible OleAutomation Dispatchable
// GUID: {0A56349F-2028-11D5-A2A7-00105A8619E7}
// *********************************************************************//
_IcqUdpDisp = dispinterface
['{0A56349F-2028-11D5-A2A7-00105A8619E7}']
procedure Connect; dispid 1610809366;
procedure Disconnect; dispid 1610809367;
procedure Register(var Password: WideString); dispid 1610809368;
procedure ChangePassword(var Password: WideString); dispid 1610809369;
function SendAdded(uin: Integer; var Nickname: WideString; var EmailAddress:
WideString): Smallint; dispid 1610809370;
procedure ContactAdd(var UINList: {??PSafeArray} OleVariant); dispid 1610809371;
procedure VisibleAdd(var UINList: {??PSafeArray} OleVariant); dispid 1610809372;
procedure InvisibleAdd(var UINList: {??PSafeArray} OleVariant); dispid 1610809373;
procedure VisibleRemove(var UINList: {??PSafeArray} OleVariant); dispid
1610809374;
procedure InvisibleRemove(var UINList: {??PSafeArray} OleVariant); dispid
1610809375;
procedure InfoRequestBasic(uin: Integer); dispid 1610809376;
procedure InfoRequestMore(uin: Integer); dispid 1610809377;
procedure InfoRequestAll(uin: Integer); dispid 1610809378;
procedure InfoUpdate(InfoUpdateType: enumInfoType; var InfoDetail: {??TGUID}
OleVariant); dispid 1610809379;
procedure SearchUin(uin: Integer); dispid 1610809380;
procedure SearchName(const Nickname: WideString; const Firstname: WideString;
const Lastname: WideString); dispid 1610809381;
procedure SearchEmail(const EmailAddress: WideString); dispid 1610809382;
function SendText(uin: Integer; const Message: WideString): Smallint; dispid
1610809383;
function SendURL(uin: Integer; const URLAddress: WideString; const URLDescription:
WideString): Smallint; dispid 1610809384;
function SendAuthReq(uin: Integer; const Nickname: WideString; const Firstname:
WideString;
const Lastname: WideString; const EmailAddress: WideString;
const Reason: WideString): Smallint; dispid 1610809385;
function SendAuthAccept(uin: Integer): Smallint; dispid 1610809386;
function SendAuthDecline(uin: Integer; const Reason: WideString): Smallint; dispid
1610809387;
function SendContact(uin: Integer; UINList: OleVariant; NickList: OleVariant):
Smallint; dispid 1610809388;
function SendUserAdd(uin: Integer): Smallint; dispid 1610809389;
property UserUin: Integer dispid 1745027081;
property UserPassword: WideString dispid 1745027080;
property LocalIP: WideString dispid 1745027079;
property LocalRealIP: WideString dispid 1745027078;
property LocalPort: Smallint dispid 1745027077;
property RemoteHost: WideString dispid 1745027076;
property RemotePort: Smallint dispid 1745027075;
property UseTCP: enumUseTCP dispid 1745027074;
property SocketState: enumConnectionSate dispid 1745027073;
property OnlineState: enumOnlineState dispid 1745027072;
procedure ShowAboutBox; dispid - 552;
end;
// *********************************************************************//
// DispIntf: __IcqUdp
// Flags: (4240) Hidden NonExtensible Dispatchable
// GUID: {0A5634A2-2028-11D5-A2A7-00105A8619E7}
// *********************************************************************//
__IcqUdp = dispinterface
['{0A5634A2-2028-11D5-A2A7-00105A8619E7}']
procedure Connected; dispid 1;
procedure Disconnected; dispid 2;
procedure Registered; dispid 3;
procedure ContactOnline(var uin: Integer; var OnlineState: enumOnlineState;
var IntIP: WideString; var ExtIP: WideString; var ExtPort: Integer;
var bTcpCapable: WordBool; var TcpVersion: Integer); dispid 4;
procedure ContactStatusChange(var uin: Integer; var State: enumOnlineState);
dispid 5;
procedure ContactOffline(var uin: Integer); dispid 6;
procedure InfoReply(var InfoType: enumInfoType; var Info: {??TGUID} OleVariant);
dispid 7;
procedure SearchReply(var uin: Integer; var Nick: WideString; var First:
WideString;
var Last: WideString; var Email: WideString; var bAuth: WordBool;
var SearchResult: enumSearchResult); dispid 8;
procedure MessageReceived(var uin: Integer; var MsgDate: TDateTime; var MsgTime:
WideString;
var MsgType: enumMessageType; var MsgText: WideString;
var URLAddress: WideString; var URLDescription: WideString;
var authNick: WideString; var authFirst: WideString;
var authLast: WideString; var authEmail: WideString;
var authReason: WideString; var contNick: OleVariant;
var contUin: OleVariant); dispid 9;
procedure ErrorFound(var Number: enumErrorConstant; var Description: WideString);
dispid 10;
procedure PacketAcknowledge(var PacketSeq: Smallint); dispid 11;
procedure DebugOut(var DebugTxt: WideString); dispid 12;
end;
// *********************************************************************//
// Interface: _proppgGeneral
// Flags: (4560) Hidden Dual NonExtensible OleAutomation Dispatchable
// GUID: {0A5634AB-2028-11D5-A2A7-00105A8619E7}
// *********************************************************************//
_proppgGeneral = interface(IDispatch)
['{0A5634AB-2028-11D5-A2A7-00105A8619E7}']
end;
// *********************************************************************//
// DispIntf: _proppgGeneralDisp
// Flags: (4560) Hidden Dual NonExtensible OleAutomation Dispatchable
// GUID: {0A5634AB-2028-11D5-A2A7-00105A8619E7}
// *********************************************************************//
_proppgGeneralDisp = dispinterface
['{0A5634AB-2028-11D5-A2A7-00105A8619E7}']
end;
// *********************************************************************//
// Interface: _clsIcqUtilities
// Flags: (4560) Hidden Dual NonExtensible OleAutomation Dispatchable
// GUID: {0A563494-2028-11D5-A2A7-00105A8619E7}
// *********************************************************************//
_clsIcqUtilities = interface(IDispatch)
['{0A563494-2028-11D5-A2A7-00105A8619E7}']
function GetCountryName(var Code: Smallint): WideString; safecall;
function GetCountryCode(var Index: Smallint): Smallint; safecall;
function GetCountryIndex(var CntryCode: Smallint): Smallint; safecall;
function GetLangName(var Index: Smallint): WideString; safecall;
function GetOccupationName(var Code: Smallint): WideString; safecall;
function GetOccupationCode(var Index: Smallint): Smallint; safecall;
function GetOccupationIndex(var OccupationCode: Smallint): Smallint; safecall;
function GetPastBackgroundName(var Code: Smallint): WideString; safecall;
function GetPastBackgroundCode(var Index: Smallint): Smallint; safecall;
function GetPastBackgroundIndex(var PastBackgroundCode: Smallint): Smallint;
safecall;
function GetAffiliationsName(var Code: Smallint): WideString; safecall;
function GetAffiliationsCode(var Index: Smallint): Smallint; safecall;
function GetAffiliationsIndex(var AffiliationsCode: Smallint): Smallint; safecall;
function GetTimeZone(Code: Byte): WideString; safecall;
function GetTimeCode(const strTime: WideString): Byte; safecall;
end;
// *********************************************************************//
// DispIntf: _clsIcqUtilitiesDisp
// Flags: (4560) Hidden Dual NonExtensible OleAutomation Dispatchable
// GUID: {0A563494-2028-11D5-A2A7-00105A8619E7}
// *********************************************************************//
_clsIcqUtilitiesDisp = dispinterface
['{0A563494-2028-11D5-A2A7-00105A8619E7}']
function GetCountryName(var Code: Smallint): WideString; dispid 1610809345;
function GetCountryCode(var Index: Smallint): Smallint; dispid 1610809346;
function GetCountryIndex(var CntryCode: Smallint): Smallint; dispid 1610809347;
function GetLangName(var Index: Smallint): WideString; dispid 1610809348;
function GetOccupationName(var Code: Smallint): WideString; dispid 1610809349;
function GetOccupationCode(var Index: Smallint): Smallint; dispid 1610809350;
function GetOccupationIndex(var OccupationCode: Smallint): Smallint; dispid
1610809351;
function GetPastBackgroundName(var Code: Smallint): WideString; dispid 1610809352;
function GetPastBackgroundCode(var Index: Smallint): Smallint; dispid 1610809353;
function GetPastBackgroundIndex(var PastBackgroundCode: Smallint): Smallint;
dispid 1610809354;
function GetAffiliationsName(var Code: Smallint): WideString; dispid 1610809355;
function GetAffiliationsCode(var Index: Smallint): Smallint; dispid 1610809356;
function GetAffiliationsIndex(var AffiliationsCode: Smallint): Smallint; dispid
1610809357;
function GetTimeZone(Code: Byte): WideString; dispid 1610809358;
function GetTimeCode(const strTime: WideString): Byte; dispid 1610809359;
end;
// *********************************************************************//
// The Class CoproppgGeneral provides a Create and CreateRemote method to
// create instances of the default interface _proppgGeneral exposed by
// the CoClass proppgGeneral. The functions are intended to be used by
// clients wishing to automate the CoClass objects exposed by the
// server of this typelibrary.
// *********************************************************************//
CoproppgGeneral = class
class function Create: _proppgGeneral;
class function CreateRemote(const MachineName: string): _proppgGeneral;
end;
// *********************************************************************//
// The Class CoclsIcqUtilities provides a Create and CreateRemote method to
// create instances of the default interface _clsIcqUtilities exposed by
// the CoClass clsIcqUtilities. The functions are intended to be used by
// clients wishing to automate the CoClass objects exposed by the
// server of this typelibrary.
// *********************************************************************//
CoclsIcqUtilities = class
class function Create: _clsIcqUtilities;
class function CreateRemote(const MachineName: string): _clsIcqUtilities;
end;
// *********************************************************************//
// OLE Server Proxy class declaration
// Server Object : TclsIcqUtilities
// Help String :
// Default Interface: _clsIcqUtilities
// Def. Intf. DISP? : No
// Event Interface:
// TypeFlags : (2) CanCreate
// *********************************************************************//
{$IFDEF LIVE_SERVER_AT_DESIGN_TIME}
TclsIcqUtilitiesProperties = class;
{$ENDIF}
TclsIcqUtilities = class(TOleServer)
private
FIntf: _clsIcqUtilities;
{$IFDEF LIVE_SERVER_AT_DESIGN_TIME}
FProps: TclsIcqUtilitiesProperties;
function GetServerProperties: TclsIcqUtilitiesProperties;
{$ENDIF}
function GetDefaultInterface: _clsIcqUtilities;
protected
procedure InitServerData; override;
public
constructor Create(AOwner: TComponent); override;
destructor Destroy; override;
procedure Connect; override;
procedure ConnectTo(svrIntf: _clsIcqUtilities);
procedure Disconnect; override;
function GetCountryName(var Code: Smallint): WideString;
function GetCountryCode(var Index: Smallint): Smallint;
function GetCountryIndex(var CntryCode: Smallint): Smallint;
function GetLangName(var Index: Smallint): WideString;
function GetOccupationName(var Code: Smallint): WideString;
function GetOccupationCode(var Index: Smallint): Smallint;
function GetOccupationIndex(var OccupationCode: Smallint): Smallint;
function GetPastBackgroundName(var Code: Smallint): WideString;
function GetPastBackgroundCode(var Index: Smallint): Smallint;
function GetPastBackgroundIndex(var PastBackgroundCode: Smallint): Smallint;
function GetAffiliationsName(var Code: Smallint): WideString;
function GetAffiliationsCode(var Index: Smallint): Smallint;
function GetAffiliationsIndex(var AffiliationsCode: Smallint): Smallint;
function GetTimeZone(Code: Byte): WideString;
function GetTimeCode(const strTime: WideString): Byte;
property DefaultInterface: _clsIcqUtilities read GetDefaultInterface;
published
{$IFDEF LIVE_SERVER_AT_DESIGN_TIME}
property Server: TclsIcqUtilitiesProperties read GetServerProperties;
{$ENDIF}
end;
{$IFDEF LIVE_SERVER_AT_DESIGN_TIME}
// *********************************************************************//
// OLE Server Properties Proxy Class
// Server Object : TclsIcqUtilities
// (This object is used by the IDE's Property Inspector to allow editing
// of the properties of this server)
// *********************************************************************//
TclsIcqUtilitiesProperties = class(TPersistent)
private
FServer: TclsIcqUtilities;
function GetDefaultInterface: _clsIcqUtilities;
constructor Create(AServer: TclsIcqUtilities);
protected
public
property DefaultInterface: _clsIcqUtilities read GetDefaultInterface;
published
end;
{$ENDIF}
// *********************************************************************//
// OLE Control Proxy class declaration
// Control Name : TIcqUdp
// Help String :
// Default Interface: _IcqUdp
// Def. Intf. DISP? : No
// Event Interface: __IcqUdp
// TypeFlags : (32) Control
// *********************************************************************//
TIcqUdpContactOnline = procedure(Sender: TObject; var uin: Integer;
var OnlineState: enumOnlineState;
var IntIP: WideString; var ExtIP: WideString;
var ExtPort: Integer;
var bTcpCapable: WordBool;
var TcpVersion: Integer) of object;
TIcqUdpContactStatusChange = procedure(Sender: TObject; var uin: Integer;
var State: enumOnlineState) of object;
TIcqUdpContactOffline = procedure(Sender: TObject; var uin: Integer) of object;
TIcqUdpInfoReply = procedure(Sender: TObject; var InfoType: enumInfoType;
var Info: {??TGUID} OleVariant) of object;
TIcqUdpSearchReply = procedure(Sender: TObject; var uin: Integer; var Nick:
WideString;
var First: WideString; var Last: WideString;
var Email: WideString; var bAuth: WordBool;
var SearchResult: enumSearchResult) of object;
TIcqUdpMessageReceived = procedure(Sender: TObject; var uin: Integer; var MsgDate:
TDateTime;
var MsgTime: WideString;
var MsgType: enumMessageType;
var MsgText: WideString;
var URLAddress: WideString;
var URLDescription: WideString;
var authNick: WideString;
var authFirst: WideString;
var authLast: WideString;
var authEmail: WideString;
var authReason: WideString;
var contNick: OleVariant;
var contUin: OleVariant) of object;
TIcqUdpErrorFound = procedure(Sender: TObject; var Number: enumErrorConstant;
var Description: WideString) of object;
TIcqUdpPacketAcknowledge = procedure(Sender: TObject; var PacketSeq: Smallint) of
object;
TIcqUdpDebugOut = procedure(Sender: TObject; var DebugTxt: WideString) of object;
TIcqUdp = class(TOleControl)
private
FOnConnected: TNotifyEvent;
FOnDisconnected: TNotifyEvent;
FOnRegistered: TNotifyEvent;
FOnContactOnline: TIcqUdpContactOnline;
FOnContactStatusChange: TIcqUdpContactStatusChange;
FOnContactOffline: TIcqUdpContactOffline;
FOnInfoReply: TIcqUdpInfoReply;
FOnSearchReply: TIcqUdpSearchReply;
FOnMessageReceived: TIcqUdpMessageReceived;
FOnErrorFound: TIcqUdpErrorFound;
FOnPacketAcknowledge: TIcqUdpPacketAcknowledge;
FOnDebugOut: TIcqUdpDebugOut;
FIntf: _IcqUdp;
function GetControlInterface: _IcqUdp;
protected
procedure CreateControl;
procedure InitControlData; override;
public
procedure Connect;
procedure Disconnect;
procedure Register(var Password: WideString);
procedure ChangePassword(var Password: WideString);
function SendAdded(uin: Integer; var Nickname: WideString; var EmailAddress:
WideString): Smallint;
procedure ContactAdd(var UINList: PSafeArray);
procedure VisibleAdd(var UINList: PSafeArray);
procedure InvisibleAdd(var UINList: PSafeArray);
procedure VisibleRemove(var UINList: PSafeArray);
procedure InvisibleRemove(var UINList: PSafeArray);
procedure InfoRequestBasic(uin: Integer);
procedure InfoRequestMore(uin: Integer);
procedure InfoRequestAll(uin: Integer);
procedure InfoUpdate(InfoUpdateType: enumInfoType; var InfoDetail: TGUID);
procedure SearchUin(uin: Integer);
procedure SearchName(const Nickname: WideString; const Firstname: WideString;
const Lastname: WideString);
procedure SearchEmail(const EmailAddress: WideString);
function SendText(uin: Integer; const Message: WideString): Smallint;
function SendURL(uin: Integer; const URLAddress: WideString; const URLDescription:
WideString): Smallint;
function SendAuthReq(uin: Integer; const Nickname: WideString; const Firstname:
WideString;
const Lastname: WideString; const EmailAddress: WideString;
const Reason: WideString): Smallint;
function SendAuthAccept(uin: Integer): Smallint;
function SendAuthDecline(uin: Integer; const Reason: WideString): Smallint;
function SendContact(uin: Integer; UINList: OleVariant; NickList: OleVariant):
Smallint;
function SendUserAdd(uin: Integer): Smallint;
procedure ShowAboutBox;
property ControlInterface: _IcqUdp read GetControlInterface;
property DefaultInterface: _IcqUdp read GetControlInterface;
published
property UserUin: Integer index 1745027081 read GetIntegerProp write
SetIntegerProp stored False;
property UserPassword: WideString index 1745027080 read GetWideStringProp write
SetWideStringProp stored False;
property LocalIP: WideString index 1745027079 read GetWideStringProp write
SetWideStringProp stored False;
property LocalRealIP: WideString index 1745027078 read GetWideStringProp write
SetWideStringProp stored False;
property LocalPort: Smallint index 1745027077 read GetSmallintProp write
SetSmallintProp stored False;
property RemoteHost: WideString index 1745027076 read GetWideStringProp write
SetWideStringProp stored False;
property RemotePort: Smallint index 1745027075 read GetSmallintProp write
SetSmallintProp stored False;
property UseTCP: TOleEnum index 1745027074 read GetTOleEnumProp write
SetTOleEnumProp stored False;
property SocketState: TOleEnum index 1745027073 read GetTOleEnumProp write
SetTOleEnumProp stored False;
property OnlineState: TOleEnum index 1745027072 read GetTOleEnumProp write
SetTOleEnumProp stored False;
property OnConnected: TNotifyEvent read FOnConnected write FOnConnected;
property OnDisconnected: TNotifyEvent read FOnDisconnected write FOnDisconnected;
property OnRegistered: TNotifyEvent read FOnRegistered write FOnRegistered;
property OnContactOnline: TIcqUdpContactOnline read FOnContactOnline write
FOnContactOnline;
property OnContactStatusChange: TIcqUdpContactStatusChange read
FOnContactStatusChange write FOnContactStatusChange;
property OnContactOffline: TIcqUdpContactOffline read FOnContactOffline write
FOnContactOffline;
property OnInfoReply: TIcqUdpInfoReply read FOnInfoReply write FOnInfoReply;
property OnSearchReply: TIcqUdpSearchReply read FOnSearchReply write
FOnSearchReply;
property OnMessageReceived: TIcqUdpMessageReceived read FOnMessageReceived write
FOnMessageReceived;
property OnErrorFound: TIcqUdpErrorFound read FOnErrorFound write FOnErrorFound;
property OnPacketAcknowledge: TIcqUdpPacketAcknowledge read FOnPacketAcknowledge
write FOnPacketAcknowledge;
property OnDebugOut: TIcqUdpDebugOut read FOnDebugOut write FOnDebugOut;
end;
procedure Register;
implementation
uses ComObj;
class function CoproppgGeneral.Create: _proppgGeneral;
begin
Result := CreateComObject(CLASS_proppgGeneral) as _proppgGeneral;
end;
class function CoproppgGeneral.CreateRemote(const MachineName: string):
_proppgGeneral;
begin
Result := CreateRemoteComObject(MachineName, CLASS_proppgGeneral) as _proppgGeneral;
end;
class function CoclsIcqUtilities.Create: _clsIcqUtilities;
begin
Result := CreateComObject(CLASS_clsIcqUtilities) as _clsIcqUtilities;
end;
class function CoclsIcqUtilities.CreateRemote(const MachineName: string):
_clsIcqUtilities;
begin
Result := CreateRemoteComObject(MachineName, CLASS_clsIcqUtilities) as
_clsIcqUtilities;
end;
procedure TclsIcqUtilities.InitServerData;
const
CServerData: TServerData = (
ClassID: '{0A563495-2028-11D5-A2A7-00105A8619E7}';
IntfIID: '{0A563494-2028-11D5-A2A7-00105A8619E7}';
EventIID: '';
LicenseKey: nil;
Version: 500);
begin
ServerData := @CServerData;
end;
procedure TclsIcqUtilities.Connect;
var
punk: IUnknown;
begin
if FIntf = nil then
begin
punk := GetServer;
Fintf := punk as _clsIcqUtilities;
end;
end;
procedure TclsIcqUtilities.ConnectTo(svrIntf: _clsIcqUtilities);
begin
Disconnect;
FIntf := svrIntf;
end;
procedure TclsIcqUtilities.DisConnect;
begin
if Fintf <> nil then
begin
FIntf := nil;
end;
end;
function TclsIcqUtilities.GetDefaultInterface: _clsIcqUtilities;
begin
if FIntf = nil then
Connect;
Assert(FIntf <> nil,
'DefaultInterface is NULL. Component is not connected to Server. You must call ''Connect'' or ''ConnectTo'' before this operation');
Result := FIntf;
end;
constructor TclsIcqUtilities.Create(AOwner: TComponent);
begin
inherited Create(AOwner);
{$IFDEF LIVE_SERVER_AT_DESIGN_TIME}
FProps := TclsIcqUtilitiesProperties.Create(Self);
{$ENDIF}
end;
destructor TclsIcqUtilities.Destroy;
begin
{$IFDEF LIVE_SERVER_AT_DESIGN_TIME}
FProps.Free;
{$ENDIF}
inherited Destroy;
end;
{$IFDEF LIVE_SERVER_AT_DESIGN_TIME}
function TclsIcqUtilities.GetServerProperties: TclsIcqUtilitiesProperties;
begin
Result := FProps;
end;
{$ENDIF}
function TclsIcqUtilities.GetCountryName(var Code: Smallint): WideString;
begin
Result := DefaultInterface.GetCountryName(Code);
end;
function TclsIcqUtilities.GetCountryCode(var Index: Smallint): Smallint;
begin
Result := DefaultInterface.GetCountryCode(Index);
end;
function TclsIcqUtilities.GetCountryIndex(var CntryCode: Smallint): Smallint;
begin
Result := DefaultInterface.GetCountryIndex(CntryCode);
end;
function TclsIcqUtilities.GetLangName(var Index: Smallint): WideString;
begin
Result := DefaultInterface.GetLangName(Index);
end;
function TclsIcqUtilities.GetOccupationName(var Code: Smallint): WideString;
begin
Result := DefaultInterface.GetOccupationName(Code);
end;
function TclsIcqUtilities.GetOccupationCode(var Index: Smallint): Smallint;
begin
Result := DefaultInterface.GetOccupationCode(Index);
end;
function TclsIcqUtilities.GetOccupationIndex(var OccupationCode: Smallint): Smallint;
begin
Result := DefaultInterface.GetOccupationIndex(OccupationCode);
end;
function TclsIcqUtilities.GetPastBackgroundName(var Code: Smallint): WideString;
begin
Result := DefaultInterface.GetPastBackgroundName(Code);
end;
function TclsIcqUtilities.GetPastBackgroundCode(var Index: Smallint): Smallint;
begin
Result := DefaultInterface.GetPastBackgroundCode(Index);
end;
function TclsIcqUtilities.GetPastBackgroundIndex(var PastBackgroundCode: Smallint):
Smallint;
begin
Result := DefaultInterface.GetPastBackgroundIndex(PastBackgroundCode);
end;
function TclsIcqUtilities.GetAffiliationsName(var Code: Smallint): WideString;
begin
Result := DefaultInterface.GetAffiliationsName(Code);
end;
function TclsIcqUtilities.GetAffiliationsCode(var Index: Smallint): Smallint;
begin
Result := DefaultInterface.GetAffiliationsCode(Index);
end;
function TclsIcqUtilities.GetAffiliationsIndex(var AffiliationsCode: Smallint):
Smallint;
begin
Result := DefaultInterface.GetAffiliationsIndex(AffiliationsCode);
end;
function TclsIcqUtilities.GetTimeZone(Code: Byte): WideString;
begin
Result := DefaultInterface.GetTimeZone(Code);
end;
function TclsIcqUtilities.GetTimeCode(const strTime: WideString): Byte;
begin
Result := DefaultInterface.GetTimeCode(strTime);
end;
{$IFDEF LIVE_SERVER_AT_DESIGN_TIME}
constructor TclsIcqUtilitiesProperties.Create(AServer: TclsIcqUtilities);
begin
inherited Create;
FServer := AServer;
end;
function TclsIcqUtilitiesProperties.GetDefaultInterface: _clsIcqUtilities;
begin
Result := FServer.DefaultInterface;
end;
{$ENDIF}
procedure TIcqUdp.InitControlData;
const
CEventDispIDs: array[0..11] of DWORD = (
$00000001, $00000002, $00000003, $00000004, $00000005, $00000006,
$00000007, $00000008, $00000009, $0000000A, $0000000B, $0000000C);
CControlData: TControlData2 = (
ClassID: '{0A5634A0-2028-11D5-A2A7-00105A8619E7}';
EventIID: '{0A5634A2-2028-11D5-A2A7-00105A8619E7}';
EventCount: 12;
EventDispIDs: @CEventDispIDs;
LicenseKey: nil (*HR:$00000000*);
Flags: $00000000;
Version: 401);
begin
ControlData := @CControlData;
TControlData2(CControlData).FirstEventOfs := Cardinal(@@FOnConnected) -
Cardinal(Self);
end;
procedure TIcqUdp.CreateControl;
procedure DoCreate;
begin
FIntf := IUnknown(OleObject) as _IcqUdp;
end;
begin
if FIntf = nil then
DoCreate;
end;
function TIcqUdp.GetControlInterface: _IcqUdp;
begin
CreateControl;
Result := FIntf;
end;
procedure TIcqUdp.Connect;
begin
DefaultInterface.Connect;
end;
procedure TIcqUdp.Disconnect;
begin
DefaultInterface.Disconnect;
end;
procedure TIcqUdp.Register(var Password: WideString);
begin
DefaultInterface.Register(Password);
end;
procedure TIcqUdp.ChangePassword(var Password: WideString);
begin
DefaultInterface.ChangePassword(Password);
end;
function TIcqUdp.SendAdded(uin: Integer; var Nickname: WideString; var EmailAddress:
WideString): Smallint;
begin
Result := DefaultInterface.SendAdded(uin, Nickname, EmailAddress);
end;
procedure TIcqUdp.ContactAdd(var UINList: PSafeArray);
begin
DefaultInterface.ContactAdd(UINList);
end;
procedure TIcqUdp.VisibleAdd(var UINList: PSafeArray);
begin
DefaultInterface.VisibleAdd(UINList);
end;
procedure TIcqUdp.InvisibleAdd(var UINList: PSafeArray);
begin
DefaultInterface.InvisibleAdd(UINList);
end;
procedure TIcqUdp.VisibleRemove(var UINList: PSafeArray);
begin
DefaultInterface.VisibleRemove(UINList);
end;
procedure TIcqUdp.InvisibleRemove(var UINList: PSafeArray);
begin
DefaultInterface.InvisibleRemove(UINList);
end;
procedure TIcqUdp.InfoRequestBasic(uin: Integer);
begin
DefaultInterface.InfoRequestBasic(uin);
end;
procedure TIcqUdp.InfoRequestMore(uin: Integer);
begin
DefaultInterface.InfoRequestMore(uin);
end;
procedure TIcqUdp.InfoRequestAll(uin: Integer);
begin
DefaultInterface.InfoRequestAll(uin);
end;
procedure TIcqUdp.InfoUpdate(InfoUpdateType: enumInfoType; var InfoDetail: TGUID);
begin
DefaultInterface.InfoUpdate(InfoUpdateType, InfoDetail);
end;
procedure TIcqUdp.SearchUin(uin: Integer);
begin
DefaultInterface.SearchUin(uin);
end;
procedure TIcqUdp.SearchName(const Nickname: WideString; const Firstname: WideString;
const Lastname: WideString);
begin
DefaultInterface.SearchName(Nickname, Firstname, Lastname);
end;
procedure TIcqUdp.SearchEmail(const EmailAddress: WideString);
begin
DefaultInterface.SearchEmail(EmailAddress);
end;
function TIcqUdp.SendText(uin: Integer; const Message: WideString): Smallint;
begin
Result := DefaultInterface.SendText(uin, Message);
end;
function TIcqUdp.SendURL(uin: Integer; const URLAddress: WideString;
const URLDescription: WideString): Smallint;
begin
Result := DefaultInterface.SendURL(uin, URLAddress, URLDescription);
end;
function TIcqUdp.SendAuthReq(uin: Integer; const Nickname: WideString;
const Firstname: WideString; const Lastname: WideString;
const EmailAddress: WideString; const Reason: WideString): Smallint;
begin
Result := DefaultInterface.SendAuthReq(uin, Nickname, Firstname, Lastname,
EmailAddress, Reason);
end;
function TIcqUdp.SendAuthAccept(uin: Integer): Smallint;
begin
Result := DefaultInterface.SendAuthAccept(uin);
end;
function TIcqUdp.SendAuthDecline(uin: Integer; const Reason: WideString): Smallint;
begin
Result := DefaultInterface.SendAuthDecline(uin, Reason);
end;
function TIcqUdp.SendContact(uin: Integer; UINList: OleVariant; NickList: OleVariant):
Smallint;
begin
Result := DefaultInterface.SendContact(uin, UINList, NickList);
end;
function TIcqUdp.SendUserAdd(uin: Integer): Smallint;
begin
Result := DefaultInterface.SendUserAdd(uin);
end;
procedure TIcqUdp.ShowAboutBox;
begin
DefaultInterface.ShowAboutBox;
end;
procedure Register;
begin
RegisterComponents('Standard', [TIcqUdp]);
RegisterComponents('Standard', [TclsIcqUtilities]);
end;
end.
////////////////////////////
////////////////////////////
2005. december 14., szerda
How to open an URL in a regular browser instead of opening it in a TWebBrowser
Problem/Question/Abstract:
I have a TWebBrowser in my application that loads unknown remote content. When a user clicks on any link in it, I would like to have the URL opened in a regular browser, but not within the TWebBrowser itself. I do not want the TWebBrowser to act upon the click.
Answer:
Use the OnBeforeNavigate2 event like that:
procedure TForm1.WebBrowser1BeforeNavigate2(Sender: TObject; const pDisp: IDispatch;
var URL, Flags, TargetFrameName, PostData, Headers: OleVariant; var Cancel: WordBool);
begin
if not FManuallyLoading then
begin
{Stop Loading in this Browser ...}
Cancel := True;
{... but open in new Browser}
Flags := Flags or 1;
(Sender as TWebBrowser).Navigate(WideString(URL), Flags,
TargetFrameName, PostData, Headers);
end;
end;
Set FManuallyLoading to True, while you are programmatically loading content into the web browser:
procedure TForm1.Button1Click(Sender: TObject);
begin
FManuallyLoading := True;
WebBrowser1.Navigate('http://www.nineberry.de');
FManuallyLoading := False;
end;
2005. december 13., kedd
How to use Randomize so that the same value is not chosen more than once
Problem/Question/Abstract:
How can I write a procedure that does not choose the same number more than once?
Answer:
This is called "shuffling". Most often, you want it to randomize the values in a list or array. In any case, the only way to count "more than once" is to do this over a given array. If you just want the shuffle values one by one, you shuffle the array and then take the values from the lowest element to the highest, successively.
The thing to avoid is to go and keep a list of the numbers already found, and call random endlessly until it gives a number not on the list. With a large range, this takes incredibly long.
The procedure below shows how to do it correctly. It assumes you want a continuous range of values. If you want something fancier (say, a shuffle of various weights, or of names, etc.), then you merely have to change the procedure to take an array of the proper type, and NOT to fill it at the beginning - the caller can pre-fill it with the values wanted.
procedure shuffle(var a: array of integer; nLow: integer);
{"a" holds all values from nLow to nLow + high(a) in pseudorandom order.
Method: Fill array with values in order. Values above jTop are shuffled. jTop starts at array top and moves down one element per step. We're done when jTop is a[0]. On each step, a random element below jTop is exchanged with the one at jTop}
var
j: integer;
jTop: integer;
nTemp: integer;
begin
for j := 0 to high(a) do
a[j] := j + nLow;
jTop := high(a);
randomize;
while (jTop > 0) do
begin
j := random(jTop + 1);
nTemp := a[j];
a[j] := a[jTop];
a[jTop] := nTemp;
dec(jTop);
end;
end;
Feliratkozás:
Bejegyzések (Atom)