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; // ??&micro;????�?�
  BMPF: TMemoryStream; // ?&raquo;?�?ġ?
  SentinelF: TMemoryStream; //?�����&para;?  16�ֽ?

  bif: BITMAPINFO256; // ?&raquo;?�?ġ??�?�
  bfh: BITMAPFILEHEADER; // ?&raquo;?�?ġ??ġ??&middot; 14�ֽ?

  PosSentinel: LongInt; // ?�����&para;??&raquo;�?

  LenPreview: Integer; // �??�����&para;?�&reg;??�?&not;�?�???��&not;??&micro;?&micro;ij�&para;?
  RasterPreview: ShortInt; // ?&micro;?�?�???��&not;????&micro;�?&raquo;&not;�&micro;?�ֽ?�???
  // 0  �&raquo;&plusmn;�???�???��&not; 1  &plusmn;�??BMP?��&not;
    // 2  &plusmn;�??WMF?��&not;    3  ?&not;?&plusmn;&plusmn;�??BMP??WMF?��&not;
  PosBMP: Integer; // ?��&not;&micro;�տ?&micro;?&raquo;�?�&not;�&raquo;?&raquo;&para;&laquo;???&raquo;?�
  LenBMP: Integer; // ?��&not;��&para;?�&not;�&raquo;?&not;BITMAPFILEHEADER??&micro;?�&not;�&raquo;?&raquo;&para;&laquo;???&raquo;?�
  IndexPreview: Integer;
  TypePreview: Shortint; // ?��&not;????
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�&brvbar;�&not;???�����&para;?
    DWGF.Read(PosSentinel, 4);
    DWGF.Position := PosSentinel;
    SentinelF.CopyFrom(DWGF, 16); // &para;????�����&para;?
    DWGF.Read(LenPreview, 4); // &para;???
    DWGF.Read(RasterPreview, 1); // &para;????��&not;????
    for IndexPreview := RasterPreview - 1 downto 0 do
    begin
      MemF.Position := 0;
      MemF.CopyFrom(DWGF, 9); // ?��&not;???�?� 9�ֽ?
      MemF.Position := 0;
      MemF.Read(TypePreview, 1); // TypePreview ?��&not;????
      case TypePreview of
        1: ; // ?�??&micro;�???��???
        2:
          begin
            // BMP?��&not;,??DWG?ġ?�?&plusmn;���&micro;�BMP?��&not;?�????????�?BMP&plusmn;�&middot;&para;&micro;�
            // ?�?�?ġ???&micro;?�&not;&micro;&laquo;??�&raquo;&plusmn;���BITMAPFILEHEADER??&micro;?
            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?ġ?�&not;?��?22�ֽ?��&micro;�Aldus?ġ??&middot;
      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 "&AMP" 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 &#8212; worse yet &#8212; 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 &#8212; 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;