Minimze and close the application by simple rolling your mouse over the applications system buttons

Problem/Question/Abstract:

How can I minimize Close the application by rolling my mouse over the system controls

Answer:

unit Unit1;

interface

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

type
  TForm1 = class(TForm)
    Button1: TButton;
    procedure Button1Click(Sender: TObject);
    procedure FormCreate(Sender: TObject);
  private
    procedure lik(var Msg: TWMNCHITTEST); message WM_NCHITTEST;
  public
    { Public declarations }
  end;

var
  Form1: TForm1;
  tx: Boolean;
implementation

{$R *.DFM}

procedure TForm1.lik(var Msg: TWMNCHITTEST);
begin
  inherited; //respond to other commands
  if tx = true then //check if it's enabled
  begin
    if Msg.Result = Windows.HTMINBUTTON then
      Application.Minimize
    else if Msg.Result = Windows.HTCLOSE then
      Close; //make widows to do it
  end;
end;

procedure TForm1.Button1Click(Sender: TObject);
begin
  tx := True; //This enables the function
end;

procedure TForm1.FormCreate(Sender: TObject);
begin
  tx := False; //This disables it
end;

end.

Grab two characters from a TEdit

Problem/Question/Abstract:

Assume the following entry in an edit box: '12-13-14-15-16'. Then, I would like to grab the '14' for example. I know that it is from position 7 to 8.

Answer:

This can be done with:

{ ... }
sTheChars := Copy(Edit1.Text, 7, 2);

7 = starting character's position (1 = first character)
2 = number of characters to copy

Parsing quoted strings

Problem/Question/Abstract:

How do I parse a string containing quoted strings and other tokens?

Answer:

{
  These routines can be used to parse strings.
  Use GetToken to extract normal tokens from InTxt.
  Use GetTokenStr to extract quoted tokens from InTxt.

  GetTokenStr raises an exception in case of an error. Use
  try..except blocks to handle these.
}
type
  CharSet = set of char;
const
  CS_Space: CharSet = [' '];
const
  CS_CSV: CharSet = [',', ' '];
const
  CS_STab: CharSet = [#9, ' '];
const
  DoubleQuote = '"';
const
  SingleQuote = '''';

function GetToken(var InTxt: string; SpaceChar: CharSet): string;
var
  i: Integer;
begin
  { Find first SpaceCharacter }
  i := 1;
  while (i <= length(InTxt)) and not (InTxt[i] in SpaceChar) do
    inc(i);
  { Get text upto that spacechar }
  Result := Copy(InTxt, 1, i - 1);
  { Remove fetched part from InTxt }
  Delete(InTxt, 1, i);
  { Delete SpaceChars in front of InTxt }
  i := 1;
  while (i <= length(InTxt)) and (InTxt[i] in SpaceChar) do
    inc(i);
  Delete(InTxt, 1, i - 1);
end;

function GetTokenStr(var InTxt: string; SpaceChar: CharSet; QuoteChar: Char): string;
var
  Done: Boolean;
  i: Integer;
begin
  { Error checking: Does the string start with a quote? }
  if Copy(InTxt, 1, 1) <> QuoteChar then
    raise Exception.Create('Expected ' + QuoteChar + ' but ' + Copy(InTxt, 1, 1) +
      ' found.');

  { Remove starting quote }
  Delete(InTxt, 1, 1);

  { Init result }
  Result := '';

  { Find a quote char that ends the string }
  repeat
    { Find first QuoteCharacter }
    i := 1;
    while (i <= length(InTxt)) and not (InTxt[i] = QuoteChar) do
      inc(i);

    { Error checking: Unsuspected end of string? }
    if i > Length(InTxt) then
      raise exception.create('Unexpected end of string.');

    { Copy upto (but not including) the quote char }
    Result := Result + Copy(InTxt, 1, i - 1);

    { Remove parsed part from InTxt }
    Delete(InTxt, 1, i);

    { If it isn't a double quote, we're done. }
    Done := (Copy(InTxt, 1, 1) <> QuoteChar);

    { If not done...}
    if not Done then
    begin
      { Insert a quote in the result token }
      Result := Result + QuoteChar;
      { Remove 2nd parsed quote from InTxt }
      Delete(InTxt, 1, 1);
    end;
  until Done;

  { Delete SpaceChars in front of InTxt }
  i := 1;
  while (i <= length(InTxt)) and (InTxt[i] in SpaceChar) do
    inc(i);
  Delete(InTxt, 1, i - 1);
end;

Usage Example:

var
  s: string;
begin
  s := '"John Smith", 500, "This is ""quoted""", "", "That was an empty string"';
  Memo1.Lines.Add(GetTokenStr(s, CS_CSV, DoubleQuote));
  Memo1.Lines.Add(GetToken(s, CS_CSV));
  Memo1.Lines.Add(GetTokenStr(s, CS_CSV, DoubleQuote));
  Memo1.Lines.Add(GetTokenStr(s, CS_CSV, DoubleQuote));
  Memo1.Lines.Add(GetTokenStr(s, CS_CSV, DoubleQuote));
end;

PostMessage to post a string instead of an integer

Problem/Question/Abstract:

How to use PostMessage to post a string instead of an integer

Answer:

unit Unit1;

interface

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

type
  TForm1 = class(TForm)
    Button1: TButton;
    procedure Button1Click(Sender: TObject);
  private
    procedure wmUser(var Msg: TMessage); message WM_USER;
  public
  end;

var
  Form1: TForm1;

implementation

{$R *.dfm}

procedure TForm1.Button1Click(Sender: TObject);
var
  lP: LPARAM;
begin
  lP := 0; {VERY important}
  string(lP) := Caption + ' Whatever';
  PostMessage(Handle, WM_USER, 0, lP);
end;

procedure TForm1.wmUser(var Msg: TMessage);
begin
  Caption := string(Msg.LParam);
  string(Msg.LParam) := ''; {VERY important}
end;

end.

Make shortcuts on a secondary TFrame work

Problem/Question/Abstract:

I am using multiple instances of a frame in my application. On the frame there are a couple of TActions that have shortcuts. If I have only one frame on the form, everything works fine and the shortcuts work. But if I am adding a secondary frame, it is always only one of the two frames that executes the TAction (eg. one of them will never have their TAction executed). The function I would like to see is, that when pressing the shortcut, the frame with the active component should execute its corresponding TActions. Is this possible with TFrames?

Answer:

With a bit of work. Override the host form's IsShortcut function. Pass the trapped message to the active frame's Actionlist.IsShortcut method first, if it returns true return True as result as well, otherwise return the result of the inherited IsShortcut function. This can be made fairly generic:

function TMyform.IsShortcut(var Message: TWMKey): Boolean; {override}
var
  ctrl: TWinControl;
  comp: TComponent;
  i: Integer;
begin
  ctrl := ActiveControl;
  if ctrl <> nil then
  begin
    repeat
      ctrl := ctrl.Parent
    until
      (ctrl = nil) or (ctrl is TCustomFrame);
    if ctrl <> nil then
    begin
      for i := 0 to ctrl.ComponentCount - 1 do
      begin
        comp := ctrl.Components[i];
        if comp is TCustomActionList then
        begin
          result := TCustomActionList(comp).IsShortcut(Message);
          if result then
            Exit;
        end;
      end;
    end;
  end;
  result inherited IsShortcut(Message);
end;

Correct handling of Windows shutdown in complex applications

Problem/Question/Abstract:

In complex applications it is necessary to correctly process all application finalization steps like OnClose and OnDestroy event handlers for all forms and Data Modules. However after the application has responded to WM_ENDSESSION message (and TApplication does this automatically) lots of API functions fail due to system shutwdown. How to ensure, that all OnDestroy handlers will work correctly?

Answer:

First let's take a look at the following code:

project XXX;
{... }
var
  DM: TMyDataModule;

begin
  DM := TMyDataModule.Create;
  {... }
  Application.Run;
  DM.Free;
end;

procedure TMyDataModule.DataModuleDestroy(Sender: TObject);
var
  I: Integer;
  J: integer;
begin
  for i := 0 to 5 do
  begin
    MessageBeep(MB_ICONQUESTION);
    if MessageBox(0, PChar('Datamodule destroying - ' + IntToStr(i)), nil,
      MB_SYSTEMMODAL) = 0 then
    begin
      j := GetLastError;
      MessageBeep(MB_ICONEXCLAMATION);
      MessageBox(0, PChar('MessageBox error - ' + IntToStr(j)), nil, MB_SYSTEMMODAL);
    end;
  end;
  MessageBeep(MB_ICONEXCLAMATION);
  MessageBox(0, 'Datamodule destroyed', nil, MB_SYSTEMMODAL);
end;

Our goal is to get 7 messageboxes.
If you reproduce this code in your application, you will get one message box window, that will immediately disappear. That is not what we want. What should we do?
The solution is to not tell windows that the application can be closed until OnDestroy is executed. But if the message is processed in window message dispatching loop, how can we get out of the loop without returning control to Windows?
Let's take a look at threads. Windows starts to send WM_ENDSESSION after all windows return 1 in responce to WM_QUERYENDSESSION. And the solution is simple: create a window in another thread and let it process WM_QUERYENDSESSION message in the way, that will shutdown our application correctly. The code in brief is:

if Msg.Msg = WM_QUERYENDSESSION then
begin
  Synchronize(CloseApp);
  WaitForSingleObject(StopWatcherEvent, INFINITE);
  ResetEvent(StopWatcherEvent);
  Msg.Result := 1;
end
else
  {  ... }

CloseApp function calls Application.MainForm.Close. The application is closed. StopWatcherEvent is set only in finalization clause, which is executed after all forms and datamodules are destroyed ;).

Here is the complete code of the watcher unit. It has been tested under Windows NT 4.0 SP6.

{====================================================}
{                                                    }
{   EldoS Visual Components                          }
{                                                    }
{   Copyright (c) 1998-2000, EldoS                   }
{                                                    }
{====================================================}

unit ElShutdownWatcher;

interface

implementation

uses
  Forms, Classes, Windows, Messages, SysUtils;

type
  TShutdownThread = class(TThread)
  private
    Wnd: HWND;
    procedure WndProc(var Msg: TMessage);
    procedure CloseApp;
  protected
    procedure Execute; override;
  end;

var
  StopWatcherEvent: THandle;

procedure TShutdownThread.CloseApp;
begin
  if (Application.MainForm <> nil) and (not Application.Terminated) then
    Application.MainForm.Close
  else
    PostMessage(Application.Handle, WM_QUIT, 0, 0);
end;

procedure TShutdownThread.WndProc(var Msg: TMessage);
begin
  if Msg.Msg = WM_QUERYENDSESSION then
  begin
    Synchronize(CloseApp);
    WaitForSingleObject(StopWatcherEvent, INFINITE);
    ResetEvent(StopWatcherEvent);
    Msg.Result := 1;
  end
  else
    DefWindowProc(Wnd, Msg.Msg, Msg.wParam, msg.lParam);
end;

procedure TShutdownThread.Execute;
var
  Msg: TMsg;
  i: LongBool;
begin
  StopWatcherEvent := CreateEvent(nil, true, false, nil);
  Wnd := AllocateHWND(WndProc);
  repeat
    i := GetMessage(Msg, 0, 0, 0);
    if i = TRUE then
    begin
      TranslateMessage(Msg);
      DispatchMessage(Msg);
      if WaitForSingleObject(StopWatcherEvent, 0) = WAIT_OBJECT_0 then
        break;
    end;
  until i <> TRUE;
  DeallocateHWND(Wnd);
  CloseHandle(StopWatcherEvent);
  StopWatcherEvent := 0;
end;

var
  Watcher: TShutdownThread;

initialization

  Watcher := TShutdownThread.Create(true);
  Watcher.FreeOnTerminate := true;
  Watcher.Resume;

finalization
  if StopWatcherEvent <> 0 then
    SetEvent(StopWatcherEvent);

end.

Playing MPEG files in Delphi apps

Problem/Question/Abstract:

How can I play an MPEG file in Delphi apps?

Answer:

Providing the Windows MMSystem layer has a MPEG decoder installed, you can easily use the MultiMedia play a MPEG file by setting the filename to the path of the MPEG file.

Example:

procedure TForm1.Button1Click(Sender: TObject);
begin
  MediaPlayer1.Filename := 'C:\DownLoad\rsgrow.mpg';
  MediaPlayer1.Open;
  MediaPlayer1.Display := Panel1;
  MediaPlayer1.DisplayRect := Panel1.ClientRect;
  MediaPlayer1.Play;
end;

Windows Messages? Who,what?!

Problem/Question/Abstract:

How can I use Windows Message and what are they?

Answer:

Hey there manny people are asking what are Windows Messages let's say the Windows Messages are the heart of every Windows.Your application interactionates with other Windows using messages.

You can send or recive messages from the Windows operating systems.

Here is how to send

var
  yopos: Hwnd;
{...}
yopos := FindWindow(nil, 'program Manager');
ShowWindow(yopos, SW_HIDE);
{...}

you can use instead SW_SHOW,SW_MINIMIZE,SW_RESTORE etc;

here is how to close a window

SendMessage(Application.Handle, WM_CLOSE, 0, 0);

There are many examples to give but...

The most popular Windows Messages are:

WM_ACTIVATE: result := 'WM_ACTIVATE             ';
WM_ACTIVATEAPP: result := 'WM_ACTIVATEAPP          ';
WM_ASKCBFORMATNAME: result := 'WM_ASKCBFORMATNAME      ';
WM_CANCELMODE: result := 'WM_CANCELMODE           ';
WM_CHANGECBCHAIN: result := 'WM_CHANGECBCHAIN        ';
WM_CHAR: result := 'WM_CHAR                 ';
WM_CHARTOITEM: result := 'WM_CHARTOITEM           ';
WM_CHILDACTIVATE: result := 'WM_CHILDACTIVATE        ';
WM_CLEAR: result := 'WM_CLEAR                ';
WM_CLOSE: result := 'WM_CLOSE                ';
WM_COMMAND: result := 'WM_COMMAND              ';
WM_COMMNOTIFY: result := 'WM_COMMNOTIFY           ';
WM_COMPACTING: result := 'WM_COMPACTING           ';
WM_COMPAREITEM: result := 'WM_COMPAREITEM          ';
WM_COPY: result := 'WM_COPY                 ';
WM_CREATE: result := 'WM_CREATE               ';
WM_CTLCOLOR: result := 'WM_CTLCOLOR             ';
WM_CUT: result := 'WM_CUT                  ';
WM_DDE_ACK: result := 'WM_DDE_ACK              ';
WM_DDE_ADVISE: result := 'WM_DDE_ADVISE           ';
WM_DDE_DATA: result := 'WM_DDE_DATA             ';
WM_DDE_EXECUTE: result := 'WM_DDE_EXECUTE          ';
WM_DDE_INITIATE: result := 'WM_DDE_INITIATE         ';
WM_DDE_POKE: result := 'WM_DDE_POKE             ';
WM_DDE_REQUEST: result := 'WM_DDE_REQUEST          ';
WM_DDE_TERMINATE: result := 'WM_DDE_TERMINATE        ';
WM_DDE_UNADVISE: result := 'WM_DDE_UNADVISE         ';
WM_DEADCHAR: result := 'WM_DEADCHAR             ';
WM_DELETEITEM: result := 'WM_DELETEITEM           ';
WM_DESTROY: result := 'WM_DESTROY              ';
WM_DESTROYCLIPBOARD: result := 'WM_DESTROYCLIPBOARD     ';
WM_DEVMODECHANGE: result := 'WM_DEVMODECHANGE        ';
WM_DRAWCLIPBOARD: result := 'WM_DRAWCLIPBOARD        ';
WM_DRAWITEM: result := 'WM_DRAWITEM             ';
WM_DROPFILES: result := 'WM_DROPFILES            ';
WM_ENABLE: result := 'WM_ENABLE               ';
WM_ENDSESSION: result := 'WM_ENDSESSION           ';
WM_ENTERIDLE: result := 'WM_ENTERIDLE            ';
WM_ERASEBKGND: result := 'WM_ERASEBKGND           ';
WM_FONTCHANGE: result := 'WM_FONTCHANGE           ';
WM_GETDLGCODE: result := 'WM_GETDLGCODE           ';
WM_GETFONT: result := 'WM_GETFONT              ';
WM_GETMINMAXINFO: result := 'WM_GETMINMAXINFO        ';
WM_GETTEXT: result := 'WM_GETTEXT              ';
WM_GETTEXTLENGTH: result := 'WM_GETTEXTLENGTH        ';
WM_HSCROLL: result := 'WM_HSCROLL              ';
WM_HSCROLLCLIPBOARD: result := 'WM_HSCROLLCLIPBOARD     ';
WM_ICONERASEBKGND: result := 'WM_ICONERASEBKGND       ';
WM_INITDIALOG: result := 'WM_INITDIALOG           ';
WM_INITMENU: result := 'WM_INITMENU             ';
WM_INITMENUPOPUP: result := 'WM_INITMENUPOPUP        ';
WM_KEYDOWN: result := 'WM_KEYDOWN              ';
WM_KEYUP: result := 'WM_KEYUP                ';
WM_KILLFOCUS: result := 'WM_KILLFOCUS            ';
WM_LBUTTONDBLCLK: result := 'WM_LBUTTONDBLCLK        ';
WM_LBUTTONDOWN: result := 'WM_LBUTTONDOWN          ';
WM_LBUTTONUP: result := 'WM_LBUTTONUP            ';
WM_MBUTTONDBLCLK: result := 'WM_MBUTTONDBLCLK        ';
WM_MBUTTONDOWN: result := 'WM_MBUTTONDOWN          ';
WM_MBUTTONUP: result := 'WM_MBUTTONUP            ';
WM_MDIACTIVATE: result := 'WM_MDIACTIVATE          ';
WM_MDICASCADE: result := 'WM_MDICASCADE           ';
WM_MDICREATE: result := 'WM_MDICREATE            ';
WM_MDIDESTROY: result := 'WM_MDIDESTROY           ';
WM_MDIGETACTIVE: result := 'WM_MDIGETACTIVE         ';
WM_MDIICONARRANGE: result := 'WM_MDIICONARRANGE       ';
WM_MDIMAXIMIZE: result := 'WM_MDIMAXIMIZE          ';
WM_MDINEXT: result := 'WM_MDINEXT              ';
WM_MDIRESTORE: result := 'WM_MDIRESTORE           ';
WM_MDISETMENU: result := 'WM_MDISETMENU           ';
WM_MDITILE: result := 'WM_MDITILE              ';
WM_MEASUREITEM: result := 'WM_MEASUREITEM          ';
WM_MENUCHAR: result := 'WM_MENUCHAR             ';
WM_MENUSELECT: result := 'WM_MENUSELECT           ';
WM_MOUSEACTIVATE: result := 'WM_MOUSEACTIVATE        ';
WM_MOUSEMOVE: result := 'WM_MOUSEMOVE            ';
WM_MOVE: result := 'WM_MOVE                 ';
WM_NCACTIVATE: result := 'WM_NCACTIVATE           ';
WM_NCCALCSIZE: result := 'WM_NCCALCSIZE           ';
WM_NCCREATE: result := 'WM_NCCREATE             ';
WM_NCDESTROY: result := 'WM_NCDESTROY            ';
WM_NCHITTEST: result := 'WM_NCHITTEST            ';
WM_NCLBUTTONDBLCLK: result := 'WM_NCLBUTTONDBLCLK      ';
WM_NCLBUTTONDOWN: result := 'WM_NCLBUTTONDOWN        ';
WM_NCLBUTTONUP: result := 'WM_NCLBUTTONUP          ';
WM_NCMBUTTONDBLCLK: result := 'WM_NCMBUTTONDBLCLK      ';
WM_NCMBUTTONDOWN: result := 'WM_NCMBUTTONDOWN        ';
WM_NCMBUTTONUP: result := 'WM_NCMBUTTONUP          ';
WM_NCMOUSEMOVE: result := 'WM_NCMOUSEMOVE          ';
WM_NCPAINT: result := 'WM_NCPAINT              ';
WM_NCRBUTTONDBLCLK: result := 'WM_NCRBUTTONDBLCLK      ';
WM_NCRBUTTONDOWN: result := 'WM_NCRBUTTONDOWN        ';
WM_NCRBUTTONUP: result := 'WM_NCRBUTTONUP          ';
WM_NEXTDLGCTL: result := 'WM_NEXTDLGCTL           ';
WM_PAINT: result := 'WM_PAINT                ';
WM_PAINTCLIPBOARD: result := 'WM_PAINTCLIPBOARD       ';
WM_PALETTECHANGED: result := 'WM_PALETTECHANGED       ';
WM_PALETTEISCHANGING: result := 'WM_PALETTEISCHANGING    ';
WM_PARENTNOTIFY: result := 'WM_PARENTNOTIFY         ';
WM_PASTE: result := 'WM_PASTE                ';
WM_POWER: result := 'WM_POWER                ';
WM_QUERYDRAGICON: result := 'WM_QUERYDRAGICON        ';
WM_QUERYENDSESSION: result := 'WM_QUERYENDSESSION      ';
WM_QUERYNEWPALETTE: result := 'WM_QUERYNEWPALETTE      ';
WM_QUERYOPEN: result := 'WM_QUERYOPEN            ';
WM_QUEUESYNC: result := 'WM_QUEUESYNC            ';
WM_QUIT: result := 'WM_QUIT                 ';
WM_RBUTTONDBLCLK: result := 'WM_RBUTTONDBLCLK        ';
WM_RBUTTONDOWN: result := 'WM_RBUTTONDOWN          ';
WM_RBUTTONUP: result := 'WM_RBUTTONUP            ';
WM_RENDERALLFORMATS: result := 'WM_RENDERALLFORMATS     ';
WM_RENDERFORMAT: result := 'WM_RENDERFORMAT         ';
WM_SETCURSOR: result := 'WM_SETCURSOR            ';
WM_SETFOCUS: result := 'WM_SETFOCUS             ';
WM_SETFONT: result := 'WM_SETFONT              ';
WM_SETREDRAW: result := 'WM_SETREDRAW            ';
WM_SETTEXT: result := 'WM_SETTEXT              ';
WM_SHOWWINDOW: result := 'WM_SHOWWINDOW           ';
WM_SIZE: result := 'WM_SIZE                 ';
WM_SIZECLIPBOARD: result := 'WM_SIZECLIPBOARD        ';
WM_SPOOLERSTATUS: result := 'WM_SPOOLERSTATUS        ';
WM_SYSCHAR: result := 'WM_SYSCHAR              ';
WM_SYSCOLORCHANGE: result := 'WM_SYSCOLORCHANGE       ';
WM_SYSCOMMAND: result := 'WM_SYSCOMMAND           ';
WM_SYSDEADCHAR: result := 'WM_SYSDEADCHAR          ';
WM_SYSKEYDOWN: result := 'WM_SYSKEYDOWN           ';
WM_SYSKEYUP: result := 'WM_SYSKEYUP             ';
WM_SYSTEMERROR: result := 'WM_SYSTEMERROR          ';
WM_TIMECHANGE: result := 'WM_TIMECHANGE           ';
WM_TIMER: result := 'WM_TIMER                ';
WM_UNDO: result := 'WM_UNDO                 ';
WM_USER: result := 'WM_USER                 ';
WM_VKEYTOITEM: result := 'WM_VKEYTOITEM           ';
WM_VSCROLL: result := 'WM_VSCROLL              ';
WM_VSCROLLCLIPBOARD: result := 'WM_VSCROLLCLIPBOARD     ';
WM_WINDOWPOSCHANGED: result := 'WM_WINDOWPOSCHANGED     ';
WM_WINDOWPOSCHANGING: result := 'WM_WINDOWPOSCHANGING    ';
WM_WININICHANGE: result := 'WM_WININICHANGE         ';

You can use these messages using this example:

private

procedure lik(var Msg: TWMNCHITTEST); message WM_NCHITTEST;
public

procedure TForm1.lik(var Msg: TWMNCHITTEST);
begin
  inherited;
  if tx = true then
  begin
    if Msg.Result = Windows.HTMINBUTTON then
      Application.Minimize
    else if Msg.Result = Windows.HTCLOSE then
      Close;
  end;
end;

TParser, an undocumented Delphi class

Problem/Question/Abstract:

TParser is an undocumented Delphi class. It is used by Delphi to read a stream and break it into tokens. Its primary use is to convert a text file to a binary form file (.dfm file).

Answer:

Description

TParser is an undocumented Delphi class. It is used by Delphi to read a stream and break it into tokens. Its primary use is to convert a text file to a binary form file (.dfm file).

TParser performs a lexical analysis of the input stream. It breaks the stream up into floating point numbers, strings, Pascal identifiers or punctuation. Any other non-space characters are considered to be punctuation. Binary data, appearing as hexadecimal digits, is also handled by TParser. Binary data is enclosed in curly braces, and is handled specially by TParser.

TParser cannot handle Pascal comments, so it cannot be considered a general purpose parsing class. It is intended to parse a correctly formatted textual form description.

TParser raises an exception when it encounters an error, but there is no error recovery.

To use the TParser class, instantiate it using the Create method, supplying the input stream you want parsed to that method. Then repeatedly call NextToken and evaluate the token returned until the token is toEOF. Finally, destroy the instance using the Free method.

Properties

property FloatType: Char read FFloatType;

Read-only property that indicates the type of floating point number. Can be 'C', 'D' or 'S'.

property SourceLine: Integer read FSourceLine;

Read-only property that indicates the current input line number. This number is included in all error messages resulting from problems with TParser conversion.

property Token: Char read FToken;

Read-only property that indicates the type of token to be read next. Tokens are either a punctuation mark or they are of type toEOF, toSymbol, toString, toInteger, toFloat or toWString.

Methods

Create

constructor Create(Stream: TStream);

Set up the stream, initialize pointers and allocate a buffer to receive characters from the stream. Then call NextToken to get a token from the stream.

Destroy

destructor Destroy;

Free the memory allocated for use with TParser.

CheckTokenSymbol

procedure CheckTokenSymbol(const S: string);

Check an identifier token for a specific string (S). If the identifier is not the same as the string, CheckTokenSymbol will raise an EParserError exception.

Error

procedure Error(const Ident: string);

Take a string resource identifier (Ident) and pass it to the ErrorStr procedure so that an exception may be raised.

ErrorFmt

procedure ErrorFmt(const Ident: string; const Args: array of const);

Format the string resource identifier and arguments, then pass the result to ErrorStr so that an exception may be raised.

ErrorStr

procedure ErrorStr(const Message: string);

Raise an EParserError exception, displaying the Message. All error handling in TParser ends up calling ErrorStr.

HexToBinary

procedure HexToBinary(Stream: TStream);

Read hexadecimal data from the input stream, convert it to binary and write the binary out to the Stream output stream. Hexadecimal data in the input stream is enclosed in curly braces.

NextToken

function NextToken: Char;

Advance the input stream to the next token and return that token. The returned token is either a single character (punctuation) or a special token character. Based on the token type, you can obtain the value of the actual token by calling one of the token functions, as shown below:

Token Name Value Function Description
toEOF   End of input stream
toFloat TokenFloat Floating point number
toInteger TokenInt Integer
toString TokenString String
toWString TokenWideString Wide string
toSymbol TokenString Identifier

SourcePos

function SourcePos: Longint;

Returns the position of the current token in the input stream. If an error occurs, SourcePos can be used to display the position in the input stream where the error occurred.

TokenComponentIdent

function TokenComponentIdent: string;

Returns an identifier path string, which is a series of identifiers separated by periods. For this function to work, the current token must be a toSymbol token. The function then reads and builds the identifier path (for example, Font.Name).

TokenFloat

function TokenFloat: Extended;

Converts the current toFloat token to a floating point number by calling the StrToFloat function. If the number is not correctly formatted, an EConvertError exception will be raised. For this function to work, the current token must be toFloat.

TokenInt

function TokenInt: Int64;

Converts the current toInteger token to an integer number by calling the StrToInt64 function. For this function to work, the current token must be toInteger.

TokenString

function TokenString: string;

Returns the current token as a string of 255 characters or less. If the token type is toString, then the returned string is the actual string, after converting non-printing characters and embedded quotes. If the token is toSymbol, the actual string is returned without any conversions.

TokenWideString

function TokenWideString: WideString;

Returns the current token as a string more than 255 characters. For this function to work, the token type must be toWString.

TokenSymbolIs

function TokenSymbolIs(const S: string): Boolean;

Returns True if the current token type is toSymbol and the token is equal to the string S (disregarding case). Otherwise, it returns False. This is handy to test for specific symbols, such as object or end.

Extracting data from a program's resources

Problem/Question/Abstract:

Sometimes it's useful to embed some data (or a file) inside our program's resources. This article deals with how to get the data out again

Answer:

This article assumes that the data you embedded was in the RCDATA format. This is a user-defined data format so we also assume that you know how to decode the format.

Reading it back from the resource is very simple due to the TResourceStream class that ships with Delphi. You create a TResourceStream in one of two ways

var
  RS: TResourceStream;
begin
  // ...

  // 1: Do this if the resource is named
  RS := TResourceStream.Create(
    HInstance, // your app or DLL instance handle
    ResourceName, // string containing resource name
    RT_RCDATA); // identifies RCDATA resource type

  // 2: Do this if it is identified by an ordinal
  //     value (per my article on writing the data)
  RS := TResourceStream.CreateFromID(
    HInstance, // as above
    ResourceID, // Word identifier
    RT_RCDATA); // as above
  // ...
end;

You now just use the stream to read the data as if it was coming from a file. You can't write to a TResourceStream as data embedded in a executable file is read only.

To copy your embedded file into another stream (say AS of type TStream) you can use this code:

AS.CopyFrom(RS, RS.Size);

As an example, say we have a program that includes an resource file that contains an RCDATA resource which has a copy of a rich text file inside it. The program displays the embedded rich text in a rich edit component. This is the code we need:

var
  RS: TResourceStream;
begin
  // Create resource stream (resource id is 100)
  RS := TResourceStream.CreateFromID(HInstance,
    100, RT_RCDATA);
  try
    // Load the rich edit component
    RichEdit1.Lines.LoadFromStream(RS);
  finally
    // Free the stream
    RS.Free;
  end;
end;

You can download a worked example that demonstrates what has been described here -- it uses the above code. The .zip file contains a pair of projects. The first a program that embeds a supplied rich text file in a resource file. The second program includes the resource file and displays the rich text in a rich edit component.

Printing to a specific bin

Problem/Question/Abstract:

Needed routine to print output to a specific bin on a laser printer. The key to this routine is the DevMode structure, there are several other routines that could be written using this structure.

Answer:

procedure BinToPrintTo(BinNo: Integer);
var
  ADevice, ADriver, APort: string;
  ADeviceMode: THandle;
  DevMode: PDeviceMode;
begin
  SetLength(ADevice, 255);
  SetLength(ADriver, 255);
  SetLength(APort, 255);
  if ADeviceMode = 0 then
  begin
    Printer.PrinterIndex := Printer.PrinterIndex;
    Printer.GetPrinter(PChar(ADevice), PChar(ADriver),
      PChar(APort), ADeviceMode);
  end;
  if ADeviceMode <> 0 then
  begin
    DevMode := GlobalLock(ADeviceMode);
    try
      DevMode^.dmDefaultSource := BinNo;
    finally
      GlobalUnlock(ADeviceMode);
    end;
  end
  else
    raise Exception.Create('Could not set printer copies');
end;

The functionality to Query the bin numbers. Setting the bin number must follow the query of binnames and the assosiated number the following code  is a brief sample how it could be done.

var
  iPaperTrayCount: Integer;
  sBinNames: array of array[0..23] of Char;
  iBinValues: array of Smallint;
  iNumBins: Integer;
  sPrinterDev: string;

begin
  //  Get the device name
  sPrinterDev := TPrinterDevice(Printer.Printers.Objects[PrinterIndex]).Device;
  // Query the number of Papaerbins
  iNumBins := DeviceCapabilities(PChar sPrinterDev), '', DC_BINNAMES, nil, nil);

if iNumBins >= 0 then
begin
  // Create an array that holds the name of the paper bin
  // and a second to hold the needed Binnumbers

  SetLength(sBinNames, iNumBins);
  SetLength(iBinValues, iNumBins);

  // get the names
  DeviceCapabilities(PChar(sPrinterDev), nil, DC_BINNAMES, @sBinNames[0], nil);
  // get the numbers
  DeviceCapabilities(PChar(sPrinterDev), nil, DC_BINS, @iBinValues[0], nil);
end;
end;

Get the keyboard input language

Problem/Question/Abstract:

When my application starts, I need to switch the keyboard language to Greek. Currently I use the statement ActivateKeyboardlayout(0, 0). When I need to switch to English (when the application terminates) I execute the same statement one more time. This works fine, but only if the language before the application's execution is English. So, before the call of the statement, I need to know if the language is Greek or English. How can do this?

Answer:

I usually use the following cycle:

{ ... }
GetKeyboardLayoutName(@t);
y := string(t);
repeat
ActivateKeyboardLayout(HKL_NEXT, 0);
GetKeyboardLayoutName(@t);
x := string(t);
until
((x = y) or (x = '00000405'));
{ ... }

Using this, the English keyboard will give the KeyboardLayoutName '00000409' and the Greek one the '000000408'. These are standard language identifiers. They're the same on any Windows machine.

To display the information, you could use this little trick:

{ ... }
var
kbd: array[0..2] of Char;
begin
GetLocaleInfo(loWord(GetKeyboardLayout(0)), LOCALE_SENGLANGUAGE, kbd, 2);
Form1.Caption := kbd;
{ ... }

Loop through frames of a TWebBrowser

Problem/Question/Abstract:

Loop through frames of a TWebBrowser

Answer:

Here is the DFM:

object Form1: TForm1
Left = 278
Top = 161
Width = 512
Height = 478
Caption = 'Form1'
Color = clBtnFace
Font.Charset = DEFAULT_CHARSET
Font.Color = clWindowText
Font.Height = -11
Font.Name = 'MS Sans Serif'
Font.Style = []
OldCreateOrder = False
WindowState = wsMaximized
PixelsPerInch = 96
TextHeight = 13
object Panel1: TPanel
Left = 0
Top = 0
Width = 504
Height = 41
Align = alTop
TabOrder = 0
object Button1: TButton
Left = 8
Top = 8
Width = 75
Height = 25
Caption = 'Close'
TabOrder = 0
OnClick = Button1Click
end
object Button2: TButton
Left = 388
Top = 7
Width = 75
Height = 25
Caption = 'LoadURL'
TabOrder = 1
OnClick = Button2Click
end
object edt_url: TEdit
Left = 104
Top = 9
Width = 281
Height = 21
TabOrder = 2
end
end
object Memo: TMemo
Left = 0
Top = 41
Width = 504
Height = 176
Align = alTop
ScrollBars = ssVertical
TabOrder = 1
end
object Browser: TWebBrowser_V1
Left = 0
Top = 217
Width = 504
Height = 215
Align = alClient
TabOrder = 2
OnFrameNavigateComplete = BrowserFrameNavigateComplete
ControlData = {
4C00000017340000391600000000000000000000000000000000000000000000
000000004C000000000000000000000001000000E0D057007335CF11AE690800
2B2E12620C000000000000004C0000000114020000000000C000000000000046
0000000000000000000000000000000000000000000000000000000000000000
00000000000000000100000000000000000000000000000000000000}
end
object StatusBar1: TStatusBar
Left = 0
Top = 432
Width = 504
Height = 19
Panels = <
item
Width = 200
end >
SimplePanel = False
end
end

Here is the source:

unit frmForm1;

interface

uses
Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
StdCtrls, ExtCtrls, SHDocVw_TLB, IEParser, mshtml_tlb, ActiveX, OleCtrls,
ComCtrls;

type
TForm1 = class(TForm)
Panel1: TPanel;
Button1: TButton;
Button2: TButton;
Memo: TMemo;
Browser: TWebBrowser_V1;
edt_url: TEdit;
StatusBar1: TStatusBar;
procedure Button1Click(Sender: TObject);
procedure Button2Click(Sender: TObject);
procedure BrowserFrameNavigateComplete(Sender: TObject;
const URL: WideString);
private
{ Private-Deklarationen }
public
{ Public-Deklarationen }
end;

var
Form1: TForm1;

implementation

{$R *.DFM}

procedure TForm1.Button1Click(Sender: TObject);
begin
close;
end;

procedure TForm1.Button2Click(Sender: TObject);
begin
if edt_url.text = '' then
exit;
Browser.navigate(edt_url.text);
end;

procedure TForm1.BrowserFrameNavigateComplete(Sender: TObject;
const URL: WideString);
var
Document: IHTMLDocument2;
FrameDoc: IHTMLDocument2;
Frames: IHTMLFramesCollection2;
All: IHtmlElementCollection;
HtmlElement: IHtmlElement;
idisp: IDispatch;
i, j: Integer;
v: OleVariant;
win2: IHTMLWindow2;
str_ready: string;
begin
Memo.Lines.Clear;
Browser.Document.QueryInterface(iHTMLDocument2, Document);
Frames := Document.get_frames;
All := Document.All;
for i := 0 to All.length - 1 do
begin
HTMLElement := All.Item(i, 0) as IHTMLElement;
if (Assigned(HTMLElement)) then
begin
if (HTMLElement.TagName = 'FRAME') then
begin
v := HTMLElement.getAttribute('Name', 0);
Memo.lines.add('============================ FRAME FOUND ==');
Memo.lines.add(' ==>FRAME NAME: ' + v);
idisp := Frames.item(v);
// now we get the window-object
idisp.QueryInterface(IHTMLWindow2, win2);
if (Assigned(win2)) then
begin
// here it comes, the IHTMLDocument2
FrameDoc := win2.document;
if (Assigned(FrameDoc)) then
begin
// we have to wait for the document until it is loaded ...
repeat
application.processmessages;
str_ready := FrameDoc.readyState;
StatusBar1.Panels[0].Text := str_ready;
until (str_ready = 'complete') or (str_ready = 'interactive');
// ...now it is safe to go on with work...
for j := 0 to FrameDoc.all.length - 1 do
begin
// showing the doc.elements for demo purposes
HTMLElement := FrameDoc.All.Item(j, 0) as IHTMLElement;
Memo.lines.add('Element : [' + HTMLElement.TagName + ']');
end;
end;
end;
end;
end;
end;
end;

end.

Create database on local MS SQL Server 2000

Problem/Question/Abstract:

How to Create database on local MS SQL Server 2000?

Answer:

// Torry's Delphi Tips - Database
// Author Adnan Hebibovic
// Listed 21.12.2003

procedure CreateDatabase(WindowsSecurity: Boolean; Username, Password: string);
var
ConnectionString: string;
CommandText: string;
begin
if WindowsSecurity then
ConnectionString := 'Provider=SQLOLEDB.1;' +
'Integrated Security=SSPI;' +
'Persist Security Info=False;' +
'Initial Catalog=master'
else
ConnectionString := 'Provider=SQLOLEDB.1;' +
'Password=' + Password + ';' +
'Persist Security Info=True;' +
'User ID=' + Username + ';' +
'Initial Catalog=master';

try

try
ADOConnection.ConnectionString := ConnectionString;
ADOConnection.LoginPrompt := False;
ADOConnection.Connected := True;

CommandText := 'CREATE DATABASE test ON ' +
'( NAME = test_dat,    ' +
'FILENAME = ''c:\program files\microsoft sql server\mssql\data\test.mdf'', ' +
'SIZE = 4, ' +
'MAXSIZE = 10, ' +
'FILEGROWTH = 1 )';

ADOCommand.CommandText := CommandText;
ADOCommand.Connection := ADOConnection;
ADOCommand.Execute;
MessageDlg('Database succesfully created.', mtInformation, [mbOK], 0);

except
on E: Exception do
MessageDlg(E.Message, mtWarning, [mbOK], 0);
end;

finally
ADOConnection.Connected := False;
ADOCommand.Connection := nil;
end;

end;

Duplicate the string sorting of the Windows XP Explorer

Problem/Question/Abstract:

I've noticed a change in Explorer's sorting algorithm. Under Windows 2000, one would see files sorted by name this way: A100, A20, A3, B100, B20, B3. Under Windows XP, one would see the same files sorted by name this way: A3, A20, A100, B3, B20, B100. Does anyone know of a string sort-compare function that uses this new sorting algorithm? I would prefer to not rely on an API call that doesn't exist in prior versions of Windows.

Answer:

unit Unit1;

interface

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

type
TForm1 = class(TForm)
Button1: TButton;
ListBox1: TListBox;
Edit1: TEdit;
Label1: TLabel;
procedure Button1Click(Sender: TObject);
procedure FormCreate(Sender: TObject);
private
{ Private declarations }
public
{ Public declarations }
end;

type
TFolderContent = (
fcFiles, {Include all Files}
fcFolders, {Include all Folders}
fcHidden {Include all hidden objects}
);
TFolderContents = set of TFolderContent;
TFileResult = (
FileName, {Return a list of filenames}
Path {Return a list of complete file paths}
);

const
AllFolderContent = [fcFiles, fcFolders, fcHidden];

var
Form1: TForm1;

implementation

uses
ShellAPI, ShlObj, ActiveX;

{$R *.dfm}

var
SortFolder: IShellFolder;
SortColumn: Integer;

function ShellCompare(Item1, Item2: Pointer): Integer;
begin
Result := 0;
if Assigned(SortFolder) then
Result := ShortInt(SortFolder.CompareIDs(SortColumn, Item1, Item2));
end;

function PathToPIDL(APath: WideString): PItemIDList;
{Takes the passed Path and attempts to convert it to the equavalent PIDL}
var
Desktop: IShellFolder;
pchEaten, dwAttributes: ULONG;
begin
Result := nil;
SHGetDesktopFolder(Desktop);
dwAttributes := 0;
if Assigned(Desktop) then
Desktop.ParseDisplayName(0, nil, PWideChar(APath), pchEaten, Result,
dwAttributes);
end;

function StrRetToStr(StrRet: TStrRet; APIDL: PItemIDList; const Malloc: IMalloc):
WideString;
{Extracts the string from the StrRet structure}
var
P: PChar;
{S: string;}
begin
case StrRet.uType of
STRRET_CSTR:
begin
SetString(Result, StrRet.cStr, lStrLen(StrRet.cStr));
{Result := S}
end;
STRRET_OFFSET:
begin
if Assigned(APIDL) then
begin
{$R-}
P := PChar(@(APIDL).mkid.abID[StrRet.uOffset - SizeOf(APIDL.mkid.cb)]);
{$R+}
SetString(Result, P, StrLen(P));
{Result := S;}
end
else
Result := '';
end;
STRRET_WSTR:
begin
Result := StrRet.pOleStr;
if Assigned(StrRet.pOleStr) then
Malloc.Free(StrRet.pOLEStr);
end;
end;
end;

function GetDirectoryFolder(Directory: WideString): IShellFolder;
var
Desktop: IShellFolder;
pchEaten, dwAttributes: ULONG;
PIDL: PItemIDList;
begin
SHGetDesktopFolder(Desktop);
if Assigned(Desktop) then
begin
PIDL := nil;
Desktop.ParseDisplayName(0, nil, PWideChar(Directory), pchEaten, PIDL,
dwAttributes);
if Assigned(PIDL) then
begin
Desktop.BindToObject(PIDL, nil, IShellFolder, Result);
CoTaskMemFree(PIDL);
end;
end;
end;

procedure EnumFolder(Folder: IShellFolder; Contents: TFolderContents; PIDLList:
TList);
var
Flags: Longword;
EnumList: IEnumIDList;
Fetched: ULONG;
PIDL: PItemIDList;
begin
Flags := 0;
if fcFiles in Contents then
Flags := Flags or SHCONTF_NONFOLDERS;
if fcFolders in Contents then
Flags := Flags or SHCONTF_FOLDERS;
if fcHidden in Contents then
Flags := Flags or SHCONTF_INCLUDEHIDDEN;
Folder.EnumObjects(0, Flags, EnumList);
if Assigned(EnumList) then
begin
while EnumList.Next(1, PIDL, Fetched) <> S_FALSE do
PIDLList.Add(PIDL);
end;
end;

procedure GetDirectoryContents(Directory: WideString; Contents: TFolderContents;
FileResult: TFileResult; SortOnColumn: Integer; FileList: TStringList);
{Parameters:
Directory: Path of the directory to get the contents of
Contents:  What type of objects on the folder to include
FileResult: Return only the file names or the complete path for each file
SortOnColumn: What column (in Explorer report view) to sort the item on, 0 is the name
FileList:  The resulting file list user allocated}
var
Folder: IShellFolder;
PIDLList: TList;
i: Integer;
Malloc: IMalloc;
Flags: Longword;
StrRet: TStrRet;
begin
Assert(Assigned(FileList),
'User must allocate the FileString List in GetDirectoryContents');
Folder := GetDirectoryFolder(Directory);
if Assigned(Folder) then
begin
SHGetMalloc(Malloc);
PIDLList := TList.Create;
try
EnumFolder(Folder, Contents, PIDLList);
SortFolder := Folder;
SortColumn := SortOnColumn;
PIDLList.Sort(ShellCompare);
{Release the count on the interface}
SortFolder := nil;
FileList.Capacity := PIDLList.Count;
if FileResult = FileName then
Flags := SHGDN_NORMAL
else
Flags := SHGDN_FORPARSING;
for i := 0 to PIDLList.Count - 1 do
begin
FillChar(StrRet, SizeOf(StrRet), #0);
if Folder.GetDisplayNameOf(PIDLList[i], Flags, StrRet) = NOERROR then
FileList.Add(StrRetToStr(StrRet, PIDLList[i], Malloc));
end;
finally
for i := 0 to PIDLList.Count - 1 do
Malloc.Free(PIDLList[i]);
PIDLList.Free;
end;
end;
end;

procedure TForm1.Button1Click(Sender: TObject);
var
Files: TStringList;
begin
Files := TStringList.Create;
GetDirectoryContents(Edit1.Text, AllFolderContent, Path, 0, Files);
ListBox1.Items.Assign(Files);
Files.Free;
end;

procedure TForm1.FormCreate(Sender: TObject);
begin
Label1.Caption := 'Enter a Directory';
Edit1.Text := 'c:\';
end;

end.

Download a file from the web to a local drive

Problem/Question/Abstract:

I want to write an application that can download upgraded versions of itself.

Answer:

Solve 1:

If you are just going to download there is no need to use ActiveX controls. Windows has the function you need already declared in the UrlMon.dll. To download a file to a local disk just use this code. Note: This function is not described in Delphi Help nor in the Win32 Programmer's Reference.

uses
URLMon;

{ ... }
if URLDownloadToFile(nil, 'http://go.to/masdp', 'c:\index.html', 0, nil) <> 0 then
MessageBox(Handle, 'An error ocurred while downloading the file.', PChar(Application.Title), MB_ICONERROR or MB_OK);
{ ... }


Solve 2:

Downloading a file is not very difficult, something like:

uses
Wininet;

var
InternetBrowserUserAgent: string;
{Set it as you like. Win98/IE uses 'Mozilla/4.0 (compatible; MSIE 5.5; Windows 98)' }

{ ... }

function GetInternetStream(URL: string; Stream: TStream): LongInt;
type
TNetBuffer = array[0..1023] of Byte;
PNetBuffer = ^TNetBuffer;
var
ihConnect, iDocument: HINTERNET;
NetBuffer: PNetBuffer;
BufferSize: Integer;
I: integer;
begin
Result := -1;
ihConnect := InternetOpen(PChar(InternetBrowserUserAgent), LOCAL_INTERNET_ACCESS, '', '', 0);
try
if ihConnect <> nil then
begin
iDocument := InternetOpenURL(ihConnect, PChar(URL), nil, Cardinal(-1),
INTERNET_FLAG_RELOAD or INTERNET_FLAG_DONT_CACHE or
INTERNET_FLAG_RAW_DATA, 0);
try
if iDocument <> nil then
begin
Result := 0;
try
New(NetBuffer);
repeat
InternetReadFile(iDocument, NetBuffer, SizeOf(TNetBuffer), BufferSize);
if BufferSize > 0 then
begin
Result := Result + Stream.Write(NetBuffer^, BufferSize);
end;
until
(BufferSize < SizeOf(TNetBuffer));
finally
Dispose(NetBuffer);
end;
end;
finally
internetCloseHandle(iDocument);
end;
end;
finally
InternetCloseHandle(ihConnect);
end;
end;

If you call this function with a TFileStream, you have the file on your harddisk. If you have a ZIP, you probably want to unzip the file now, use a component that can do this (I think there are some around). The problem is that an application cannot replace itself (because it is write protected while it is running). The solution would be to call another application and terminate the first one. The second one has to update the first one (maybe wait a while until it is really terminated and not write protect any more) and start it again. If you just have to update non-executable files this is much easier. Another solution would be a separate update-application, that the user can call from somewhere (after he has closed the main application).


Solve 3:

I always use this piece of code, works with proxy servers as well:

uses
WinInet;

var
BytesRead: DWord;
sUrl, S: string;
Nethandle, UrlHandle: Pointer;
M: TMemoryStream;
Buffer: array[0..8191] of Char;
begin
sUrl := 'http://.....';
NetHandle := InternetOpen('Mozilla 4.0', INTERNET_OPEN_TYPE_PRECONFIG, nil, nil, 0);
try
if Assigned(NetHandle) then
begin
UrlHandle := InternetOpenUrl(NetHandle, PChar(sUrl), nil, 0,
INTERNET_FLAG_RELOAD, 0);
if Assigned(UrlHandle) then
begin
M := TMemoryStream.Create;
try
repeat
FillChar(Buffer, SizeOf(Buffer), 0);
InternetReadFile(UrlHandle, @Buffer, SizeOf(Buffer), BytesRead);
if BytesRead > 0 then
M.Write(Buffer, BytesRead);
until
BytesRead = 0;
M.Position := 0;
SetLength(S, M.Size);
M.Read(S[1], M.Size);
InternetCloseHandle(UrlHandle);
M.Position := 0;
M.SaveToFile('..\Filename');
finally
M.Free;
end;
end;
end;
finally
InternetCloseHandle(NetHandle);
end;
end;

An Application Loader with a TCPServer

Problem/Question/Abstract:

Loading Delphi apps without a browser and on Win as Linux as well needs a decision once. With a loader on the client side, no further installation is in charge.

Answer:

We had the requirement starting different Delphi apps from a linux or windows server, wherever you are. We call it Delphi Web Start (DWS). The dws-client gets a list and after clicking on it, the app is loading from server to client with just a stream. First we had to choose between a ftp and a tcp solution. The advantage of tcp is the freedom to define a separate port, which was "services, port 9010 - DelphiWebStart".   You will need indy. Because it is simple to use and very fast. The tcp-server comes from indy which has one great advantage:

CommandHandlers is a collection of text commands that will be processed by the server. This property greatly simplify the process of building servers based on text protocols.

First we start with DWS_Server, so we define two command handlers:

CTR_LIST = 'return_list';
CTR_FILE = 'return_file';

By starting the tcp-server it returns with the first command

handler "CTR_LIST" a list of the apps:

procedure TForm1.IdTCPServer1Execute(AThread: TIdPeerThread);
{... }
// comes with writeline from client
if sRequest = CTR_LIST then
begin
for idx := 0 to meData.Lines.Count - 1 do
athread.Connection.WriteLn(ExtractFileName(meData.Lines[idx]));
aThread.Connection.WriteLn('::END::');
aThread.Connection.Disconnect;

One word concerning the thread:
In the internal architecture there are 2 threads categories.

First is a listener thread that "listen" and waits for a connection. So we don't have to worry about threads, the built in
thread will be served by indy though parameter:

IdTCPServer1Execute(AThread: TIdPeerThread)

When our dws-client is connected, this thread transfer all the communication operations to another thread. This technique is very efficient because your client application will be able to connect any time, even if there are many different connections to the server.

The second command "CTR_FILE" transfers the app to the client:

if Pos(CTR_file, sRequest) > 0 then
begin
iPos := Pos(CTR_file, sRequest);
FileName := GetFullPath(FileName);
if FileExists(FileName) then
begin
lbStatus.Items.Insert(0, Format('%-20s %s',
[DateTimeToStr(now), 'Transfer starts ...']));
FileStream := TFileStream.Create(FileName, fmOpenRead +

fmShareDenyNone);
aThread.Connection.OpenWriteBuffer;
aThread.Connection.WriteStream(FileStream);
aThread.Connection.CloseWriteBuffer;
FreeAndNil(FileStream);
aThread.Connection.Disconnect;

Now let's have a look at the client side. The client connects to the server, using the connect method of TIdTcpClient. In this moment, the client sends any command to the server, in our case (you remember DelphiWebStart) he gets the list of available apps:

with IdTCPClient1 do
begin
if Connected then
DisConnect;
showStatus;
Host := edHost.Text;
Port := StrToInt(edPort.Text);
Connect;
WriteLn(CTR_LIST);

After clicking on his choice, the app will be served:

with IdTCPClient1 do
begin
ExtractFileName(lbres.Items[lbres.ItemIndex])]));
WriteLn(CTR_FILE + lbres.Items[lbres.ItemIndex]);
FileName := ExpandFileName(edPath.Text + '/' +
ExtractFileName(lbres.Items[lbres.ItemIndex]));
{... }
FileStream := TFileStream.Create(FileName, fmCreate);
while connected do
begin
ReadStream(FileStream, -1, true);
{   .... }
execv(pchar(filename), nil);

Better with a compiler directive to load delivered files:

{$IFDEF LINUX}
execv(pchar(filename), nil);
//libc.system(pchar(filename));
{$ENDIF}
{$IFDEF MSWINDOWS}
// shellapi.WinExec('c:\testcua.bat', SW_SHOW);
with lbstatus.items do
begin
case shellapi.shellExecute(0, 'open', pchar(filename), '', nil,
SW_SHOWNORMAL) of
0: insert(0, 'out of memory or resources');
ERROR_BAD_FORMAT: insert(0, 'file is invalid in image');
ERROR_FILE_NOT_FOUND: insert(0, 'file was not found');
ERROR_PATH_NOT_FOUND: insert(0, 'path was not found');
end;
Insert(0, Format('%-20s %s',
[DateTimeToStr(now), filename + ' Loaded...']));
end
{$ENDIF}

The datastructure is a direct file access. In this case, rather than populating a stand-alone memory structure, the data is written to the StringGrid (which is serving both as a memory structure for holding the data and as a visual control for navigating and editing the data).

type
TAppData = record
Name: string[50];
Size: longint;
Release: string[30];
descript: string[80];
end;

TBuildAppGrid = class(TObject)
private
aGrid: TStringGrid;
app: TAppData;
f: file of TAppData;
FaDatfile: ShortString;
Fmodified: Boolean;
protected
function GetaDatfile: ShortString;
procedure SetaDatfile(const Value: ShortString);
public
constructor initGrid(vGrid: TStringGrid; vFile: shortString);
procedure fillGrid;
procedure storeGrid;
property aDatfile: ShortString read GetaDatfile write SetaDatfile;
property modified: Boolean read Fmodified write Fmodified;
end;

One note about execution on linux with libc-commands; there will be better solutions (execute and wait and so on) and we still work on it, so I'm curious about comments on

"Delphi Web Start"

therfore my aim is to publish improvments in a basic framework on sourceforge.net depends on your feedback ;)

Many thanks to Dr. Karlheinz M�rth with a first glance.

Test your server with the telnet program. After connecting with host, type "return_list" and you'll see a first result. I know that we haven't implement an error handling procedure, but for our scope this example is almost sufficient. The DWS-source holds version 0.9.

28.10.03 Project DWS is now under Sourceforge: http://sourceforge.net/projects/delphiwebstarthttp://sourceforge.net/projects/delphiwebstart

Component Download: http://max.kleiner.com/download/dws.ziphttp://max.kleiner.com/download/dws.zip

Dragging non-windowed controls at run-time

Problem/Question/Abstract:

Someone asked how to drag a TImage for example, and just playing with code I came up with this quick (and dirty?) solution.

Answer:

There's an article here on how to drag windowed controls "Dragging controls and forms the easy way", but that code doesn't work for TImages for example

My solution for such thing is simply put the Image inside a TPanel and from the Image OnMouseDown call the code of the TPanel, thus resulting in being able to move the image, here's the code:

procedure TForm1.Panel1MouseDown(Sender: TObject; Button: TMouseButton;
Shift: TShiftState; X, Y: Integer);
const
SC_DragMove = $F012; {this is magic (undocumented)}
begin
ReleaseCapture;
panel1.perform(WM_SysCommand, SC_DragMove, 0);
end;

procedure TForm1.Image1MouseDown(Sender: TObject; Button: TMouseButton;
Shift: TShiftState; X, Y: Integer);
begin
panel1mousedown(Sender, Button, Shift, X, Y)
end;

The same would work for resizing, or all the other things that can be done changing the constant (given that the image is aligned using alClient)

Get the name and domain of a logged-in user

Problem/Question/Abstract:

How to get the name and domain of a logged-in user

Answer:

In the form's OnClose method, call AnimateWindow. For example, the following call fades out the window:

function NetServerGetInfo(serverName: PWideChar; level: Integer;
var bufptr: Pointer): Cardinal; stdcall; external 'NETAPI32.DLL';

function NetApiBufferFree(buffer: Pointer): Cardinal; stdcall; external
'NETAPI32.DLL';

type
SERVER_INFO_503 = record
sv503_sessopens: Integer;
sv503_sessvcs: Integer;
sv503_opensearch: Integer;
sv503_sizreqbuf: Integer;
sv503_initworkitems: Integer;
sv503_maxworkitems: Integer;
sv503_rawworkitems: Integer;
sv503_irpstacksize: Integer;
sv503_maxrawbuflen: Integer;
sv503_sessusers: Integer;
sv503_sessconns: Integer;
sv503_maxpagedmemoryusage: Integer;
sv503_maxnonpagedmemoryusage: Integer;
sv503_enablesoftcompat: BOOL;
sv503_enableforcedlogoff: BOOL;
sv503_timesource: BOOL;
sv503_acceptdownlevelapis: BOOL;
sv503_lmannounce: BOOL;
sv503_domain: PWideChar;
sv503_maxcopyreadlen: Integer;
sv503_maxcopywritelen: Integer;
sv503_minkeepsearch: Integer;
sv503_maxkeepsearch: Integer;
sv503_minkeepcomplsearch: Integer;
sv503_maxkeepcomplsearch: Integer;
sv503_threadcountadd: Integer;
sv503_numblockthreads: Integer;
sv503_scavtimeout: Integer;
sv503_minrcvqueue: Integer;
sv503_minfreeworkitems: Integer;
sv503_xactmemsize: Integer;
sv503_threadpriority: Integer;
sv503_maxmpxct: Integer;
sv503_oplockbreakwait: Integer;
sv503_oplockbreakresponsewait: Integer;
sv503_enableoplocks: BOOL;
sv503_enableoplockforceclose: BOOL;
sv503_enablefcbopens: BOOL;
sv503_enableraw: BOOL;
sv503_enablesharednetdrives: BOOL;
sv503_minfreeconnections: Integer;
sv503_maxfreeconnections: Integer;
end;
PSERVER_INFO_503 = ^SERVER_INFO_503;

function Get_User_Name: string;
var
dwlen: DWORD;
begin
dwlen := MAX_COMPUTERNAME_LENGTH + 1;
Setlength(Result, dwlen);
GetUserName(pchar(Result), dwlen);
Result := StrPas(pchar(Result));
end;

function Get_Computer_Name: string;
var
dwlen: DWORD;
begin
dwlen := MAX_COMPUTERNAME_LENGTH + 1;
Setlength(Result, dwlen);
GetComputerName(pchar(Result), dwlen);
Result := StrPas(pchar(Result));
end;

function GetDomainName: string;
var
err: Integer;
buf: pointer;
fDomainName: string;
wServerName: WideString;
begin
wServerName := Get_Computer_Name;
err := NetServerGetInfo(PWideChar(wServerName), 503, buf);
if err = 0 then
try
fDomainName := PSERVER_INFO_503(buf)^.sv503_domain;
finally
NetAPIBufferFree(buf)
end;
Result := fDomainName;
end;

Class to Execute and Manage External EXE in your App

Problem/Question/Abstract:

This class allows you to Execute and Manage External Applications from within your Application.

Features

Execute with or without 'Wait for Completion'
Get the Windows Handle of the running App.
Determine if the Executed App is still running.
Close the running App (Like a user would)
Terminate the running App (Like 'End Task' in Task Manager)
Autoclose the App if running when class Freed or your App terminates.
SetFocus and Restore a running App.

Usage Examples :

{...}
var
WApp: TWinApp;
{...}
WApp := TWinApp.Create;
WApp.ApplcationName := 'c:\winnt\notepad.exe';
WApp.parameters := 'c:\mytest.txt';
{or}
WApp := TWinApp.Create('c:\winnt\notepad.exe', 'c:\mytest.txt');
{...}
WApp.Execute;
{...}
PostMessage(WApp.Handle, WM_XXXX, .....
{...}
WApp.Close
{...}
if WApp.IsRunning then
WApp.SetFocus.....
{...}
if {....} then
WApp.Terminate
{...}
WApp.Free; {WApp will close if CloseOnExit = true}

This is a brand new beta class from my side, so any bugs, fixes or enhancements will be appreciated.

Answer:

unit MahWinExec;
interface

uses Windows, Messages, SysUtils, Forms;

// ==========================================================================
// Class to Manage External Windows Application in your Application
// Mike Heydon April 2004
//
// PROPERTIES
// ----------
// WaitForHandle   - Denotes whether to wait for windows to create and
//                   allocate a Handle to the Main Window of the Executed
//                   Application. Default is false. (Only neede to be true
//                   if you really required the window handle IMMEDIATELY
//                   after calling execute). If false the Handle will
//                   eventually become available once the app has loaded
//                   and created the main window.
//
// Handle          - Returns the Handle of the Executed App's main window.
//                   See property WaitForHandle. This can be used for API
//                   calls such as SendMessage() and ShowWindow() or any
//                   call that requires a valid Windows Handle (HWND).
//
// CloseOnExit     - Denotes whether to close the Executed App (if running)
//                   when YOUR applications end. Default is true.
//
// IsRunning       - Read Only. Denotes whether the Executed App is still
//                   running or not. It may have been closed by the User,
//                   Close Method, Terminate Method etc.
//
// ApplicationName - Name of the App to Execute. Can also be specified at
//                   Create time using an overloaded Create() method.
//                   eg. 'c:\winnt\notepad.exe'
//
// StartDirectory  - Name of the Directory to start the Application in.
//                   Default is '' (Current Directory).
//                   eg. 'c:\mydir'
//
// Parameters      - Any parameters (Command Line Argument) to the App.
//                   eg. 'c:\mydata\problems.txt'
//
// METHODS
// -------
// Execute         - Execute the Application specified by properties
//                   ApplicationName,Parameters and StartDirectory.
//                   If optional parameter AWaitForTerminate is set to
//                   true then Execute will NOT return until the Executed
//                   Application has been shut down or terminated. Default
//                   for this parameter is false (Executes returns
//                   immediately and execution of main thread continues)
//                   You can also direct Execute to wait for the main
//                   window handle to be created, see property
//                   WaitForHandle for details.
//
// Close           - If the App is Running then a windows message is sent
//                   to it instruction it to close and exit. This is the
//                   same as if the User had selected EXIT in the App.
//
// Terminate       - If the App is Running then TerminateProcess() is
//                   executed on the App's process ID. This is the same as
//                   selected "End Task" in the task manager. Use it only in
//                   extreme circumstances. The state of global data
//                   maintained by dynamic-link libraries (DLLs) may be
//                   compromised if Terminate is used rather than Close
//
// SetFocus        - If Running then the Executed App is given focus.
//
// ==========================================================================

type

// TWinApp - Windows Executable App manager
TWinApp = class(TObject)
private
FApplicationName,
FStartDirectory,
FParameters: string;
FCloseOnExit,
FWaitForHandle: boolean;
FProcHandle: THandle;
FStartupInfo: TStartupInfo;
FProcessInfo: TProcessInformation;
function GetWindowHandle: THandle;
function GetAppRunning: boolean;
public
// Methods
constructor Create; overload;
constructor Create(const AApplicationName: string;
AParameters: string = '';
AStartDirectory: string = ''); overload;
destructor Destroy; override;
function Execute(AWaitForTerminate: boolean = false): boolean;
procedure Terminate;
procedure Close;
procedure SetFocus;

// Properties
property Handle: THandle read GetWindowHandle;
property WaitForHandle: boolean read FWaitForHandle
write FWaitForHandle;
property IsRunning: boolean read GetAppRunning;
property CloseOnExit: boolean read FCloseOnExit write FCloseOnExit;
property ApplicationName: string read FApplicationName
write FApplicationName;
property Parameters: string read FParameters write FParameters;
property StartDirectory: string read FStartDirectory
write FStartDirectory;
end;

// --------------------------------------------------------------------------
implementation

// ====================================
// Constructor Methods - Overloaded
// ====================================

constructor TWinApp.Create;
begin
FProcHandle := 0;
FCloseOnExit := true;
FApplicationName := '';
FStartDirectory := '';
FParameters := '';
FWaitForHandle := false;
end;

constructor TWinApp.Create(const AApplicationName: string;
AParameters: string = '';
AStartDirectory: string = '');
begin
Create; // Call Standard Constructor
FApplicationName := AApplicationName;
FParameters := AParameters;
FStartDirectory := AStartDirectory;
end;

// =====================================================================
// Get Handle of Main Window of Executed Application
// Returns 0 if App not running or No main Window Handle.
//
// NOTE : If WaitForHanlde is false this function may return 0 if called
//        to soon after Execute(), as the Main Window may not yet have
//        been created and a Windows Handle allocated. If you require
//        the handle immediately after calling Execute then set
//        property WaitForHandle to true. Execute will then not return
//        until the Windows Handle is present.
//        Default for WaitForHandle is false.
// =====================================================================

function TWinApp.GetWindowHandle: THandle;

type
PTEnumCodeData = ^TEnumCodeData; // Data struture used
TEnumCodeData = record // for API CallBack Proc
WindowsHandle, // EnumWindowsCode()
ProcessHandle: THandle;
end;

var
rEnumCodeData: TEnumCodeData;
Retvar: THandle;

// Win API Callback Function
function EnumWindowsCode(Wnd: hWnd;
PInfo: PTEnumCodeData): boolean;
export; stdcall;
var
hProcess: THandle;
begin
GetWindowThreadProcessId(Wnd, hProcess);

if PInfo^.ProcessHandle = hProcess then
begin
PInfo^.WindowsHandle := Wnd;
Result := false;
end
else
Result := true;
end;

// Start GetWindowHandle()
begin
if FProcHandle <> 0 then
begin
rEnumCodeData.ProcessHandle := FProcessInfo.dwProcessId;
rEnumCodeData.WindowsHandle := 0;
EnumWindows(@EnumWindowsCode, integer(@rEnumCodeData));
Retvar := rEnumCodeData.WindowsHandle;
end
else
Retvar := 0;

Result := Retvar;
end;

// ===============================================
// Destructor Method
// If property CloseOnExit is true then the
// Executed Application is closed if running
// ===============================================

destructor TWinApp.Destroy;
begin
if FCloseOnExit and GetAppRunning then
Close;
if FProcHandle <> 0 then
CloseHandle(FProcHandle);

inherited Destroy;
end;

// =====================================
// Check if the app is running or not
// =====================================

function TWinApp.GetAppRunning: boolean;
var
Retvar: boolean;
iExitCode: DWORD;
begin
if FProcHandle <> 0 then
begin
if GetExitCodeProcess(FProcHandle, iExitCode) then
Retvar := iExitCode = STILL_ACTIVE
else
Retvar := false;
end
else
Retvar := false;

Result := Retvar;
end;

// ==============================
// Execute the application
// ==============================

function TWinApp.Execute(AWaitForTerminate: boolean = false): boolean;
var
Retvar: boolean;
sCurrDir,
sCommand: string;
Wnd: THandle;
begin
Retvar := false; // Assume we can't execute

if not GetAppRunning then
begin
if FProcHandle <> 0 then
CloseHandle(FProcHandle);
sCurrDir := GetCurrentDir;
if trim(FStartDirectory) <> '' then
SetCurrentDir(FStartDirectory);

FParameters := trim(FParameters);
FProcHandle := 0;
FillChar(FStartupInfo, SizeOf(FStartupInfo), 0);
FStartupInfo.wShowWindow := SW_SHOWNORMAL;
FStartupInfo.cb := SizeOf(FStartupInfo);

if FParameters <> '' then
sCommand := trim(FApplicationName) + ' "' + FParameters + '"'
else
sCommand := trim(FApplicationName);

if CreateProcess(nil, PChar(sCommand), nil, nil, false, 0, nil, nil,
FStartupInfo, FProcessInfo) then
begin

// Must we wait for App to finish ?
// If so then  all handles are n/a
if AWaitForTerminate then
begin
WaitForSingleObject(FProcessInfo.hProcess, INFINITE);
FProcHandle := 0;
end
else
begin
// Get Main Window Process Handle
// FProcessInfo.dwProcessID is NOT the handle we are
// looking for. (think it is an Explorer Process
FProcHandle := OpenProcess(PROCESS_ALL_ACCESS, false,
FProcessInfo.dwProcessId);

// Must we wait until App is loaded and has a windows handle ?
// If so then stay in loop until Main Windows of App is created
// and a Windows Handle has been allocated.
// Default for this action is false
if FWaitForHandle then
while GetWindowHandle = 0 do
Application.ProcessMessages;
end;

// Close unused handles
CloseHandle(FProcessInfo.hProcess);
CloseHandle(FProcessInfo.hThread);
Retvar := true;
end
else
FProcHandle := 0;

SetCurrentDir(sCurrDir);
end
else
begin
if FProcHandle <> 0 then
begin
Wnd := GetWindowHandle;

if Wnd <> 0 then
begin
// Focus and DeMinize App
SetForegroundWindow(Wnd);
ShowWindow(Wnd, SW_RESTORE);
Retvar := true;
end;
end;
end;

Result := RetVar;
end;

// =============================================
// Ask the Application to close down normally
// =============================================

procedure TWinApp.Close;
var
Wnd: THandle;
begin
if FProcHandle <> 0 then
begin
Wnd := GetWindowHandle;
if Wnd <> 0 then
PostMessage(Wnd, WM_QUIT, 0, 0);
end;
end;

// ===================================================================
// The Terminate method is used to unconditionally cause a
// TWinApp to exit. Use it only in extreme circumstances. The state of
// global data maintained by dynamic-link libraries (DLLs) may be
// compromised if Terminate is used rather than Close
// ===================================================================

procedure TWinApp.Terminate;
begin
if FProcHandle <> 0 then
TerminateProcess(FProcHandle, 0);
end;

// ========================================
// Bring to the front and give focus
// ========================================

procedure TWinApp.SetFocus;
var
Wnd: THandle;
begin
if FProcHandle <> 0 then
begin
Wnd := GetWindowHandle;

if (Wnd <> 0) and GetAppRunning then
begin
SetForegroundWindow(Wnd);
ShowWindow(Wnd, SW_RESTORE);
end;
end;
end;

end.

Detect if a new drive has been added

Problem/Question/Abstract:

In my software I need to detect if a new drive is attached to the computer through an USB port. The Windows Explorer expands automatically, so I assume there is a Windows Message broadcasted. Can anyone help me how to detect a new drive?

Answer:

{ ... }
type
TForm1 = class(TForm)
{ ... }
private
procedure WMDEVICECHANGE(var Msg: TMessage); message WM_DEVICECHANGE;
{ ... }
end;

procedure TFormBookBrowse.WMDEVICECHANGE(var Msg: TMessage);
const
DBT_DEVICEARRIVAL = $8000;
DBT_DEVICEREMOVECOMPLETE = $8004;
begin
inherited;
case Msg.WParam of
DBT_DEVICEARRIVAL:
begin
{ ... }
end;
DBT_DEVICEREMOVECOMPLETE:
begin
{ ... }
end;
end;
end;

Save the printer setting to file

Problem/Question/Abstract:

How to save the printer setting to file and then load it

Answer:

Create a unit PrinterSetup and place code in this unit. Do the following to save the printer config to file

procedure TForm1.Button1Click(Sender: TObject);
var
PrinterSetup: TPrinterSetup
begin
PrinterSetup := TPrinterSetup.Create;
PrinterSetup.SaveSetup(FileName);
//where file name is a string to the location of the File ex.'c:\print.cfg'
PrinterSetup.Free;
end

PrinterSetup unit  code

unit PrinterSetup;

interface

uses
printers,
windows,
SysUtils,
Classes,
WinSpool;

type
TPrinterSetup = class

private
Device, Driver, Port: array[0..CCHDEVICENAME] of char;
DeviceMode: THandle;
procedure Refresh;

protected

public
procedure SaveSetup(FileName: TFilename);
procedure LoadSetup(FileName: TFilename);
end;
TPrinterConfig = record
ADevice, ADriver, APort: array[0..CCHDEVICENAME] of char;
SizeOfDeviceMode: DWORD;
end;

implementation

procedure TPrinterSetup.Refresh;
begin
Printer.GetPrinter(Device, Driver, Port, DeviceMode);
end;

procedure TPrinterSetup.SaveSetup(FileName: TFilename);
var
StubDevMode: TDeviceMode;
SetupPrinter: TPrinterConfig;
FPrinterHandle: THandle;
fFileConfig: file of TPrinterConfig;
fFileDevMode: file of Char;
pDevMode: PChar;
Contador: Integer;
begin
Refresh;
with SetupPrinter do
begin
StrLCopy(ADevice, Device, SizeOf(ADevice));
StrLCopy(ADriver, Driver, SizeOf(ADriver));
StrLCopy(APort, Port, SizeOf(APort));
OpenPrinter(Device, FPrinterHandle, nil);
SizeOfDeviceMode := DocumentProperties(0, FPrinterHandle, Device,
StubDevMode, StubDevMode, 0);
end;
AssignFile(fFileConfig, FileName);
ReWrite(fFileConfig);
Write(fFileConfig, SetupPrinter);
CloseFile(fFileConfig);
AssignFile(fFileDevMode, FileName);
Reset(fFileDevMode);
Seek(fFileDevMode, FileSize(fFileDevMode));
pDevMode := GlobalLock(DeviceMode);
for Contador := 0 to SetupPrinter.SizeOfDeviceMode - 1 do
begin
Write(fFileDevMode, pDevMode[Contador]);
end;
CloseFile(fFileDevMode);
GlobalUnLock(DeviceMode);
end;

procedure TPrinterSetup.LoadSetup(FileName: TFilename);
var
SetupPrinter: TPrinterConfig;
fFileConfig: file of TPrinterConfig;
fFileDevMode: file of Char;
ADeviceMode: THandle;
pDevMode: PChar;
Contador: Integer;
begin
if FileExists(FileName) then
begin
AssignFile(fFileConfig, FileName);
Reset(fFileConfig);
read(fFileConfig, SetupPrinter);
CloseFile(fFileConfig);
AssignFile(fFileDevMode, FileName);
Reset(fFileDevMode);
Seek(fFileDevMode, SizeOf(SetupPrinter));
ADeviceMode := GlobalAlloc(GHND, SetupPrinter.SizeOfDeviceMode);
pDevMode := GlobalLock(ADeviceMode);
for Contador := 0 to SetupPrinter.SizeOfDeviceMode - 1 do
begin
read(fFileDevMode, char(pDevMode[Contador]));
end;
CloseFile(fFileDevMode);
GlobalUnLock(ADeviceMode);
Printer.SetPrinter(SetupPrinter.ADevice, SetupPrinter.ADriver,
SetupPrinter.APort, ADeviceMode);
end;
end;

end.

Drawing a bounding box with a mouse

Problem/Question/Abstract:

How can I draw a bounding box with a mouse?

Answer:

private
{ Private declarations }
AnchorX, AnchorY,
CurX, CurY: Integer;
Bounding: Boolean;
end;

implementation

procedure TForm1.FormMouseDown(Sender: TObject; Button: TMouseButton;
Shift: TShiftState; X, Y: Integer);
begin
AnchorX := X;
CurX := X;
AnchorY := Y;
CurY := Y;
Bounding := True;
end;

procedure TForm1.FormMouseMove(Sender: TObject; Shift: TShiftState; X,
Y: Integer);
begin
if Bounding then
begin
Canvas.Pen.Mode := pmNot;
Canvas.Pen.Width := 2;
Canvas.Brush.Style := bsClear;
Canvas.Rectangle(AnchorX, AnchorY, CurX, CurY);
CurX := X;
CurY := Y;
Canvas.Rectangle(AnchorX, AnchorY, CurX, CurY);
end;
end;

procedure TForm1.FormMouseUp(Sender: TObject; Button: TMouseButton;
Shift: TShiftState; X, Y: Integer);
begin
if Bounding then
begin
Bounding := False;
Canvas.Pen.Mode := pmNot;
Canvas.Brush.Style := bsClear;
Canvas.Rectangle(AnchorX, AnchorY, CurX, CurY);
end;
end;

Implement an Array Property

Problem/Question/Abstract:

In an interface we can't use fields so when you declare a class that implements one or more interfaces, you must provide an implementation of all the methods declared in the interface and the fields too. Therefore Array Properties are welcome.

Answer:

Properties come in two mode behaviour, scalar and array. An array property can't be published in component design, but they have many other uses to struct your class. One of the best features is the array index can be ANY type, and multidimensional arrays are possible, too. For array-type properties, we must use getter and setter, means read and write methods; no possibilitie to map an array-type property directly to an array-type field. Thats real design. First we need a class or interface:

IChaosBase = interface(IUnknown)
['{C6661345-26D1-D611-9FAD-C52B9EAAF7C0}']
function getScales(index: integer): Tdouble; stdcall;
procedure setScales(index: integer; scale: Tdouble); stdcall;
property scales[index: integer]: TDouble
read getScales write setScales;
end;

The aim is to store those 4 fields with the property scales[]:

scaleX1: double;
scaleX2: double;
scaleY1: double;
scaleY2: double;

Second we need the implementing class. The simplest way to implement the _AddRef, _Release, and QueryInterface methods is to inherit them from TInterfacedObject, thats the meaning of TInterfacedObject:

type
TDouble = double;
TDoubleArray = array[1..4] of TDouble;

TChaosBase = class(TInterfacedObject, IChaosBase)
protected
myscales: TDoubleArray;
function getScales(index: integer): TDouble; stdcall;
procedure setScales(index: integer; scale: TDouble); stdcall;
property scales[index: integer]: TDouble
read getScales write setScales;
end;

Now comes the setter and getter, especially the setter setScalses() needs a second parameter to define the type (you remember the array index can be ANY type) in our case a simple double. Also the datastructure can be choosen (list, map, collection), in our case the structure is a simple array.

function TChaosBase.getScales(index: integer): Tdouble;
begin
result := myscales[index];
end;

procedure TChaosBase.setScales(index: integer; scale: Tdouble);
begin
myScales[index] := scale;
end;

At least the write-access goes like this from any class or method:

scales[1] := 0.89;
scales[2] := 1.23;
scales[3] := 0.23;
scales[4] := 1.34;

or the read-access is a simple call to the propertie:

scaledX := (X - scales[1]) / (scales[2] - scales[1]);
scaledY := (Y - scales[4]) / (scales[3] - scales[4]);

Default access: There can be only one default array property for each class, means instead of myChaosBase.scales[i] we can use myChaosBase[i] with the directive default:

property scales[index: integer]: TDouble read getScales write setScales; default;

Why always drag a window by its title bar?

Problem/Question/Abstract:

Why always drag a window by its title bar?

Answer:

If you want to give your users the ability to move your application by dragging it
by clicking anywhere on your application window (see Windows 3.1's Clock application),
here's what you can do:

private

procedure WMNCHitTest(var Msg: TWMNCHitTest);
  message wm_NCHitTest;

..

procedure TForm1.WMNCHitTest(var Msg: TWMNCHitTest);
begin
  inherited;
  if htClient = Msg.Result then
    Msg.Result := htCaption;
end;

Variant records: the equivalent to the C-union structure

Problem/Question/Abstract:

Is there a way to create a C 'union'-like structure in Delphi? That is, a structure that uses the same memory area?

Answer:

The Delphi (Pascal/ObjectPascal) equivalent to a C-union structure is called a Variant Record (not to be confused with the Variant "type" available in Delphi 2.0+). As with a C- union, the Pascal variant record allows several structure types to be combined into one, and all will occupy the same memory space. Look up the syntax declaration under "Records" in the help file. But here's an example:

type
  TPerson = record
    FirstName, LastName: string[40];
    BirthDate: TDate;
    case Citizen: Boolean of
      True: (BirthPlace: string[40]);
      False: (Country: string[20];
        EntryPort: string[20];
        EntryDate: TDate;
        ExitDate: TDate);
  end;

The record above is actually a single expression of two records that could describe a person:

type
  TPersonCitizen = record
    FirstName, LastName: string[40];
    BirthDate: TDate;
    BirthPlace: string[40]
  end;

  and

type
  TPersonAlien = record
    FirstName, LastName: string[40];
    BirthDate: TDate;
    Country: string[20];
    EntryPort: string[20];
    EntryDate: TDate;
    ExitDate: TDate;
  end;

And as in a union, the combination of the two types of records makes for much more efficient programming, because a person could be expressed in a variety of ways.

Everything I explained above is pretty hypothetical stuff. In Delphi, the TRect structure that describes a rectangle is actually a variant record:

type
  TPoint = record
    X: Longint;
    Y: Longint;
  end;

TRect = record
  case Integer of
    0: (Left, Top, Right, Bottom: Integer);
    1: (TopLeft, BottomRight: TPoint);
end;

where the coordinates of the rectangle can be expressed using either four integer values or two TPoints.

I realize this is pretty quick and dirty, so I suggest you refer to the help file for a more in-depth explanation, or go to your nearest book store or library and look at any Pascal book (not Delphi -- most won't explain this fairly esoteric structure). However, if you're familiar with the C-union, this stuff should be an absolute breeze.

Using indexes with InterBase

Problem/Question/Abstract:

Using indexes with InterBase

Answer:

The types of indexes and the best choice depends on the DBMS. The following has been found for InterBase.

create indexes on columns that are used in where or join clauses of your SQL statements

if you use ORDER BY constructs, have an (compound) index of fields in the same order as in the ORDER BY construct

if you combine conditions with OR, you may want to have single indexes on each field of your conditions

select * from t where col1 =

How to hide a program from Windows

Problem/Question/Abstract:

How to hide a program from Windows

Answer:

Look at this modified project source and apply the changes to your own project:

program Project1;

uses
  Forms,
  Unit1 in 'Unit1.pas' {Form1},
  Windows;

{$R *.RES}

var
  ExtendedStyle: Integer;

begin
  Application.Initialize;
  ExtendedStyle := GetWindowLong(Application.Handle, GWL_EXSTYLE);
  SetWindowLong(Application.Handle, GWL_EXSTYLE, ExtendedStyle or WS_EX_TOOLWINDOW
    and not WS_EX_APPWINDOW);
  Application.CreateForm(TForm1, Form1);
  Application.Run;
end.