2004. szeptember 30., csütörtök
Reconnecting to network shares with the help of a Component.
Problem/Question/Abstract:
Ever lost a networked share and didn't know how to connect to it? Well with this component you can search the network for a specific share containing a file or a directory and automatically reconnect to it.
Answer:
NOTE: IF YOU ALLREADY KNOW THE LOCATION OF THE SHARE YOU SHOULDN'T USE THIS COMPONENT AS IN LARGE NETWORKS WILL BE SLOW. THIS IS ONLY IF YOU DON'T KNOW THE EXACT LOCATION BUT CAN LOCATE IT BY USING A MARKER SUCH AS A SPECIFIC FILE OR FOLDER.
TIP: Use the BeforeConnect Event to specify whether a connection should be made.
unit Reconnect;
interface
uses
Windows, Messages, StdCtrls, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
FileCtrl;
type
TSIsType = (itDir, itIniFile, itApp, itOther);
TBeforeConnectEvent = procedure(Owner: TObject; AssignPath: string; var Accept:
boolean) of object;
TAfterConnectEvent = procedure(Owner: TObject; AssignedPath: string) of object;
TOnFail = procedure(Owner: TObject; FailMessage: string) of object;
TReconnect = class(TComponent)
private
{ Private declarations }
DidAssign: boolean;
FItemToLookFor: string;
FUserName: string;
FPassword: string;
FLetterToAssign: Char;
FIsType: TSIsType;
FOutputLabel: TLabel;
FFailMessage: string;
FBeforeConnect: TBeforeConnectEvent;
FAfterConnect: TAfterConnectEvent;
FOnFail: TOnFail;
function DoEnum(NetResT: PNetResourceA): integer;
function addbs(g: string): string; overload;
function addbs(g: string; SLASH: CHAR): string; overload;
function SearchFor(NetResT: NETRESOURCE; Path, param: string): boolean;
protected
{ Protected declarations }
public
{ Public declarations }
published
{ Published declarations }
function SearchAndAssign: boolean;
property ItemToLookFor: string read FItemToLookFor write FItemToLookFor;
property LetterToAssign: Char read FLetterToAssign write FLetterToAssign;
property IsType: TSIsType read FIsType write FIsType default itDir;
property OutputLabel: TLabel read FOutputLabel write FOutputLabel;
property UserName: string read FUserName write FUserName;
property Password: string read FPassword write FPassword;
property BeforeConnect: TBeforeConnectEvent read FBeforeConnect write
FBeforeConnect;
property AfterConnect: TAfterConnectEvent read FAfterConnect write FAfterConnect;
property OnFail: TOnFail read FOnFail write FOnFail;
end;
procedure Register;
implementation
function TReconnect.addbs(g: string; SLASH: CHAR): string;
begin
g := trim(g);
if g <> '' then
begin
if g[length(g)] <> SLASH then
result := g + SLASH
else
result := g;
end
else
result := g;
end;
function TReconnect.addbs(g: string): string;
begin
result := addbs(g, '\');
end;
function TReconnect.SearchFor(NetResT: NETRESOURCE; Path, param: string): boolean;
var
cont: boolean;
Exists: boolean;
begin
Exists := false;
path := addbs(path);
SearchFor := false;
if IsType = itDir then
Exists := directoryExists(path + param);
if IsType = itIniFile then
Exists := FileExists(path + param);
if IsType = itApp then
Exists := FileExists(path + param);
if IsType = itOther then
Exists := FileExists(path + param);
if Exists then
begin
cont := true;
try
if assigned(FBeforeConnect) then
BeforeConnect(self, path, cont);
except
showmessage('Failed to call BeforeConnect.');
end;
if cont then
begin
try
NetResT.lpLocalName := pchar(string(FLetterToAssign) + ':');
WNetAddConnection2A(NetResT, pchar(UserName), pchar(Password),
CONNECT_UPDATE_PROFILE);
DidAssign := true;
try
if assigned(FAfterConnect) then
AfterConnect(self, path);
except
showmessage('Failed to call AfterConnect.');
end;
except on E: Exception do
Showmessage(E.Message);
end;
SearchFor := true;
end;
end;
end;
function TReconnect.DoEnum(NetResT: PNetResourceA): integer;
var
EnumH: THandle;
cnt: cardinal;
buffsize: cardinal;
NetResBuf: array[0..200] of NETRESOURCE;
res: word;
i: integer;
begin
if DidAssign then
exit;
try
cnt := 255;
WNetOpenEnum(RESOURCE_GLOBALNET, RESOURCETYPE_DISK, 0, NetResT, EnumH);
res := 0;
while (res = NO_ERROR) do
begin
buffsize := sizeof(NetResBuf);
res := WNetEnumResource(EnumH, cnt, @NetResBuf, buffsize);
for i := 0 to cnt - 1 do
begin
if Assigned(OutputLabel) then
begin
OutputLabel.Caption := NetResBuf[i].lpRemoteName;
OutputLabel.Refresh;
end;
if NetResBuf[i].dwDisplayType = RESOURCEDISPLAYTYPE_SHARE then
begin
if not DidAssign then
if SearchFor(NetResBuf[i], string(NetResBuf[i].lpRemoteName),
ItemToLookFor) then
begin
result := 0;
exit;
end;
end;
if (NetResBuf[i].dwScope = RESOURCEUSAGE_CONTAINER) then
doEnum(@NetResBuf[i]);
end;
end;
WNetCloseEnum(EnumH);
result := 1;
except on E: Exception do
begin
FFailMessage := E.Message;
if Assigned(FOnFail) then
OnFail(Owner, FFailMessage);
result := 0;
end;
end;
end;
function TReconnect.SearchAndAssign: boolean;
begin
DidAssign := false;
DoEnum(nil);
result := true;
end;
procedure Register;
begin
RegisterComponents('VNPVcls', [TReconnect]);
end;
end.
2004. szeptember 29., szerda
Parse the lines of a text file and import them into a Paradox table
Problem/Question/Abstract:
I have a text file with a certain format where only the first line is of type year and month. The rest is always the same: Integer, String, String, Integer, Integer, Integer. Example:
2001,10
000368,"The Name","Category",000671000,0724690,009421
000701,"The Name","Category",000398500,0398500,005181
What's the best way to import this into Paradox tables?
Answer:
Solve 1:
I would read it one line at a time and parse it with something like the following parser. The variable ofs needs to be set to zero to start the parsing at the beginning of the line.
{ ... }
ReadLn(f, line);
ofs := 0;
if GetNextSepValueOK(line, ofs, YrStr, ', ', '"') and
GetNextSepValueOK(line, ofs, MoStr, ', ', '"') then
{prep date}
else
raise Exception.Create('Cannot find year and month');
while not EOF(f) do
begin
ReadLn(f, line);
ofs := 0;
{Do Append and try, etc. }
while GetNextSepValueOK(line, ofs, value, ', ', '"') do
{Do Post}
end;
end;
{ ... }
function GetNextSepValueOK(const line: string; var ofs: integer; out value: string;
const Separator, Grouper: char): Boolean;
var
i, oc, lnb, GrouperCount: integer;
c: char;
temp: ShortString;
begin
oc := 0;
lnb := 0;
GrouperCount := 0;
i := ofs;
while (ofs < length(line)) do
begin
c := line[ofs + 1];
if not Odd(GrouperCount) and (c = Separator) then
break
else if c = Grouper then
begin
inc(GrouperCount);
if odd(GrouperCount) and (ofs > i) and (line[ofs] = Grouper) then
begin
inc(oc);
temp[oc] := Grouper;
end;
end
else if (c > ' ') or (lnb > 0) or odd(GrouperCount) then
begin
inc(oc);
temp[oc] := c;
end;
if (c > ' ') or odd(GrouperCount) then
lnb := oc;
inc(ofs);
end;
if (ofs < length(line)) and (line[ofs + 1] = Separator) then
begin
inc(ofs);
Result := true;
end
else
Result := (i < length(line)) and not Odd(GrouperCount);
if Result then
begin
temp[0] := char(lnb);
value := temp;
end;
end;
Solve 2:
procedure TForm1.ImportFile(const filename: string);
var
F: Textfile;
year, month: Integer;
line: string;
sl: Tstringlist;
begin
Assignfile(F, filename);
Reset(F);
try
ReadLn(F, line);
sl := TStringlist.Create;
try
sl.QuoteChar := '"';
sl.Commatext := line;
year := StrToInt(sl[0]);
month := StrToInt(sl[1]);
while not EOF(F) do
begin
Readln(line);
sl.Commatext := line;
SaveRecord(sl);
end;
finally
sl.free
end;
finally
Closefile(f)
end;
end;
The Saverecord method would be something like:
procedure Tform1.SaveRecord(sl: TStringlist);
begin
if sl.Count <> 6 then
raise Exception.Create('Invalid record');
table1.Append;
table1['ID'] := sl[0];
table2['Name'] := sl[1];
{ ... }
table1.Post;
end;
Solve 3:
You can use the CommaText property of a TStringList to parse the lines. Something like this:
procedure ReadFile(FileName: string);
var
F: TextFile;
S: string;
List: TStringList;
i: integer;
begin
AssignFile(F, FileName);
Reset(F);
List := TStringList.Create;
try
Readln(F, S);
List.CommaText := S;
{do whatever you want with first line}
while not EOF(F) do
begin
List.Clear;
ReadLn(F, S);
List.CommaText := S;
{List now contains the integers and strings as separate strings}
MyTable.Append;
for i := 0 to 5 do
MyTable.Fields[i].AsString := List.Strings[i];
MyTable.Post;
end;
finally
List.Free;
end;
closefile(f);
end;
2004. szeptember 28., kedd
Find files with FindFirst and FindNext
Problem/Question/Abstract:
Find files with FindFirst and FindNext
Answer:
The procedure FindFiles locates files (by a given "filemask") and adds their complete path to a stringlist. Note that recursion is used: FindFiles calls itself at the end of the procedure!
Before calling FindFiles, the stringlist has to be created; afterwards, you must free the stringlist.
In StartDir you pass the starting directory, including the disk drive. In FileMask you pass the name of the file to find, or a file mask. Examples:
FindFiles('c:\', 'letter01.doc')
FindFiles('d:\', 'euroen??.dpr')
FindFiles('d:\projects', '*.dpr')
If you want to test this procedure, start a new project and add some components to the form: two Edits (one for the starting directory, one for the mask), a Button, a TLabel and a ListBox.
implementation
....
var
FilesList: TStringList;
...
procedure FindFiles(StartDir, FileMask: string);
var
SR: TSearchRec;
DirList: TStringList;
IsFound: Boolean;
i: integer;
begin
if StartDir[length(StartDir)] <> '\' then
StartDir := StartDir + '\';
{ Build a list of the files in directory StartDir
(not the directories!) }
IsFound :=
FindFirst(StartDir + FileMask, faAnyFile - faDirectory, SR) = 0;
while IsFound do
begin
FilesList.Add(StartDir + SR.Name);
IsFound := FindNext(SR) = 0;
end;
FindClose(SR);
// Build a list of subdirectories
DirList := TStringList.Create;
IsFound := FindFirst(StartDir + '*.*', faAnyFile, SR) = 0;
while IsFound do
begin
if ((SR.Attr and faDirectory) <> 0) and
(SR.Name[1] <> '.') then
DirList.Add(StartDir + SR.Name);
IsFound := FindNext(SR) = 0;
end;
FindClose(SR);
// Scan the list of subdirectories
for i := 0 to DirList.Count - 1 do
FindFiles(DirList[i], FileMask);
DirList.Free;
end;
procedure TForm1.ButtonFindClick(Sender: TObject);
begin
FilesList := TStringList.Create;
FindFiles(EditStartDir.Text, EditFileMask.Text);
ListBox1.Items.Assign(FilesList);
LabelCount.Caption := 'Files found: ' + IntToStr(FilesList.Count);
FilesList.Free;
end;
2004. szeptember 27., hétfő
Image can show preview-image in dwg file (autocad file name)
Problem/Question/Abstract:
I have writen a component from image which can show the preview-image in dwg file
Answer:
unit DWGView;
interface
uses
Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
ExtCtrls;
type
BITMAPINFO256 = record
bmiHeader: BITMAPINFOHEADER;
bmiColors: array[0..255] of RGBQUAD;
end;
type
TNoPreviewEvent = procedure(Sender: TOBject) of object;
TFileErrorEvent = procedure(Sender: TOBject; DWGName: string) of object;
TDWGView = class(TImage)
private
FDWGVersion: string;
FDWGFile: string;
FNoPreviewEvent: TNoPreviewEvent;
FOnFileError: TFileErrorEvent;
FImage: TImage;
procedure SetDWGFile(const Value: string);
procedure SetFImage(const Value: TImage);
{ Private declarations }
protected
procedure ReadDWG;
constructor TDWGView;
{ Protected declarations }
public
{ Public declarations }
published
{ Published declarations }
property Image: TImage read FImage write SetFImage;
property DWGFile: string read FDWGFile write SetDWGFile;
property DWGVersion: string read FDWGVersion;
property OnNoPreview: TNoPreviewEvent read FNoPreviewEvent write FNoPreviewEvent;
property OnFileError: TFileErrorEvent read FOnFileError write FOnFileError;
end;
procedure Register;
implementation
procedure Register;
begin
RegisterComponents('Voice', [TDWGView]);
end;
procedure TDWGView.ReadDWG;
var
DWGF: TFileStream; // ?�???ġ?
MemF: TMemoryStream; // ??µ????�?�
BMPF: TMemoryStream; // ?»?�?ġ?
SentinelF: TMemoryStream; //?�����¶? 16�ֽ?
bif: BITMAPINFO256; // ?»?�?ġ??�?�
bfh: BITMAPFILEHEADER; // ?»?�?ġ??ġ??· 14�ֽ?
PosSentinel: LongInt; // ?�����¶??»�?
LenPreview: Integer; // �??�����¶?�®??�?¬�?�???��¬??µ?µij�¶?
RasterPreview: ShortInt; // ?µ?�?�???��¬????µ�?»¬�µ?�ֽ?�???
// 0 �»±�???�???��¬ 1 ±�??BMP?��¬
// 2 ±�??WMF?��¬ 3 ?¬?±±�??BMP??WMF?��¬
PosBMP: Integer; // ?��¬µ�տ?µ?»�?�¬�»?»¶«???»?�
LenBMP: Integer; // ?��¬��¶?�¬�»?¬BITMAPFILEHEADER??µ?�¬�»?»¶«???»?�
IndexPreview: Integer;
TypePreview: Shortint; // ?��¬????
begin
if Assigned(FOnFileError) then
FOnFileError(Self, FDWGFile);
DWGF := TFileStream.Create(FDWGFile, fmOpenRead);
BMPF := TMemoryStream.Create;
MemF := TMemoryStream.Create;
SentinelF := TMemoryStream.Create;
try
SetLength(FDWGVersion, 6);
DWGF.ReadBuffer(FDWGVersion[1], 6);
DWGF.Position := 13; // ?ġ?�??�13�¦�¬???�����¶?
DWGF.Read(PosSentinel, 4);
DWGF.Position := PosSentinel;
SentinelF.CopyFrom(DWGF, 16); // ¶????�����¶?
DWGF.Read(LenPreview, 4); // ¶???
DWGF.Read(RasterPreview, 1); // ¶????��¬????
for IndexPreview := RasterPreview - 1 downto 0 do
begin
MemF.Position := 0;
MemF.CopyFrom(DWGF, 9); // ?��¬???�?� 9�ֽ?
MemF.Position := 0;
MemF.Read(TypePreview, 1); // TypePreview ?��¬????
case TypePreview of
1: ; // ?�??µ�???��???
2:
begin
// BMP?��¬,??DWG?ġ?�?±���µ�BMP?��¬?�????????�?BMP±�·¶µ�
// ?�?�?ġ???µ?�¬µ«??�»±���BITMAPFILEHEADER??µ?
MemF.Position := 1;
MemF.Read(PosBMP, 4); // 2,5
MemF.Read(LenBMP, 4); // 6,9
DWGF.Position := PosBMP;
DWGF.ReadBuffer(bif, sizeof(bif));
with bif do
begin
bmiColors[0].rgbBlue := 0;
bmiColors[0].rgbGreen := 0;
bmiColors[0].rgbRed := 0;
bmiColors[225].rgbBlue := 255;
bmiColors[225].rgbGreen := 255;
bmiColors[225].rgbRed := 255;
end;
bfh.bfType := $4D42;
bfh.bfSize := LenBMP + sizeof(bfh); //
bfh.bfReserved1 := 0;
bfh.bfReserved2 := 0;
bfh.bfOffBits := 14 + $28 + 1024;
BMPF.Position := 0;
BMPF.Write(bfh, sizeof(bfh));
BMPF.WriteBuffer(bif, sizeof(bif));
BMPF.CopyFrom(DWGF, LenBMP - 1064);
BMPF.Position := 0;
Picture.Bitmap.LoadFromStream(BMPF);
end;
3: ; // WMF?ġ?�¬?��?22�ֽ?��µ�Aldus?ġ??·
end;
end;
finally
SentinelF.Free;
MemF.Free;
DWGF.Free;
BMPF.Free;
end;
end;
procedure TDWGView.SetDWGFile(const Value: string);
begin
FDWGFile := Value;
ReadDWG;
end;
procedure TDWGView.SetFImage(const Value: TImage);
begin
FImage := Value;
end;
constructor TDWGView.TDWGView;
begin
//TODO: Add your source code here
FDWGFile := '';
FDWGVersion := '';
end;
end.
2004. szeptember 26., vasárnap
Creating a descendant of a component to enhance functionality
Problem/Question/Abstract:
Adding an accelerator key to a TPageControl
Answer:
This tip is an example of extending the functionality of a component by creating a descendant. While implicit to the discussion at hand, here's where the power of an object-oriented language such as Delphi lays. As you'll see in the code below, it doesn't take much to create new functionality of an object by creating a descendant. The point of this is that had I not been using an object-oriented language, I would have had to re-write the original code of the TPageControl, then add the extended functionality. Fortunately, the VCL, which is really an object hierarchy, allows me to transparently inherit and retain the ancestral functionality and concentrate on the new functionality. You gotta love it!
For those of you new to Delphi, an accelerator key is a key that is pressed in combination with the Alt key to execute a command. They're sometimes called keyboard shortcuts or hotkeys, and you'll typically see them in menus as the underlined letter of a menu item. For instance, the "F" in the File menu selection is an accelerator key for that item. So to open up the File menu, you'd press Alt-F.
Accelerator keys aren't limited to just menu items. In fact, for almost any Caption property or a Caption-like property (e.g. Radio Group items) of a component, you can define an accelerator key. All you need to do is place an "&" before a letter to designate it as an accelerator key. This is useful with VCL components like a TRadioGroup's Items, which allow the user to quickly select the radio button choice with the touch of a key. However, not all VCL components will respond to accelerator keystrokes if you define them. TPageControl in Delphi 2.0, which replaces TTabbedNotebook, is one of those components. And with it, accelerator key functionality would be particularly useful.
The only method I know for implementing accelerator key functionality in a TPageControl is to create a new component. There's another way, but you have to create menu and define hotkeys for menu items with equivalent functionality (they'll turn your pages for you), and that's a pretty kludgy way of doing things. Besides, the code to accomplish what we want is actually very simple.
Below is the unit code for a descendant of TPageControl that adds accelerator key functionality. We'll discuss the particulars after the listing:
unit accel;
interface
uses
Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
ComCtrls;
type
TAccelPageCtrl = class(TPageControl)
private
{ Private declarations }
procedure CMDialogChar(var Msg: TCMDialogChar); message CM_DIALOGCHAR;
protected
{ Protected declarations }
public
{ Public declarations }
published
{ Published declarations }
end;
procedure Register;
implementation
procedure TAccelPageCtrl.CMDialogChar(var Msg: TCMDialogChar);
var
I: Integer;
Okay: Boolean;
begin
Okay := False;
inherited; //call the inherited message handler.
//Now with our own component, start at Page 1 (Item 0) and work to the end.
for I := 0 to PageCount - 1 do
begin
//Is key pressed accelerator key in Caption?
Okay := IsAccel(Msg.CharCode, Pages[I].Caption) and CanChange(I);
//this is the fix
//It is, so change the page and break out of the loop.
if Okay then
begin
Msg.Result := 1; //you can set this to anything, but by convention it's 1
ActivePage := Pages[I];
Change;
Break;
end;
end;
end;
procedure Register;
begin
RegisterComponents('BD', [TAccelPageCtrl]);
end;
end.
As you can see from the above. all that's required to add accelerator key response is a simple message handler procedure. The message we're interested in is CM_DialogChar, a Delphi custom message type encapsulated by TCMDialogChar, which is a wrapper type for the Windows WM_SYSCHAR message. WM_SYSCHAR is the Windows message that is used to trap accelerator keys; you can find a good discussion of it in the online help. The most important thing to note is what happens when the TAccelPageCtrl component detects that a CM_DialogChar message has fired.
Take a look at the CMDialogChar procedure, and note that all that's going in the code is a simple for loop that starts at the first page of the descendant object and goes to the last page, unless the key that was pressed happened to be an accelerator key. We can easily determine if a key is an accelerator key with the IsAccel function, which takes the key code pressed and a string (we passed the Caption property of the current TabSheet). IsAccel searches through the string and looks for a matching accelerator key. If it finds one, it returns True. If so, we set the message result value and change the page of TAccelPageCtrl to the page where the accelerator was found by setting the ActivePage property and calling the inherited Change procedure from TPageControl.
I haven't used TPageControl since I created this component because of how easy TAccelPageCtrl makes switching from TabSheet to TabSheet. It's far easier to do a Alt-<key> combination than use the mouse when you're at the keyboard. Play around with this and you'll be convinced not to use the standard VCL TPageControl.
2004. szeptember 25., szombat
How to prevent the cursor from jumping to the start of a TDBMemo after setting the charcase property
Problem/Question/Abstract:
I published the Charcase property of a TDBMemo, but have had a couple of problems. If I set the case to Upper or Lower sometimes, depending on what text is in the memo, no matter where I place the cursor and start typing (dataset in browse mode before this) the cursor jumps to the start of the memo and types there instead. Setting Charcase to normal corrects this. This only happens on a memo that is fairly full with text (the display area that is!). Any ideas why this is happening and how to stop it?
Answer:
This happens even in a normal TDBMemo. My solution is to use the OnEnter event of the TDBMemo:
{ ... }
x := TDBMemo(Sender).SelStart;
if not (TDBMemo(Sender).DataSource.DataSet.State in dsEditModes) then
TDBMemo(Sender).DataSource.DataSet.Edit;
TDBMemo(Sender).SelStart := x;
TDBMemo(Sender).SelLength := 0;
{ ... }
This seems to solve that problem entirely. First it stores the clicked on location of the memo, and you can see what the rest does.
2004. szeptember 24., péntek
How to create a random list of numbers
Problem/Question/Abstract:
I should give an example of what I'm trying to do. The NewTrackList procedure is supposed to create a list of 14 numbers from 1 to 14, with no numbers repeated. The list is supposed to be random, that is, a different sequence of numbers is created every time the procedure runs.
Answer:
procedure NewTrackList;
var
TrackNumbersList: array[1..14] of Integer;
I, II: Integer;
SameTracks: Boolean;
S: string;
begin
for I := 1 to 14 do
TrackNumbersList[I] := 0;
for I := 1 to 14 do
begin
TrackNumbersList[I] := Random(14) + 1;
repeat
SameTracks := False;
for II := 1 to I - 1 do
begin
if I = 1 then
Break;
if TrackNumbersList[I] = TrackNumbersList[II] then
begin
SameTracks := True;
TrackNumbersList[I] := Random(14) + 1;
Break;
end;
end;
until
not SameTracks;
end;
S := '';
for I := 1 to 14 do
S := S + ' ' + IntToStr(TrackNumbersList[I]);
Form1.Label1.Caption := S;
end;
procedure TTunesMain.FormCreate(Sender: TObject);
begin
Randomize;
NewTrackList;
end;
S is a local variable of type String. I obviously added a TLabel to the form, as well.
2004. szeptember 23., csütörtök
Master passwords for password protected Paradox tables
Problem/Question/Abstract:
Master passwords for password protected Paradox tables
Answer:
The password protection for Paradox tables is really weak. Here are two of the master passwords which you can use to open any protected Paradox table:
For Paradox 5 and 7 / BDE 3.0:
jIGGAe
cupcdvum
For Paradox 4 DOS:
nx66ppx
2004. szeptember 22., szerda
Call another help file from your application
Problem/Question/Abstract:
How do you display a help file that does not belong to your application (i.e. is not specified as Application.HelpFile)?
Answer:
You can call the Winhelp command directly. The Delphi function Application.HelpCommand is simply a wrapper around this call:
procedure TForm1.LaunchHelp(HelpFile: string);
begin
{ The two parameters HELP_FINDER and 0 are the same paramters
you use in Application.HelpCommand(Command, Data).
You can use any of the valid parameters here. }
WinHelp(Form1.handle, PChar(HelpFile), HELP_FINDER, 0);
end;
Important!
The help file you call this way does NOT automatically close when the current form or the application is closed! To ensure that the help file is closed when the user closes the form, add a close command to the OnClose event of the form:
procedure TForm1.FormClose(Sender: TObject; var Action: TCloseAction);
begin
WinHelp(Form1.handle, PChar(HelpFile), HELP_QUIT, 0);
end;
2004. szeptember 21., kedd
Convert a normal IP Address to a DWord IP Address
Problem/Question/Abstract:
We sometimes link to a URL like "http://3232235778". This notation is known as DWord IP Address. How can we convert a regular IP Address to a DWord IP Address.
Answer:
Solve 1:
The following Function may not be the most elegante one, but it works. The function will convert an IP Address passed as a string, and returns a string with the converted DWord value. You can test the result with the "Ping" command.
NOTE: you must add "Math" to "Uses" for the "IntPower" Function;
******************************************************************
This code is FREE. It was compiled on Delphi 3.
******************************************************************
function IP2HEX(OrgIP: string): string;
var
OrgVal: string; // Saved Original IP Address
O1, O2, O3, O4: string; // Original IP Split
H1, H2, H3, H4: string; // Octet To Hex
HexIP: string; // All Hex Strings United
XN: array[1..8] of Extended;
Flt1: Extended;
Xc: Integer;
begin
// Save in reverse order for easy "Case"
Xn[8] := IntPower(16, 0);
Xn[7] := IntPower(16, 1);
Xn[6] := IntPower(16, 2);
Xn[5] := IntPower(16, 3);
Xn[4] := IntPower(16, 4);
Xn[3] := IntPower(16, 5);
Xn[2] := IntPower(16, 6);
Xn[1] := IntPower(16, 7);
// Save Original IP Address
OrgVal := OrgIP;
O1 := Copy(OrgVal, 1, Pos('.', OrgVal) - 1);
Delete(OrgVal, 1, Pos('.', OrgVal));
O2 := Copy(OrgVal, 1, Pos('.', OrgVal) - 1);
Delete(OrgVal, 1, Pos('.', OrgVal));
O3 := Copy(OrgVal, 1, Pos('.', OrgVal) - 1);
Delete(OrgVal, 1, Pos('.', OrgVal));
O4 := OrgVal;
H1 := IntToHex(StrToInt(O1), 2);
H2 := IntToHex(StrToInt(O2), 2);
H3 := IntToHex(StrToInt(O3), 2);
H4 := IntToHex(StrToInt(O4), 2);
// Here we have the HEX value of IP Address
HexIP := H1 + H2 + H3 + H4;
// Start Convert Huge HEX to Float variable
Flt1 := 0;
for Xc := 1 to 8 do
begin
case HexIP[Xc] of
'0'..'9': Flt1 := Flt1 + (StrToInt(HexIP[XC]) * Xn[Xc]);
'A': Flt1 := Flt1 + (10 * Xn[Xc]);
'B': Flt1 := Flt1 + (11 * Xn[Xc]);
'C': Flt1 := Flt1 + (12 * Xn[Xc]);
'D': Flt1 := Flt1 + (13 * Xn[Xc]);
'E': Flt1 := Flt1 + (14 * Xn[Xc]);
'F': Flt1 := Flt1 + (15 * Xn[Xc]);
end;
end;
Result := FloatToStr(Flt1);
end;
Solve 2:
function IpStringToLong(Ip: string): longword;
var
i, Shift: integer;
Temp: string;
begin
Temp := '';
Shift := 24;
Result := 0;
for i := 1 to Length(Ip) do
begin
if Ip[i] = '.' then
begin
try
Result := Result or (byte(StrToInt(Temp)) shl Shift);
finally
Temp := '';
Dec(Shift, 8);
end;
end
else
Temp := Temp + Ip[i];
end;
if Shift <> 0 then
Result := 0;
end;
Solve 3:
function IP2Number(IP: string): dword;
var
I, DotPosition: integer;
IPWord: dword;
begin
Result := 0;
for I := 0 to 3 do
begin
DotPosition := Pos('.', IP);
if (DotPosition = 0) then
begin
DotPosition := Length(IP) + 1;
end; {if}
IPWord := StrToInt(Copy(IP, 1, DotPosition - 1));
Result := Result or (IPWord shl ((3 - I) * 8));
IP := Copy(IP, DotPosition + 1, Length(IP));
end; {for}
end;
Solve 4:
function IpToWord(pIP: PChar): longword;
var
Block: integer;
begin
Result := 0;
Block := 0;
repeat
case pIP^ of
#00, '.':
begin
Result := Result shl 8 + Block;
Block := 0;
end;
'0'..'9': Block := Block * 10 + Ord(pIp^) - 48;
' ': { allow spaces }
else
raise {some error }
end;
Inc(pIP);
until (pIP - 1)^ = #00;
end;
call it using
x := IpToWord(PChar(mySTring))
2004. szeptember 20., hétfő
Generate random password string
Problem/Question/Abstract:
How can I generate the random password in own program?
Answer:
Solve 1:
In last holidays I wrote a small dialog for random password generation. It's a simple but results is very useful:))
Try it:
function TfrmPWGenerate.btnGenerateClick(Sender: TObject): string;
{max length of generated password}
const
intMAX_PW_LEN = 10;
var
i: Byte;
s: string;
begin
{if you want to use the 'A..Z' characters}
if cbAZ.Checked then
s := 'ABCDEFGHIJKLMNOPQRSTUVWXYZ'
else
s := '';
{if you want to use the 'a..z' characters}
if cbAZSmall.Checked then
s := s + 'abcdefghijklmnopqrstuvwxyz';
{if you want to use the '0..9' characters}
if cb09.Checked then
s := s + '0123456789';
if s = '' then
exit;
Result := '';
for i := 0 to intMAX_PW_LEN - 1 do
Result := Result + s[Random(Length(s) - 1) + 1];
end;
initialization
Randomize;
The sample results:
IBbfA1mVK2
tmuXIuQJV5
oNEY1cF6xB
flIUhfdIui
mxaK71dJaq
B0YTqxdaLh
...
I think that it's no bad:)) Of course, you can add the some additional crypt methods and check of unique.
Solve 2:
function GenPassWord(): string;
var
nCounter: integer;
cString: string;
cNumber: integer;
begin
Randomize;
cString := '';
// nCounter = password length
for nCounter := 0 to 8 do
begin
repeat
cNumber := Random(122);
// for capitol chrs extend the range
until (nNumber >= 97) and (nNumber <= 122);
cString := cString + Chr(nNumber);
end;
Result := cString;
end;
2004. szeptember 19., vasárnap
Explore your project directory
Problem/Question/Abstract:
Explore your project directory
Answer:
You probably spend a lot of time switching between Delphi's IDE and Windows' Explorer, continuously renaming, copying or moving something somewhere. And if your project directories are as (de-) organized as mine, you have to double-click at least 20 times before you get to your project directory.
Here's a simple solution:
1. Load Delphi.
2. Select Tools.
3. Select Configure Tools. The Tool Options dialog is displayed.
4. Select Add Command. The Tool Properties dialog is displayed.
5. Fill in the Tool Properties dialog as shown below. If your Windows Explorer is in another location, adjust the path accordingly.
Title: Open Project Directory
Program: C:\Windows\Explorer.exe
Working dir: [empty]
Parameters: /n,/e
6. Click OK, and then click Close.
That's it!
Now, just open a project and select the menu Tools / Open Project Directory.
2004. szeptember 18., szombat
How to extract an applet name from the Control Panel applets
Problem/Question/Abstract:
How to extract an applet name from the Control Panel applets
Answer:
*.cpl files are DLL's that export a function called CPlApplet, that you can use to get information about the applets contained in the file.
The following code demonstrates what to do. Refer to win32.hlp or MSDN.Microsoft.com for more information.
function LoadStringFromModule(Module: HInst; ID: Integer): string;
const
MaxLen = 2000;
var
Len: Integer;
begin
SetLength(Result, MaxLen);
Len := LoadString(Module, ID, PChar(Result), MaxLen);
if Len > 0 then
SetLength(Result, Len)
else
Result := '';
end;
type
TCPlAppletFunc = function(hwndCPl: HWnd; uMsg: DWord; lParam1: Longint;
lParam2: Longint): Longint; stdcall;
procedure ShowCPLNameAndDescription(FileName: string);
var
H: HInst;
CPlApplet: TCPlAppletFunc;
NumberOfApplets: Integer;
AppletInfo: TCPLInfo;
I: Integer;
Name, Desc: string;
begin
{Load CPL}
H := LoadLibrary(PChar(FileName));
if H <> 0 then
try
{Get CPlApplet Function from Module}
CPlApplet := GetProcAddress(H, 'CPlApplet');
if Assigned(CPlApplet) then
begin
{Get Number of Applets contained}
NumberOfApplets := CPlApplet(Application.Handle, CPL_GETCOUNT, 0, 0);
ShowMessage(Format('There are %d Applets in this file', [NumberOfApplets]));
{For each Applet in the file}
for I := 0 to NumberOfApplets - 1 do
begin
{Get Name and Desription}
CPlApplet(Application.Handle, CPL_INQUIRE, I, Longint(@AppletInfo));
Name := LoadStringFromModule(H, AppletInfo.idName);
Desc := LoadStringFromModule(H, AppletInfo.idInfo);
{And display them}
ShowMessage(Format('Applet No %d: %s / %s', [I, Name, Desc]));
end;
end;
finally
{Unload CPL}
FreeLibrary(H);
end;
end;
procedure TForm1.Button1Click(Sender: TObject);
begin
ShowCPLNameAndDescription('main.cpl');
end;
2004. szeptember 17., péntek
How to create and use a colour palette
Problem/Question/Abstract:
How to create and use a color palette
Answer:
Solve 1:
Below are functions that help to create a palette (an identity palette, BTW) from an array of RGBQuads (such as you would find in the palette section of a .BMP file). I stole this from the WinG documentation, and converted it to Delphi. First call ClearSystemPalette, then you can get an identity palette by calling CreateIdentityPalette. If you plan to try palette animation, work in a 256-color mode, and change all the PC_NOCOLLAPSE entries below to PC_RESERVED. Besides creating the palette, the other pieces to the puzzle are:
1. Override the form's GetPalette method, so that it returns the new palette.
2. Select and realize the new palette just before you paint.
OldPal := SelectPalette(Canvas.Handle, NewPalette, False);
RealizePalette(Canvas.Handle);
{ Do your painting here }
SelectPalette(Canvas.Handle, OldPal, False);
3. Remember to release the palette when you are done using DeleteObject
4. If you are used using the RGB function to get color values, use the PaletteRGB function in its place.
function CreateIdentityPalette(const aRGB; nColors: Integer): HPALETTE;
type
QA = array[0..255] of TRGBQUAD;
var
Palette: PLOGPALETTE;
PalSize: Word;
ScreenDC: HDC;
I: Integer;
nStaticColors: Integer;
nUsableColors: Integer;
begin
PalSize := SizeOf(TLOGPALETTE) + SizeOf(TPALETTEENTRY) * 256;
GetMem(Palette, PalSize);
try
with Palette^ do
begin
palVersion := $0300;
palNumEntries := 256;
ScreenDC := GetDC(0);
try
{ For SYSPAL_NOSTATIC, just copy the color table into a PALETTEENTRY
array and replace the first and last entries with black and white }
if (GetSystemPaletteUse(ScreenDC) = SYSPAL_NOSTATIC) then
begin
{ Fill in the palette with the given values, marking each with PalFlag }
{$R-}
for i := 0 to (nColors - 1) do
with palPalEntry[i], QA(aRGB)[I] do
begin
peRed := rgbRed;
peGreen := rgbGreen;
peBlue := rgbBlue;
peFlags := PC_NOCOLLAPSE;
end;
{ Mark any unused entries with PalFlag }
for i := nColors to 255 do
palPalEntry[i].peFlags := PC_NOCOLLAPSE;
{ Make sure the last entry is white -- This may replace an entry in the array!}
I := 255;
with palPalEntry[i] do
begin
peRed := 255;
peGreen := 255;
peBlue := 255;
peFlags := 0;
end;
{ And the first is black -- This may replace an entry in the array!}
with palPalEntry[0] do
begin
peRed := 0;
peGreen := 0;
peBlue := 0;
peFlags := 0;
end;
{$R+}
end
else
begin
{ For SYSPAL_STATIC, get the twenty static colors into the
array, then fill in the empty spaces with the given color table }
{ Get the static colors from the system palette }
nStaticColors := GetDeviceCaps(ScreenDC, NUMRESERVED);
GetSystemPaletteEntries(ScreenDC, 0, 256, palPalEntry);
{$R-}
{ Set the peFlags of the lower static colors to zero }
nStaticColors := nStaticColors shr 1;
for i := 0 to (nStaticColors - 1) do
palPalEntry[i].peFlags := 0;
{ Fill in the entries from the given color table}
nUsableColors := nColors - nStaticColors;
for I := nStaticColors to (nUsableColors - 1) do
with palPalEntry[i], QA(aRGB)[i] do
begin
peRed := rgbRed;
peGreen := rgbGreen;
peBlue := rgbBlue;
peFlags := PC_NOCOLLAPSE;
end;
{ Mark any empty entries as PC_NOCOLLAPSE }
for i := nUsableColors to (255 - nStaticColors) do
palPalEntry[i].peFlags := PC_NOCOLLAPSE;
{ Set the peFlags of the upper static colors to zero }
for i := (256 - nStaticColors) to 255 do
palPalEntry[i].peFlags := 0;
end;
finally
ReleaseDC(0, ScreenDC);
end;
end;
{ Return the palette }
Result := CreatePalette(Palette^);
finally
FreeMem(Palette, PalSize);
end;
end;
procedure ClearSystemPalette;
var
Palette: PLOGPALETTE;
PalSize: Word;
ScreenDC: HDC;
I: Word;
const
ScreenPal: HPALETTE = 0;
begin
PalSize := SizeOf(TLOGPALETTE) + SizeOf(TPALETTEENTRY) * 255; {256th = [0] }
GetMem(Palette, PalSize);
try
FillChar(Palette^, PalSize, 0);
Palette^.palVersion := $0300;
Palette^.palNumEntries := 256;
{$R-}
for I := 0 to 255 do
with Palette^.palPalEntry[I] do
peFlags := PC_NOCOLLAPSE;
{$R+}
{ Create, select, realize, deselect, and delete the palette }
ScreenDC := GetDC(0);
try
ScreenPal := CreatePalette(Palette^);
if ScreenPal <> 0 then
begin
ScreenPal := SelectPalette(ScreenDC, ScreenPal, FALSE);
RealizePalette(ScreenDC);
ScreenPal := SelectPalette(ScreenDC, ScreenPal, FALSE);
DeleteObject(ScreenPal);
end;
finally
ReleaseDC(0, ScreenDC);
end;
finally
FreeMem(Palette, PalSize);
end;
end;
Solve 2:
unit VideoFcns;
interface
uses Windows;
procedure GrayColorTable(const clrtable: PRGBQUAD; const threshold: integer = -1);
procedure BinaryColorTable(const clrtable: PRGBQUAD; const threshold: integer);
implementation
procedure GrayColorTable(const clrtable: PRGBQUAD; const threshold: integer);
var
j: integer;
cp: PRGBQUAD;
begin
if threshold <> -1 then
begin
BinaryColorTable(clrtable, threshold);
exit;
end;
cp := clrtable;
for j := 0 to 255 do
begin
{here you can set rgb components the way you like}
cp^.rgbBlue := j;
cp^.rgbGreen := j;
cp^.rgbRed := j;
cp^.rgbReserved := 0;
inc(cp);
end;
end;
procedure BinaryColorTable(const clrtable: PRGBQUAD; const threshold: integer);
var
j: integer;
g: integer;
cp: PRGBQUAD;
begin
cp := clrtable;
for j := 0 to 255 do
begin
if j < threshold then
g := 0
else
g := 255;
cp^.rgbBlue := g;
cp^.rgbGreen := g;
cp^.rgbRed := g;
cp^.rgbReserved := 0;
inc(cp);
end;
end;
Here is an example how palette is used:
procedure TBmpByteImage.FillBMPInfo(BMPInfo: pointer; const Wi, He: integer);
var
p: ^TBitmapInfo;
begin
p := BMPInfo;
p^.bmiHeader.biSize := sizeof(p.bmiHeader);
if Wi <> 0 then
p^.bmiHeader.biWidth := Wi
else
p^.bmiHeader.biWidth := w;
if He <> 0 then
p^.bmiHeader.biHeight := He
else
p^.bmiHeader.biHeight := h;
p^.bmiHeader.biPlanes := 1;
p^.bmiHeader.biBitCount := 8;
p^.bmiHeader.biCompression := BI_RGB;
p^.bmiHeader.biClrUsed := 0;
p^.bmiHeader.biClrImportant := 0;
end;
function TBmpByteImage.CreateDIB(const threshold: integer): HBITMAP;
var
dc: HDC;
bmpInfo: ^TBitmapInfo;
BMPData: pointer;
hBmp: HBITMAP;
x, y: integer;
cp1, cp2: pbyte;
begin
GetMem(bmpInfo, sizeof(bmpInfo.bmiHeader) + sizeof(RGBQUAD) * 256);
FillBMPInfo(BMPInfo);
{I am using a grey palette}
GrayColorTable(@bmpInfo^.bmiColors[0], threshold);
dc := CreateDC('DISPLAY', nil, nil, nil);
hBmp := CreateDIBSection(dc, bmpInfo^, DIB_RGB_COLORS, BMPData, 0, 0);
DeleteDC(dc);
FreeMem(bmpInfo, sizeof(bmpInfo.bmiHeader) + sizeof(RGBQUAD) * 256);
cp2 := BMPData;
for y := h - 1 downto 0 do
begin
cp1 := @g^[y]^[0];
for x := 0 to w - 1 do
begin
cp2^ := cp1^;
inc(cp1);
inc(cp2);
end;
end;
CreateDIB := hBmp;
end;
{and finally draw bitmap }
procedure TBmpByteImage.Draw(const where: TImage; const threshold: integer);
var
hBmp: HBITMAP;
Bitmap1: TBitmap;
begin
hBmp := CreateDIB(threshold);
if hBmp = 0 then
exit;
Bitmap1 := TBitmap.Create;
with Bitmap1 do
begin
Handle := hBmp;
Width := w;
Height := h;
end;
where.picture.Bitmap := Bitmap1;
Bitmap1.Free;
GlobalFree(hBmp);
end;
2004. szeptember 16., csütörtök
How to get the number of colours of a bitmap
Problem/Question/Abstract:
How to get the number of colours of a bitmap
Answer:
{ ... }
if Image1.Picture.Graphic is TBitmap then
begin
case Image1.Picture.Bitmap.PixelFormat of
{Find color depth}
pf1bit: pf := '. Monochrome';
pf4bit: pf := '. 16 Colors';
pf8bit: pf := '. 256 Colors';
pf15bit: pf := '. 32768 Colors';
pf16bit: pf := '. 65536 Colors';
pf24bit: pf := '. 16 Million Colors';
pf32bit: pf := '. Gazillions of Colors!';
else
pf := '. Custom color scheme';
end;
end;
2004. szeptember 15., szerda
An enhanced TQuery, combining the functionality of a TQuery, TBatchMove and TTable
Problem/Question/Abstract:
In many of my applications, when I perform a query, I write it out to disk, using a TBatchMove. How can I create a component that will combine the functionality of TQuery with a TBatchMove?
Answer:
Where's the Documentation?
One of my associates mentioned something recently that took me by surprise. He said there aren't many articles about building components in the major Delphi periodicals. When I really thought about it, and also perused some back issues of the periodicals I get, I realized he was correct. There were articles about specific components and what they do, but I couldn't find an article that dealt with building components in a general way.
I think the reason is that the process of building a component is a really involved and complex one. It doesn't matter whether the desired component's functionality is simple or not. There are just a lot of things you have to consider while building a component. And because of this, I don't think you could easily cover that type of material in a single article. You'd probably want to include it as several chapters in a book or devote an entire book to the subject, which is exactly what many writers have done.
Why is the process complex, even if what you might write is not? It has to do with the object hierarchy. When you build custom components, you will always inherit from a base class, be it TObject, TComponent or another class on the inheritance tree. To ensure that you aren't reinventing the wheel when writing new methods, it's a good idea to study the methods and properties of the ancestor class and even the ancestor's ancestor class, or further up the line if you want. I find myself doing it a lot when creating components because inadvertently redeclaring functions and properties without overriding base class functions and properties will usually get you in a lot of trouble with the compiler. Or, your component may compile, but it may not work as expected or — worse yet — not work at all.
This tip is no exception.
A New TQuery Component
One of the most common things you'll do when performing queries in Delphi is write the answer set(s) to persistent data stores. What does this involve? Let's look at the steps:
Create a TQuery
Load SQL into the TQuery
Open the Query
Create a destination TTable
Set its DatabaseName, TableName and TableType properties
Create a TBatchMove
Set its Source, Destination and Mode properties
Execute the TBatchMove
Fairly easy, but a lot of code to accomplish a really simple task. Here's an example:
InitQuery := TQuery.Create(Application);
with InitQuery do
begin
DatabaseName := 'PRIVATE';
Close;
SQL.Clear;
SQL.Add('SELECT D.BATCH, D.RECORD, D.ACCOUNT, D.FACILITY, D."INGREDIENT COST",');
SQL.Add('D."PHARMACY ID", D.DAW, D."DAYS SUPPLY", D."DISPENSING FEE",
D."MEMBER ID",');
SQL.Add('D."DOCTOR ID", D.NDC, D.FORMULARY, D."Apr Amt Due",');
SQL.Add('D1."DEA CODE", D1."GPI CODE", D1."DRUG NAME", D1."GENERIC CODE",
0 AS D."DAW COUNT"');
SQL.Add('FROM "' + EncPath + '" D, ":DRUGS:MDMDDB" D1');
SQL.Add('WHERE (D.' + DateFld + ' >= ' + BStart + ' AND D.' + DateFld + ' <= '
+ BEnd + ') AND');
SQL.Add('((D."RECORD STATUS" P'') OR (D."RECORD STATUS" R'')) ');
SQL.SaveToFile('mgrInit.sql');
try
Open;
try // Send the SQL result to :PRIV:INIT.DB
InitTable := "TTable.Create(Application);
"
with InitTable do
begin
DatabaseName := "PRIVATE";
TableName := "INIT";
end;
InitBatch := TBatchMove.Create(Application);
with InitBatch do
begin
Destination := InitTable;
Source := InitQuery;
Mode := batCopy;
Execute;
end;
finally
InitTable.Free;
InitBatch.Free;
end;
except
Free;
Abort;
end;
Free;
end;
Having grown tired of having to do this over and over in my code, I decided to create a component that combines all of the functionality mentioned above. In fact, there are not any multiple execution steps — just one call to make the thing go. This component is a descendant of TQuery, so it enjoys all of TQuery's features, but has the ability to execute the steps above with one call. Not only that, it's intelligent enough to know if you're doing a query, such as an UPDATE, that doesn't require writing to another table. I could go into a lot more detail with this but I won't because I documented the source code extensively. Let's take a look at it:
{==================================================================================
Program Name : TEnhQuery - Enhanced Query
Description : This component, derived from TQuery, was created to save coding by
integrating the functionality of performing a BatchMove into the
TQuery's execution code. Whenever you want to create a persistent
result set in code, you always have to create a TTable and a
TBatchMove to move the data from the Query to the persistent store.
This component eliminates that by creating the necessary objects
immediately after performing an open. The component is smart enough
to know if a BatchMove is actually necessary by parsing the SQL and
seeing if a SELECT is being performed. If it isn't, the component
will perform an ExecSQL instead. One other thing to note is that
I've included a lot of exception handling. Granted, they force a
silent Abort, but I've ensured there aren't any stray objects
floating around either.
Important Additions:
Properties: DestinationTable - Name of destination table. Defaults to 'INIT.DB'
DestDatabaseName - Name destination database. If a component is
dropped into a form, you can set this interactively
with a property editor I created for it.
DestBatchMoveMode - This is a property of type TBatchMode. Defaults
to batCopy.
DoBatchMove - Determines if a batch move should take place at
all. If it should (value = True), the SQL
result set will be moved to a persistent data
store. Otherwise, a regular Open will
occur.
Methods: Execute (virtual) This is what you will call when using this
component. However, since this is a descendant
of TQuery, you can always use Open or ExecSQL
to go around this function. Notice that this is
virtual, which means that you can add more
functionality if you wish.
DoEnhQueryOpen: This takes the place of the Open method, but
(virtual) since it's private, it can only be called by
Execute. It too is virtual, so you can override
its functionality. I suggest you keep it private
to avoid people inadvertently using it.
Notes:
You may get a couple of compiler warnings stating that the vars "btc" and "tbl" may
not have been initialized. Ignore them. The reason for the warning is because the
vars are declared but only initialized if the Open succeeded. No use in creating
them if they aren't needed.
==================================================================================}
unit enhquery;
interface
uses
Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
DB, DBTables, DSGNINTF, alnames;
type
TDBStringProperty = class(TStringProperty)
public
function GetAttributes: TPropertyAttributes; override;
procedure GetValueList(List: TStrings); virtual; abstract;
procedure GetValues(Proc: TGetStrProc); override;
end;
TDestDBProperty = class(TDBStringProperty)
public
procedure GetValueList(List: TStrings); override;
end;
{Main type information for TEnhQuery}
TEnhQuery = class(TQuery)
private
FDestTblName: string;
FDestDBName: string;
FBatchMode: TBatchMode;
FDoBatchMove: Boolean;
procedure SetDestTblName(Value: string);
procedure DoEnhQueryOpen; virtual;
public
constructor Create(AOwner: TComponent); override;
procedure Execute; virtual; {Let people override this}
published
property DestinationTable: string read FDestTblName write SetDestTblName;
property DestDatabaseName: string read FDestDBName write FDestDBName;
property DestBatchMoveMode: TBatchMode read FBatchMode write FBatchMode;
property DoBatchMove: Boolean read FDoBatchMove write FDoBatchMove;
end;
procedure Register;
implementation
constructor TEnhQuery.Create(AOwner: TComponent);
begin
inherited Create(AOwner);
FDestTblName := 'INIT.DB'; {Set initial value of Destination Table on Create}
FDestDBName := Session.PrivateDir;
FBatchMode := batCopy;
FDoBatchMove := True;
end;
procedure TEnhQuery.SetDestTblName(Value: string);
begin
if (FDestTblName <> Value) then
FDestTblName := Value;
end;
{=========================================================================
This is a very simple routine that will determine which route to take with
respect to executing the SQL query. It gives the component a bit of
intelligence, so the user need only use one call. Essentially, it looks
at the first line of the query; if it finds the word SELECT, then it
knows to call OpenProc, which will open the query and perform a batch move.
=========================================================================}
procedure TEnhQuery.Execute;
begin
if (SQL.Count > 0) then
if DoBatchMove then {Check to see if a batch move is desired}
if (Pos('SELECT', SQL[0]) > 0) then
if (DestinationTable <> '') and (DestDatabaseName <> '') then
try
DoEnhQueryOpen;
except
raise
Exception.Create('Enhanced Query DoEnhQueryOpen procedure did not execute
properly.Aborting');
Abort;
end
else
MessageDlg('You must supply a Destination Table and DatabaseName', mtError,
[mbOK], 0)
else
Open
else
try
ExecSQL;
except
raise Exception.Create('ExecSQL did not execute properly. Aborting');
Abort;
end
else
MessageDlg('You have not provided any SQL to execute' + #13 +
'so there is nothing to process. Load the' + #13 +
'SQL property with a query', mtError, [mbOk], 0);
end;
procedure TEnhQuery.DoEnhQueryOpen;
var
btc: TBatchMove;
tbl: TTable;
begin
try
Open;
try
tbl := TTable.Create(Application);
btc := TBatchMove.Create(Application);
with tbl do
begin
Active := False;
DatabaseName := DestDatabaseName;
TableName := DestinationTable;
end;
with btc do
begin
Source := Self;
Destination := tbl;
Mode := DestBatchMoveMode;
Execute;
end;
finally
btc.Free;
tbl.Free;
end;
except
Abort;
end;
end;
{=============================================================================
TDestDBProperty property editor override functions. Since the property editor
is derived from TStringProperty, we only need to override the functions
associated with displaying our dialog box.
=============================================================================}
function TDBStringProperty.GetAttributes: TPropertyAttributes;
begin
Result := [paValueList, paSortList, paMultiSelect];
end;
procedure TDBStringProperty.GetValues(Proc: TGetStrProc);
var
I: Integer;
Values: TStringList;
begin
Values := TStringList.Create;
try
GetValueList(Values);
for I := 0 to Values.Count - 1 do
Proc(Values[I]);
finally
Values.Free;
end;
end;
procedure TDestDBProperty.GetValueList(List: TStrings);
begin
(GetComponent(0) as TDBDataSet).DBSession.GetDatabaseNames(List);
end;
procedure Register;
begin
RegisterPropertyEditor(TypeInfo(string), TEnhQuery, 'DestDatabaseName',
TDestDBProperty);
RegisterComponents('BD', [TEnhQuery]);
end;
end.
With this component, here's all you do to perform a basic extract query:
Create an instance of the component
Set the SQL property
Set the Destination TableName (it defaults to 'INIT.DB')
Set the Destination DatabaseName (it defaults to Session.PrivateDir)
As you can see, it's all a matter of setting properties. You'll notice in the properties section of the code, I've got a property called DoBatchMove. This is a Boolean property that defaults to True. If you set it to false, the batch move will not occur, but the query will be opened. This ensures that you can use the component like a regular TQuery. You'd set this to False when you are using the component in conjunction with a TDataSource and TDBGrid.
As mentioned in the code comments, we have a custom property editor. For those of you who have wanted to learn how to do custom drop-down list property editors, study the code above. You'll be amazed at how incredibly easy it is to do.
Pat Richey of TeamBorland pointed me to the DBREG.PAS file in the \LIB directory to get the code for the property editor. I adapted it to use in this component. But the great thing about this is that once I implemented the property editor, I had a drop- down combo of databases, just like TQuery's and TTable's DatabaseName property!
2004. szeptember 14., kedd
How to wait for a file to be created
Problem/Question/Abstract:
Does anyone have code that will wait for a file to be created? In particular I'm trying to come up with code that has pretty much a 0% processor usage.
Answer:
The following function consumes very litte CPU while waiting for a file to be created:
function WaitForFile(FileName: string): Boolean;
{Wait for a file to be created. Tracks the directory were the file will be created.
Returns true if file exists, false on error.}
var
WaitHandle: THandle;
begin
Result := False; {Let's assume we failed}
WaitHandle := FindFirstChangeNotification(PChar(ExtractFilePath(FileName)),
False, FILE_NOTIFY_CHANGE_FILE_NAME);
if (INVALID_HANDLE_VALUE = WaitHandle) then
begin
{The path to the file does not exists}
Exit;
end;
repeat
if WaitForSingleObject(WaitHandle, INFINITE) = WAIT_OBJECT_0 then
begin {Something happenned in the directory}
if FileExists(FileName) then
begin
result := True;
Break; {My file has been created, exit}
end;
{My file is not there, keep on}
if not FindNextChangeNotification(WaitHandle) then
begin
{Something happened to the directory, maybe it was deleted}
Break;
end;
end;
until
False;
FindCloseChangeNotification(WaitHandle);
end;
2004. szeptember 13., hétfő
Controlling a TCommonDialog window at runtime
Problem/Question/Abstract:
How can I pop up a dialog like TOpenDialog in the corner of my screen instead of the center?
Answer:
This is kind of a weird one, because normally it's not something you'd consider. But take the situation in which you're editing a file and pop up a dialog box. By default, Windows dialogs pop up in the center of the screen, essentially blocking the view of your work. But to make matters worse, they're modal (which is probably a good thing anyway). So, in order to see your work - just in case you need the information underneath the dialog - you have to drag them to another location. No big deal, just a bit of a hassle.
Knowing this from the user's point of view, what can you do about it as a programmer? On the surface, it may seem that you won't be able to do much. The dialog boxes in Delphi are descendants of TCommonDialog, which is a standard Windows dialog, so direct manipulation with Delphi code isn't possible. Okay, I'm writing this article, so you know there's a way. But first, let's look at what we're faced with.
TCommonDialog boxes such as TOpenDialog and TSaveDialog are application-modal, meaning that when they pop up, your application is inaccessible.
Because of the inaccessibility mentioned above, direct manipulation of the windows is impossible.
Given these two factors, what do we do? Well, we go around the back door. And the way we'll do this is with a TTimer.
In point one (1), I mentioned that your application is rendered inaccessible when a TCommonDialog box pops up to the screen. But that doesn't necessarily mean it's not running. Things like a TTimer will still run even if you pop up a modal dialog box. With that in mind, all we have to do is start the TTimer before we execute the TCommonDialog and have the code in the TTimer's OnTimer event handle finding our dialog box and moving it to a new position. Let's look at some code:
unit main;
interface
uses
Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
ExtCtrls, StdCtrls;
type
TForm1 = class(TForm)
OpenDialog1: TOpenDialog;
Button1: TButton;
Timer1: TTimer;
procedure Button1Click(Sender: TObject);
procedure Timer1Timer(Sender: TObject);
private
{ Private declarations }
dlgTitle: PChar;
public
{ Public declarations }
end;
var
Form1: TForm1;
implementation
{$R *.DFM}
procedure TForm1.Button1Click(Sender: TObject);
begin
Timer1.Enabled := True; {Start the timer}
GetMem(dlgTitle, SizeOf(OpenDialog1.Title)); {Get memory for dialog title}
StrPCopy(dlgTitle, OpenDialog1.Title); {Fill the space}
OpenDialog1.Execute; {Pop up the dialog}
end;
procedure TForm1.Timer1Timer(Sender: TObject);
var
dlgWnd: HWND;
dlgX, dlgY: Integer;
dlgRect: TRect;
begin
dlgWnd := FindWindow('#32770', dlgTitle); {Find the dialog window}
if dlgWnd <> 0 then
begin
{In this next section we're going to get the dimensions of the dialog
so that we can use them to put the dialog right in the lower right-
hand corner of the screen. 0, 0 in place of the dlgX and dlgY vars
will place it where you want it.}
GetWindowRect(dlgWnd, dlgRect);
dlgX := Screen.Width - (dlgRect.Right - dlgRect.Left);
dlgY := Screen.Height - (dlgRect.Bottom - dlgRect.Top);
{Set the window's position and kill the timer}
SetWindowPos(dlgWnd, 0, dlgX, dlgY, 0, 0, SWP_NOSIZE);
Timer1.Enabled := False;
end;
{Regardless, get rid of this memory allocation. No stinkin' stray pointers}
FreeMem(dlgTitle, SizeOf(OpenDialog1.Title));
end;
end.
The code comments explain everything pretty clearly, so I won't go into details but I will tell you that I cheated. I had to ask around to find out what the class value for a TOpenDialog box was. However, the nice thing about the 32770 value is that it is the class value for all TCommonDialog descendants. Therefore, you can use it for all of them. Nice.
As you can see from the code above, I start the timer running before I call the execute of the OpenDialog1. Then when the OnTimer event fires off, I look for the dialog window using my handy-dandy class value and the title of the dialog that I passed into a PChar (because FindWindow will only take a null-terminated string). After that, I get the window's dimensions then use them to compute its position relative to the screen to put it in the lower right-hand corner of the screen. After that, I kill the timer, free unused memory space, and WHAMO! I've got a TCommonDialog popping up where I want it and not where Windows will put it.
Are there any down sides to this? The obvious one you'll find when you put this code together is that there is a noticeable flash as the dialog gets moved. This is due in part to the TTimer. I set its interval value to 50ms; a lower value would be negligible for moving the window in time. The only way to prevent the flash is to get a hook into the Windows workspace and keep it from painting. But that would take a heck of a lot of code to put together; in other words, it's more trouble than it's worth.
2004. szeptember 12., vasárnap
How to get runtime properties of a component at runtime
Problem/Question/Abstract:
How to get runtime properties of a component at runtime
Answer:
You may need to know at runtime what properties are available for a particular component at runtime. The list can be obtained by a call to GetPropList. The types, functions and procedures, including GetPropList, that allow access to this property information reside in the VCL source file TYPINFO.PAS.
GetPropList Parameters
function GetPropList(TypeInfo: PTypeInfo; TypeKinds: TTypeKinds; PropList: PPropList):
Integer;
The first parameter for GetPropList is of type PTypeInfo, and is part of the RTTI (Run Time Type Information) available for any object. The record structure defined:
PPTypeInfo = ^PTypeInfo;
PTypeInfo = ^TTypeInfo;
TTypeInfo = record
Kind: TTypeKind;
Name: ShortString;
{TypeData: TTypeData}
end;
The TTypeInfo record can be accessed through the objects ClassInfo property. For example, if you were getting the property list of a TButton, the call might look, so far, like this:
GetPropList(Button1.ClassInfo, ....
The second parameter, of type TTypeKinds, is a set type that acts as a filter for the kinds of properties to include in the list. There are a number of valid entries that could be included in the set (see TYPEINFO.PAS), but tkProperties covers the majority. Now our call to GetPropList would look like:
GetPropList(Button1.ClassInfo, tkProperties....
The last parameter, PPropList is an array of PPropInfo and is defined in TYPEINFO.PAS:
PPropList = ^TPropList;
TPropList = array[0..16379] of PPropInfo;
Now the call might read:
procedure TForm1.FormCreate(Sender: TObject);
var
PropList: PPropList;
begin
PropList := AllocMem(SizeOf(PropList^));
GetPropList(TButton.ClassInfo, tkProperties + [tkMethod], PropList);
{...}
Getting Additional Information from the TTypeInfo Record:
The example at the end of this document lists not just the property name, but it's type. The name of the property type resides in an additional set of structures. Let's take a second look at the TPropInfo record. Notice that it contains a PPTypeInfo that points ultimately to a TTypeInfo record. TTypeInfo contains the class name of the property.
PPropInfo = ^TPropInfo;
TPropInfo = packed record
PropType: PPTypeInfo;
GetProc: Pointer;
SetProc: Pointer;
StoredProc: Pointer;
Index: Integer;
Default: Longint;
NameIndex: SmallInt;
Name: ShortString;
end;
PPTypeInfo = ^PTypeInfo;
PTypeInfo = ^TTypeInfo;
TTypeInfo = record
Kind: TTypeKind;
Name: ShortString;
{TypeData: TTypeData}
end;
The example below shows how to set up the call to GetPropList, and how to access the array elements. TForm will be referenced in this example instead of TButton, but you can substitute other values in the GetPropList call. The visible result will be to fill the list with the property name and type of the TForm properties.
This project requires a TListBox. Enter the code below in the forms OnCreate event handler.
uses
TypInfo;
procedure TForm1.FormCreate(Sender: TObject);
var
PropList: PPropList;
i: integer;
begin
PropList := AllocMem(SizeOf(PropList^));
i := 0;
try
GetPropList(TForm.ClassInfo, tkProperties + [tkMethod], PropList);
while (PropList^[i] <> nil) and (i < High(PropList^)) do
begin
ListBox1.Items.Add(PropList^[i].Name + ': ' + PropList^[i].PropType^.Name);
Inc(i);
end;
finally
FreeMem(PropList);
end;
end;
2004. szeptember 11., szombat
Turn functions and procedures with parameters into threads
Problem/Question/Abstract:
I want to learn how to create and use threads. I have several functions and procedures that are used many times within button click events. The procedures and functions all have at least one parameter (no directives) and one function produces a result (a stringlist). I've spent part of the day reading about threads and how to create them and doing some experimenting. The easiest way seems to be to create a descendant of TThread. But I can't figure out how to handle the parameters.
Answer:
The classic method is this. Pass them to the thread constructor as parameters and, in the constructor, store them in fields of the thread object. When the thread runs, it can use these fields:
myThread = class(TThread)
private
myParam1: integer;
myParam2: integer;
protected
procedure execute; override;
public
constructor create(param1; param2: integer);
end;
myThread.create(param1, param2: integer);
begin
inherited create(true);
myParam1 := param1;
myParam2 := param2;
resume;
end;
If the thread needs a stringList for it's output, create one in the thread, store in the results & post the results back to the main VCL thread.
resultList := TStringList.create;
{ ... }
postMessage(myFormHandle, VCL_MESSSAGE, integer(resultList), 0);
The 'myFormHandle' HWND parameter for the postMessage call will need to be passed in as one of the constructor parameters, as described earlier. VCL_MESSAGE is just some const message number, eg. WM_APP+1000. The form, or whatever component whose handle is passed, will need a message handler procedure to catch the result, but this is fairly well explained in the onLine help:
procedure VCLMESSAGE(var message: TMessage); message VCL_MESSAGE;
{ ... }
procedure myForm.VCLMESSAGE(var message: TMessage);
var
resultList: TStringList;
begin
resultList := TStringList(message.wParam);
end;
Don't forget to free the result stringList after handling it, like I did in my exaple code!
2004. szeptember 10., péntek
Get a list of registered files and their extensions
Problem/Question/Abstract:
Is there a Windows API that returns the name of the program that a particular file extension is associated with?
Answer:
Solve 1:
To get a list of the applications and their extensions for opening up files in Windows95 do the following:
procedure TForm1.FormShow(Sender: TObject);
var
K: TRegIniFile;
i: Integer;
Extensions: TStringList;
begin
K := TRegIniFile.Create('');
K.RootKey := HKEY_LOCAL_MACHINE;
K.OpenKey('SOFTWARE\MicroSoft\Windows\CurrentVersion\Extensions', False);
Extensions := TStringList.Create;
K.GetValueNames(Extensions);
for i := 0 to Extensions.Count - 1 do
Memo1.Lines.Add(Extensions.Strings[i] + ' = ' + K.ReadString('',
Extensions.Strings[i], ''));
Extensions.Free;
K.Free;
end;
Solve 2:
Enumerate all extensions and their servers in the registry:
procedure TForm1.Button1Click(Sender: TObject);
var
reg: TRegistry;
keys: TStringList;
i: Integer;
typename, displayname, server: string;
begin
memo1.clear;
reg := TRegistry.Create;
try
reg.rootkey := HKEY_CLASSES_ROOT;
if reg.OpenKey('', false) then
begin
keys := TStringlist.create;
try
reg.GetKeyNames(keys);
reg.closekey;
{memo1.lines.addstrings(keys);}
for i := 0 to keys.count - 1 do
begin
if keys[i][1] = '.' then
begin
{this is an extension, get its typename}
if reg.OpenKey(keys[i], false) then
begin
typename := reg.ReadString('');
reg.closekey;
if typename <> '' then
begin
if reg.OpenKey(typename, false) then
begin
displayname := reg.readstring('');
reg.closekey;
end;
if reg.OpenKey(typename + '\shell\open\command', false) then
begin
server := reg.readstring('');
memo1.lines.add(format('Extension: "%s", Typename: "%s",
Displayname:"%s"' + #13#10' Server: %s', [keys[i],
typename, displayname, server]));
reg.closekey;
end;
end;
end;
end;
end;
finally
keys.free;
end;
end;
finally
reg.free
end;
end;
2004. szeptember 9., csütörtök
How to check whether a program is available on a PC
Problem/Question/Abstract:
How do you find out whether a program is available ? For example, how can you programmatically tell whether MS Word 2000 is installed rather than Lotus WordPro? The OS can be Win95, 98, ME, 2000, NT4. I did not find any Win API function allowing to find out if a specific application exists on the machine. The nearest I found is the FindExecutable function but you need to pass it a document file name. Should I read the registry, to enumerate the currently installed applications?
Answer:
For the MS Word case, you might want to start Word in automation mode to see if its present. The following routine does that:
function IsWordPresent(var IsActive: Boolean): Boolean;
var
MSWord: Variant;
begin
Result := False;
IsActive := False;
try
MSWord := GetActiveOleObject('Word.Application');
Result := not VarIsEmpty(MSWord);
IsActive := not VarIsEmpty(MSWord)
except
MSWord := Unassigned
end;
if VarIsEmpty(MSWord) then
begin
try
MSWord := CreateOleObject('Word.Application');
Result := not VarIsEmpty(MSWord);
if Result then
MSWord.Quit
except
end;
end;
end;
2004. szeptember 8., szerda
How to create only one instance of a MDI child form (3)
Problem/Question/Abstract:
How can I prevent to open a MDIChild if it is already open? When I select the same option on the menu, the first code executes again and I get two forms.
Answer:
procedure TformMain.doDisplayCustomerLookupGrid(Sender: TObject);
var
MyChildFormName: string;
MyChild: TformCustGrid;
I: Integer;
begin
MyChildFormName := 'Customer Lookup';
{ If the child form already exists, make it active }
with formMain do
for I := 0 to MDIChildCount - 1 do
begin
if MDIChildren[I].Caption = MyChildFormName then
begin
MDIChildren[I].BringToFront;
exit;
end;
end;
{ If the child form does not exist, create it }
MyChild := TformCustGrid.Create(Application);
MyChild.Caption := MyChildFormName;
end;
2004. szeptember 7., kedd
Changing the z-order of controls
Problem/Question/Abstract:
How to move a control just one position within the z-order of the parent.
Answer:
The default methods
Usually you can bring any control on a form to front or send it to the back using the methods supplied with the TControl class.
AnyControl.BringToFront;
AnyControl.SendToBack;
However, often these methods will not suffice. If you want to move the control just one position, there are no public methods to acompolish just this. In the private section of the TControl-class you find the method SetZOrderPosition which you cannot use. Looking at the source code, you'll notice, you cannot even cut-n-copy that, as it is accessing some private variables/objects, which are not made public either.
A simple solution
The solution, to work around this limitation, is to move the control either to the top or the back and move the others, that should remain in front (or behind), too. The following procedure will do just this.
The first parameter Sender takes the control to be moved. The second paramter points the direction. True will bring it to front, False will move it to the back.
procedure ChangeControlZOrder(Sender: TObject; MoveUp: Boolean = True);
var
I, Curr: Integer;
Control: TControl;
List: TList;
begin
if Sender is TControl then
begin
// sender is an control
Control := Sender as TControl;
// check for parent control, managing the z-order
if Control.Parent = nil then
// not available
Exit;
// get position of the sender
Curr := -1;
for I := 0 to Pred(Control.Parent.ControlCount) do
if Control.Parent.Controls[I] = Sender then
begin
Curr := I;
Break;
end;
if Curr < 0 then
// hm, position not found
Exit;
List := TList.Create;
try
if MoveUp then
begin
for I := Curr + 2 to Pred(Control.Parent.ControlCount) do
// get the other controls, to be moved, too
List.Add(Control.Parent.Controls[I]);
// bring sender to front
Control.BringToFront;
for I := 0 to Pred(List.Count) do
// move the remaining controls
TControl(List[I]).BringToFront;
end
else
begin
for I := 0 to Curr - 2 do
// get the other controls, to be moved, too
List.Add(Control.Parent.Controls[I]);
// send sender to back
Control.SendToBack;
for I := Pred(List.Count) downto 0 do
// move the remaining controls
TControl(List[I]).SendToBack;
end;
finally
List.Free;
end;
end;
end;
2004. szeptember 6., hétfő
How to store events in a TList (2)
Problem/Question/Abstract:
What I am trying to achieve is to let many different objects attach to a single event. I did it with Interfaces but I want to do it with normal methods now. My first attempt was to simply store a pointer in a TList, but of course it did not work. I did not think about the Code and Data pointers. My question: How do I store methods in a list in a generic way? I do not want to specify the event type in my base class, only in my specialized classes.
Answer:
The problem is that a TNotifyEvent is more than a pointer: it includes both data and class information. In any case, here is a solution for you. Drop two buttons on a form, and link the Unit1 code in below.
unit Unit1;
interface
uses
Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs, Contnrs,
StdCtrls;
type
TNotifyEventObj = class
private
FNotifyEvent: TNotifyEvent;
public
constructor Create(aNE: TNotifyEvent);
property NotifyEvent: TNotifyEvent read FNotifyEvent write FNotifyEvent;
end;
TForm1 = class(TForm)
Button1: TButton;
Button2: TButton;
procedure Button1Click(Sender: TObject);
procedure Button2Click(Sender: TObject);
private
{ Private declarations }
FList: TObjectList;
FCount: integer;
procedure CountEvent(Sender: TObject);
public
{ Public declarations }
constructor Create(AOwner: TComponent); override;
destructor Destroy; override;
procedure AddEvent(aNE: TNotifyEvent);
end;
var
Form1: TForm1;
implementation
{$R *.DFM}
{ TNotifyEventObj }
constructor TNotifyEventObj.Create(aNE: TNotifyEvent);
begin
FNotifyEvent := aNE;
end;
{ TForm1 }
constructor TForm1.Create(AOwner: TComponent);
begin
inherited;
FCount := 0;
FLIst := TObjectList.Create;
end;
destructor TForm1.Destroy;
begin
FList.Free;
inherited;
end;
procedure TForm1.Button1Click(Sender: TObject);
begin
AddEvent(CountEvent);
end;
procedure TForm1.Button2Click(Sender: TObject);
var
lNE: TNotifyEvent;
I: Integer;
begin
for I := 0 to FList.Count - 1 do { Iterate }
begin
lNE := TNotifyEventObj(FList[I]).NotifyEvent;
lNE(self);
end;
end;
procedure TForm1.AddEvent(aNE: TNotifyEvent);
begin
FLIst.Add(TNotifyEventObj.Create(aNE));
end;
procedure TForm1.CountEvent(Sender: TObject);
begin
FCount := FCount + 1;
Caption := IntToStr(FCount);
end;
end.
2004. szeptember 5., vasárnap
How to play two sounds simultaneously
Problem/Question/Abstract:
I'd like to have a background.wav file playing and once in a while have a short effects .wav sound play at the same time (without interrupting - stopping and restarting it - the background .wav).
Answer:
The Delphi code below plays two sounds concurrently under Win95. I think concurrent sound playing relies on the driver supporting multiple inputs, and I believe you could request if it has this capability before trying to play.
procedure TForm1.Button1Click(Sender: TObject);
begin
SendMCICommand('open waveaudio shareable');
SendMCICommand('play hickory.wav');
SendMCICommand('play greeting.wav');
SendMCICommand('close waveaudio');
end;
procedure TForm1.SendMCICommand(Cmd: string);
var
RetVal: integer;
ErrMsg: array[0..254] of char;
begin
RetVal := mciSendString(StrAsPChar(Cmd), nil, 0, 0);
if RetVal <> 0 then
begin
{get message for returned value}
mciGetErrorString(RetVal, ErrMsg, 255);
MessageDlg(StrPas(ErrMsg), mtError, [mbOK], 0);
end;
end;
function StrAsPChar(var S: OpenString): PChar;
{returns a PChar from a string}
begin
if Length(S) = High(S) then
dec(S[0]);
S[Ord(Length(s)) + 1] := #0;
Result := @S[1];
end;
2004. szeptember 4., szombat
How to fade text in and out on a TCanvas
Problem/Question/Abstract:
How to fade text in and out on a TCanvas
Answer:
function TFadeEffect.FadeInText(Target: TCanvas; X, Y: integer; FText: string): TRect;
var
Pic: TBitmap;
W, H: integer;
PicRect, TarRect: TRect;
begin
Pic := TBitmap.Create;
Pic.Canvas.Font := Target.Font;
W := Pic.Canvas.TextWidth(FText);
H := Pic.Canvas.TextHeight(FText);
Pic.Width := W;
Pic.Height := H;
PicRect := Rect(0, 0, W, H);
TarRect := Rect(X, Y, X + W, Y + H);
Pic.Canvas.CopyRect(PicRect, Target, TarRect);
SetBkMode(Pic.Canvas.Handle, Transparent);
Pic.Canvas.TextOut(0, 0, FText);
FadeInto(Target, X, Y, Pic);
Pic.Free;
FadeInText := TarRect;
end;
procedure TFadeEffect.FadeOutText(Target: TCanvas; TarRect: TRect; Orig: TBitmap);
var
Pic: TBitmap;
PicRect: TRect;
begin
Pic := TBitmap.Create;
Pic.Width := TarRect.Right - TarRect.Left;
Pic.Height := TarRect.Bottom - TarRect.Top;
PicRect := Rect(0, 0, Pic.Width, Pic.Height);
Pic.Canvas.CopyRect(PicRect, Orig.Canvas, TarRect);
FadeInto(Target, TarRect.Left, TarRect.Top, Pic);
Pic.Free;
end;
2004. szeptember 3., péntek
How to check for a duplicate key index programmatically
Problem/Question/Abstract:
I have a DBISAM 2.04 table with several indexes. It actually lists project details. One field is the ProjectNo (a text field some 20 char wide). I want to make sure that the same PropjectNo is not entered twice. I could make the index unique, and that would no doubt work. But the error message returned in not very user friendly - I would rather trap it myself. I assume that in the OnBeforEInsert event I would have some code that checks to see if this index key already exists. If so, then I warn the user (perhaps even allowing the record to be saved if the user insists). And then aborting the save if a duplicate. How do I find an existing key, i.e. something like KeyExists(['99023']) ? Would I have to do a Locate or something?
Answer:
Make a generic function like:
function TMyForm.CheckDuplicateKey(ATable: string; const Field: TField): Boolean;
var
cSQL, KeyField, cValue: string;
begin
KeyField := Field.FieldName;
cValue := Field.AsString;
cSQL := Format('select %s from %s where %s = %s', [KeyField, ATable, KeyField, cValue]);
with LookupQuery do
begin
SQL.Clear;
SQL.Add(cSQL);
Open;
if RecordCount > 0 then
Result := True
else
Result := False;
Close;
end;
end;
and use it in your key field's OnValidate handler like:
procedure TMyForm.MainQueryMyIDValidate(Sender: TField);
begin
if CheckDuplicateKey('MyTable', Sender) then
raise Exception.Create('The table already has a record with this key.');
end;
2004. szeptember 2., csütörtök
How to copy multiple files into one (2)
Problem/Question/Abstract:
What is the quickest way of merging loads of files together, and being able to pull them out when needed in the application all files have unique names, I need to merge the files as the application could create 10000+ and all them being in one dirctory, well lets say windows does not handle it very well specially the fact that they are all small file with the odd occasion of a 15mb file, so I need a better way off managing it not interested in compression I want something that is as quick or quicker than access an individual file.
Answer:
Solve 1:
If you do not need random access to the files in the larger file (in which case you need an index, a kind of directory) you can simply concatenate the source files, storing the file name and size for each file in front of the files data.
procedure ConCatFiles(const targetname: string; const Sourcenames: TStrings);
var
i: Integer;
target, source: TFileStream;
fsize: Longint;
begin
target := TFileStream.Create(targetname, fmCreate);
try
for i := 0 to Sourcenames.Count - 1 do
begin
source := TFileStream.Create(Sourcenames[i], fmOpenread or fmShareDenyNone);
try
fsize := Length(Sourcenames[i]);
target.Write(fsize, Sizeof(fsize));
target.Write(Sourcenames[i][1], fsize);
fsize := source.size;
target.Write(fsize, Sizeof(fsize));
target.Copyfrom(source, 0);
finally
source.free;
end;
end;
finally
target.Free;
end;
end;
procedure UnmergeFiles(const sourcename: string);
var
i: Integer;
target, source: TFileStream;
fsize, sourcesize: Longint;
fname: string;
begin
source := TFileStream.Create(sourcename, fmOpenread or fmShareDenyNone);
try
sourcesize := source.size;
while source.position < sourcesize do
begin
source.Read(fsize, Sizeof(fsize));
SetLength(fname, fsize);
source.Read(fname[1], fsize);
target := TFileStream.Create(fname, fmCreate);
try
source.Read(fsize, Sizeof(fsize));
target.Copyfrom(source, fsize);
finally
target.free;
end;
end;
finally
source.Free;
end;
end;
Untested! And of course you should think about how to handle pathes in this context.
Solve 2:
I've written a little example that doesn't consume too much memory. It concatenates and compresses files into one destination file (CompressFiles) and can restore then in a given location (DecompressFiles).
{ ... }
implementation
{$R *.dfm}
uses
zLib;
procedure CompressFiles(Files: TStrings; const Filename: string);
var
infile, outfile, tmpFile: TFileStream;
compr: TCompressionStream;
i, l: Integer;
s: string;
begin
if Files.Count > 0 then
begin
outFile := TFileStream.Create(Filename, fmCreate);
try
{the number of files}
l := Files.Count;
outfile.Write(l, SizeOf(l));
for i := 0 to Files.Count - 1 do
begin
infile := TFileStream.Create(Files[i], fmOpenRead);
try
{the original filename}
s := ExtractFilename(Files[i]);
l := Length(s);
outfile.Write(l, SizeOf(l));
outfile.Write(s[1], l);
{the original filesize}
l := infile.Size;
outfile.Write(l, SizeOf(l));
{compress and store the file temporary}
tmpFile := TFileStream.Create('tmp', fmCreate);
compr := TCompressionStream.Create(clMax, tmpfile);
try
compr.CopyFrom(infile, l);
finally
compr.Free;
tmpFile.Free;
end;
{append the compressed file to the destination file}
tmpFile := TFileStream.Create('tmp', fmOpenRead);
try
outfile.CopyFrom(tmpFile, 0);
finally
tmpFile.Free;
end;
finally
infile.Free;
end;
end;
finally
outfile.Free;
end;
DeleteFile('tmp');
end;
end;
procedure DecompressFiles(const Filename, DestDirectory: string);
var
dest, s: string;
decompr: TDecompressionStream;
infile, outfile: TFilestream;
i, l, c: Integer;
begin
dest := IncludeTrailingPathDelimiter(DestDirectory);
infile := TFileStream.Create(Filename, fmOpenRead);
try
{number of files}
infile.Read(c, SizeOf(c));
for i := 1 to c do
begin
{read filename}
infile.Read(l, SizeOf(l));
SetLength(s, l);
infile.Read(s[1], l);
{read filesize}
infile.Read(l, SizeOf(l));
{decompress the files and store it}
s := dest + s; {include the path}
outfile := TFileStream.Create(s, fmCreate);
decompr := TDecompressionStream.Create(infile);
try
outfile.CopyFrom(decompr, l);
finally
outfile.Free;
decompr.Free;
end;
end;
finally
infile.Free;
end;
end;
2004. szeptember 1., szerda
How can I get a computer's IP address?
Problem/Question/Abstract:
How can I get a computer's IP address ?
Answer:
unit Unit1;
interface
uses
Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
StdCtrls, Winsock;
type
TForm1 = class(TForm)
Button1: TButton;
procedure Button1Click(Sender: TObject);
private
{ Private declarations }
public
{ Public declarations }
function DetectHostIP: Boolean;
end;
const
HostIP: string = 'Unknown';
var
Form1: TForm1;
implementation
{$R *.DFM}
procedure TForm1.Button1Click(Sender: TObject);
begin
DetectHostIP;
end;
//Detect own TCP/IP address
function TForm1.DetectHostIP: Boolean;
var
wsdata: TWSAData;
hostName: array[0..255] of char;
hostEnt: PHostEnt;
addr: PChar;
begin
WSAStartup($0101, wsdata);
try
gethostname(hostName, sizeof(hostName));
hostEnt := gethostbyname(hostName);
if Assigned(hostEnt) then
if Assigned(hostEnt^.h_addr_list) then
begin
addr := hostEnt^.h_addr_list^;
if Assigned(addr) then
begin
HostIP := Format('%d.%d.%d.%d', [byte(addr[0]),
byte(addr[1]), byte(addr[2]), byte(addr[3])]);
Result := True;
end
else
Result := False;
end
else
Result := False
else
begin
MessageDlg(Format('Winsock error %d', [WSAGetLastError]), mtError, [mbOk], 0);
Result := False;
end;
finally
WSACleanup;
end
end;
Feliratkozás:
Bejegyzések (Atom)