Monitoring System Shell Changes using Delphi

TSHChangeNotify

unit SHChangeNotify;

{$IFNDEF VER80} {$IFNDEF VER90} {$IFNDEF VER93}
  {$DEFINE Delphi3orHigher}
{$ENDIF} {$ENDIF} {$ENDIF}

//*************************************************************
//*************************************************************
// TSHChangeNotify component by Elliott Shevin  shevine@aol.com
// vers. 3.0, October 2000
//
//   See the README.TXT file for revision history.
//
//*
//*  I owe this component to James Holderness, who described the
//*  use of the undocumented Windows API calls it depends upon,
//*  and Brad Martinez, who coded a similar function in Visual
//*  Basic. I quote here from Brad's expression of gratitude to
//*  James:
//*     Interpretation of the shell's undocumented functions
//*     SHChangeNotifyRegister (ordinal 2) and SHChangeNotifyDeregister
//*     (ordinal 4) would not have been possible without the
//*     assistance of James Holderness. For a complete (and probably
//*     more accurate) overview of shell change notifcations,
//*     please refer to James'  "Shell Notifications" page at
//*     http://www.geocities.com/SiliconValley/4942/
//*
//*  This component will let you know when selected events
//*  occur in the Windows shell, such as files and folders
//*  being renamed, added, or deleted. (Moving an item yields
//*  the same results as renaming it.) For the complete list
//*  of events the component can trap, see Win32 Programmer's
//*  reference description of the SHChangeNotify API call.
//*
//*  Properties:
//*     MessageNo: the Windows message number which will be used to signal
//*                a trapped event. The default is WM_USER (1024); you may
//*                set it to some other value if you're using WM_USER for
//*                any other purpose.
//*     TextCase:  tcAsIs (default), tcLowercase, or tcUppercase, determines
//*                whether and how the Path parameters passed to your event
//*                handlers are case-converted.
//*     HardDriveOnly: when set to True, the component monitors only local
//*                hard drive partitions; when set to False, monitors the
//*                entire file system.
//*
//*  Methods:
//*     Execute:   Begin monitoring the selected shell events.
//*     Stop:      Stop monitoring.
//*
//*  Events:
//*     The component has an event corresponding to each event it can
//*     trap, e.g. OnCreate, OnMediaInsert, etc.
//*     Each event handler is passed either three or four parameters--
//*          Sender=this component.
//*          Flags=the value indentifying the event that triggered the handler,
//*             from the constants in the SHChangeNotify help. This parameter
//*             allows multiple events to share handlers and still distinguish
//*             the reason the handler was triggered.
//*          Path1, Path2: strings which are the paths affected by the shell
//*             event. Whether both are passed depends on whether the second
//*             is needed to describe the event. For example, OnDelete gives
//*             only the name of the file (including path) that was deleted;
//*             but OnRenameFolder gives the original folder name in Path1
//*             and the new name in Path2.
//*             In some cases, such as OnAssocChanged, neither Path parameter
//*             means anything, and in other cases, I guessed, but we always
//*             pass at least one.
//*     Each time an event property is changed, the component is reset to
//*     trap only those events for which handlers are assigned. So assigning
//*     an event handler suffices to indicate your intention to trap the
//*     corresponding shell event.
//*
//*     There is one more event: OnEndSessionQuery, which has the same
//*     parameters as the standard Delphi OnCloseQuery (and can in fact
//*     be your OnCloseQuery handler). This component must shut down its
//*     interception of shell events when system shutdown is begun, lest
//*     the system fail to shut down at the user's request.
//*
//*     Setting CanEndSession (same as CanClose) to FALSE in an
//*     OnEndSessionQuery will stop the process of shutting down
//*     Windows. You would only need this if you need to keep the user
//*     from ending his Windows session while your program is running.
//*
//*   I'd be honored to hear what you think of this component.
//*   You can write me at shevine@aol.com.
//*************************************************************
//*************************************************************

interface

uses
  Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
  {$IFNDEF Delphi3orHigher}
     OLE2,
  {$ELSE}
     ActiveX, ComObj,
  {$ENDIF}

  ShlObj;

const
   SHCNF_ACCEPT_INTERRUPTS      = $0001;
   SHCNF_ACCEPT_NON_INTERRUPTS  = $0002;
   SHCNF_NO_PROXY               = $8000;

type NOTIFYREGISTER = record
    pidlPath      : PItemIDList;
    bWatchSubtree : boolean;
end;

type PNOTIFYREGISTER = ^NOTIFYREGISTER;

type TTextCase = (tcAsIs,tcUppercase,tcLowercase);

type
    TOneParmEvent = procedure(Sender : TObject; Flags : cardinal; Path1 : string) of object;
    TTwoParmEvent = procedure(Sender : TObject; Flags : cardinal; Path1, Path2 : string) of object;
    TEndSessionQueryEvent = procedure(Sender: TObject; var CanEndSession: Boolean) of object;

    function SHChangeNotifyRegister(
       hWnd        : HWND;
       dwFlags     : integer;
       wEventMask  : cardinal;
       uMsg        : UINT;
       cItems      : integer;
       lpItems     : PNOTIFYREGISTER) : HWND; stdcall;
    function SHChangeNotifyDeregister(
       hWnd        : HWND) : boolean; stdcall;
    function SHILCreateFromPath(Path: Pointer;
                     PIDL: PItemIDList; var Attributes: ULONG):
                     HResult; stdcall;


type
  TSHChangeNotify = class(TComponent)
  private
    fTextCase      : TTextCase;
    fHardDriveOnly : boolean;
    NotifyCount    : integer;
    NotifyHandle   : hwnd;
    NotifyArray    : array[1..26] of NOTIFYREGISTER;
    AllocInterface : IMalloc;
    PrevMsg        : integer;
    prevpath1      : string;
    prevpath2      : string;
    fMessageNo     : integer;
    fAssocChanged     : TTwoParmEvent;
    fAttributes       : TOneParmEvent;
    fCreate           : TOneParmEvent;
    fDelete           : TOneParmEvent;
    fDriveAdd         : TOneParmEvent;
    fDriveAddGUI      : TOneParmEvent;
    fDriveRemoved     : TOneParmEvent;
    fMediaInserted    : TOneParmEvent;
    fMediaRemoved     : TOneParmEvent;
    fMkDir            : TOneParmEvent;
    fNetShare         : TOneParmEvent;
    fNetUnshare       : TOneParmEvent;
    fRenameFolder     : TTwoParmEvent;
    fRenameItem       : TTwoParmEvent;
    fRmDir            : TOneParmEvent;
    fServerDisconnect : TOneParmEvent;
    fUpdateDir        : TOneParmEvent;
    fUpdateImage      : TOneParmEvent;
    fUpdateItem       : TOneParmEvent;
    fEndSessionQuery  : TEndSessionQueryEvent;

    OwnerWindowProc   : TWndMethod;

    procedure SetMessageNo(value : integer);
    procedure WndProc(var msg: TMessage);

  protected
    procedure QueryEndSession(var msg: TMessage);

  public
    constructor Create(AOwner : TComponent); override;
    destructor  Destroy; override;
    procedure   Execute;
    procedure   Stop;

  published
    property MessageNo : integer read fMessageNo write SetMessageNo default WM_USER;
    property TextCase : TTextCase read fTextCase write fTextCase  default tcAsIs;
    property HardDriveOnly : boolean  read fHardDriveOnly write fHardDriveOnly default True;

    property OnAssocChanged     : TTwoParmEvent read fAssocChanged write fAssocChanged;
    property OnAttributes : TOneParmEvent read fAttributes   write fAttributes;
    property OnCreate         : TOneParmEvent read fCreate       write fCreate;
    property OnDelete         : TOneParmEvent read fDelete       write fDelete;
    property OnDriveAdd         : TOneParmEvent read fDriveAdd     write fDriveAdd;
    property OnDriveAddGUI : TOneParmEvent read fDriveAddGUI  write fDriveAddGUI;
    property OnDriveRemoved : TOneParmEvent read fDriveRemoved write fDriveRemoved;
    property OnMediaInserted    : TOneParmEvent read fMediaInserted write fMediaInserted;
    property OnMediaRemoved : TOneParmEvent read fMediaRemoved write fMediaRemoved;
    property OnMkDir         : TOneParmEvent read fMkDir        write fMkDir;
    property OnNetShare         : TOneParmEvent read fNetShare     write fNetShare;
    property OnNetUnshare : TOneParmEvent read fNetUnshare   write fNetUnshare;
    property OnRenameFolder : TTwoParmEvent  read fRenameFolder write fRenameFolder;
    property OnRenameItem : TTwoParmEvent read fRenameItem   write fRenameItem;
    property OnRmDir         : TOneParmEvent read fRmDir        write fRmDir;
    property OnServerDisconnect : TOneParmEvent read fServerDisconnect write fServerDisconnect;
    property OnUpdateDir        : TOneParmEvent read fUpdateDir    write fUpdateDir;
    property OnUpdateImage : TOneParmEvent read fUpdateImage  write fUpdateImage;
    property OnUpdateItem       : TOneParmEvent read fUpdateItem   write fUpdateItem;
    property OnEndSessionQuery  : TEndSessionQueryEvent
                                         read fEndSessionQuery write fEndSessionQuery;
    { Published declarations }
  end;

procedure Register;

implementation

const Shell32DLL = 'shell32.dll';

function SHChangeNotifyRegister;
              external Shell32DLL index 2;
function SHChangeNotifyDeregister;
              external Shell32DLL index 4;
function SHILCreateFromPath;
              external Shell32DLL index 28;

procedure Register;
begin
  RegisterComponents('Custom', [TSHChangeNotify]);
end;

// Set defaults, and ensure NotifyHandle is zero.
constructor TSHChangeNotify.Create (AOwner : TComponent);
begin
   inherited Create(AOwner);
   fTextCase      := tcAsIs;
   fHardDriveOnly := true;

   fAssocChanged     := nil;
   fAttributes       := nil;
   fCreate           := nil;
   fDelete           := nil;
   fDriveAdd         := nil;
   fDriveAddGUI      := nil;
   fDriveRemoved     := nil;
   fMediaInserted    := nil;
   fMediaRemoved     := nil;
   fMkDir            := nil;
   fNetShare         := nil;
   fNetUnshare       := nil;
   fRenameFolder     := nil;
   fRenameItem       := nil;
   fRmDir            := nil;
   fServerDisconnect := nil;
   fUpdateDir        := nil;
   fUpdateImage      := nil;
   fUpdateItem       := nil;
   fEndSessionQuery  := nil;

   MessageNo    := WM_USER;

   // If designing, dodge the code that implements messag interception.
   if csDesigning in ComponentState
      then exit;

   // Substitute our window proc for our owner's window proc.
   OwnerWindowProc := (Owner as TWinControl).WindowProc;
   (Owner as TWinControl).WindowProc := WndProc;

   // Get the IMAlloc interface so we can free PIDLs.
   SHGetMalloc(AllocInterface);
end;

procedure TSHChangeNotify.SetMessageNo(value : integer);
begin
   if (value >= WM_USER)
     then fMessageNo := value
     else raise Exception.Create
                    ('MessageNo must be greater than or equal to '
                    + inttostr(WM_USER));
end;

// Execute unregisters any current notification and registers a new one.
procedure TSHChangeNotify.Execute;
var
   EventMask      : integer;
   driveletter    : string;
   i              : integer;
   pidl           : PItemIDList;
   Attributes     : ULONG;
   NotifyPtr      : PNOTIFYREGISTER;
begin
   NotifyCount := 0;

   if csDesigning in ComponentState
      then exit;

   Stop;  // Unregister the current notification, if any.

   EventMask := 0;
   if assigned(fAssocChanged     ) then EventMask := (EventMask or SHCNE_ASSOCCHANGED);
   if assigned(fAttributes       ) then EventMask := (EventMask or SHCNE_ATTRIBUTES);
   if assigned(fCreate           ) then EventMask := (EventMask or SHCNE_CREATE);
   if assigned(fDelete           ) then EventMask := (EventMask or SHCNE_DELETE);
   if assigned(fDriveAdd         ) then EventMask := (EventMask or SHCNE_DRIVEADD);
   if assigned(fDriveAddGUI      ) then EventMask := (EventMask or SHCNE_DRIVEADDGUI);
   if assigned(fDriveRemoved     ) then EventMask := (EventMask or SHCNE_DRIVEREMOVED);
   if assigned(fMediaInserted    ) then EventMask := (EventMask or SHCNE_MEDIAINSERTED);
   if assigned(fMediaRemoved     ) then EventMask := (EventMask or SHCNE_MEDIAREMOVED);
   if assigned(fMkDir            ) then EventMask := (EventMask or SHCNE_MKDIR);
   if assigned(fNetShare         ) then EventMask := (EventMask or SHCNE_NETSHARE);
   if assigned(fNetUnshare       ) then EventMask := (EventMask or SHCNE_NETUNSHARE);
   if assigned(fRenameFolder     ) then EventMask := (EventMask or SHCNE_RENAMEFOLDER);
   if assigned(fRenameItem       ) then EventMask := (EventMask or SHCNE_RENAMEITEM);
   if assigned(fRmDir            ) then EventMask := (EventMask or SHCNE_RMDIR);
   if assigned(fServerDisconnect ) then EventMask := (EventMask or SHCNE_SERVERDISCONNECT);
   if assigned(fUpdateDir        ) then EventMask := (EventMask or SHCNE_UPDATEDIR);
   if assigned(fUpdateImage      ) then EventMask := (EventMask or SHCNE_UPDATEIMAGE);
   if assigned(fUpdateItem       ) then EventMask := (EventMask or SHCNE_UPDATEITEM);

   if EventMask = 0   // If there's no event mask
      then exit;      // then there's no need to set an event.

   // If the user requests watches on hard drives only, cycle through
   // the list of drive letters and add a NotifyList element for each.
   // Otherwise, just set the first element to watch the entire file
   // system.
   if fHardDriveOnly
     then for i := ord('A') to ord('Z') do begin
            DriveLetter := char(i) + ':\';
            if GetDriveType(pchar(DriveLetter)) = DRIVE_FIXED
               then begin
                      inc(NotifyCount);
                      with NotifyArray[NotifyCount] do begin
                          SHILCreateFromPath
                                     (pchar(DriveLetter),
                                      addr(pidl),
                                      Attributes);
                          pidlPath := pidl;
                          bWatchSubtree := true;
                      end;
            end;
     end

     // If the caller requests the entire file system be watched,
     // prepare the first NotifyElement accordingly.
     else begin
          NotifyCount := 1;
          with NotifyArray[1] do begin
              pidlPath      := nil;
              bWatchSubtree := true;
          end;
     end;

     NotifyPtr    :=  addr(NotifyArray);

     NotifyHandle :=  SHChangeNotifyRegister(
                               (Owner as TWinControl).Handle,
                                SHCNF_ACCEPT_INTERRUPTS       +
                                    SHCNF_ACCEPT_NON_INTERRUPTS,
                                EventMask,
                                fMessageNo,
                                NotifyCount,
                                NotifyPtr);

   if NotifyHandle = 0
      then begin
             Stop;
             raise Exception.Create('Could not register SHChangeNotify');
   end;
end;

// This procedure unregisters the Change Notification
procedure TSHChangeNotify.Stop;
var
   NotifyHandle   : hwnd;
   i              : integer;
   pidl           : PITEMIDLIST;
begin
   if csDesigning in ComponentState
      then exit;

   // Deregister the shell notification.
   if NotifyCount > 0
      then SHChangeNotifyDeregister(NotifyHandle);

   // Free the PIDLs in NotifyArray.
   for i := 1 to NotifyCount do begin
      pidl := NotifyArray[i].PidlPath;
      if AllocInterface.DidAlloc(pidl) = 1
                         then AllocInterface.Free(pidl);
   end;

   NotifyCount := 0;
end;

// This is the procedure that is called when a change notification occurs.
// It interprets the two PIDLs passed to it, and calls the appropriate
// event handler, according to what kind of event occurred.
procedure TSHChangeNotify.WndProc(var msg: TMessage);
type
   TPIDLLIST = record
      pidlist : array[1..2] of PITEMIDLIST;
   end;
   PIDARRAY = ^TPIDLLIST;
var
   Path1    : string;
   Path2    : string;
   ptr      : PIDARRAY;
   p1,p2    : PITEMIDLIST;
   repeated : boolean;
   p        : integer;
   event    : longint;
   parmcount      : byte;
   OneParmEvent   : TOneParmEvent;
   TwoParmEvent   : TTwoParmEvent;

   // The internal function ParsePidl returns the string corresponding
   // to a PIDL.
   function ParsePidl (Pidl : PITEMIDLIST) : string;
   begin
      SetLength(result,MAX_PATH);
      if not SHGetPathFromIDList(Pidl,pchar(result))
          then result := '';
   end;

// The actual message handler starts here.
begin
  if Msg.Msg = WM_QUERYENDSESSION
     then QueryEndSession(Msg);

  if Msg.Msg = fMessageNo
     then begin
        OneParmEvent := nil;
        TwoParmEvent := nil;

        event := msg.LParam and ($7FFFFFFF);

        case event of
           SHCNE_ASSOCCHANGED     : TwoParmEvent := fAssocChanged;
           SHCNE_ATTRIBUTES       : OneParmEvent := fAttributes;
           SHCNE_CREATE           : OneParmEvent := fCreate;
           SHCNE_DELETE           : OneParmEvent := fDelete;
           SHCNE_DRIVEADD         : OneParmEvent := fDriveAdd;
           SHCNE_DRIVEADDGUI      : OneParmEvent := fDriveAddGUI;
           SHCNE_DRIVEREMOVED     : OneParmEvent := fDriveRemoved;
           SHCNE_MEDIAINSERTED    : OneParmEvent := fMediaInserted;
           SHCNE_MEDIAREMOVED     : OneParmEvent := fMediaRemoved;
           SHCNE_MKDIR            : OneParmEvent := fMkDir;
           SHCNE_NETSHARE         : OneParmEvent := fNetShare;
           SHCNE_NETUNSHARE       : OneParmEvent := fNetUnshare;
           SHCNE_RENAMEFOLDER     : TwoParmEvent := fRenameFolder;
           SHCNE_RENAMEITEM       : TwoParmEvent := fRenameItem;
           SHCNE_RMDIR            : OneParmEvent := fRmDir;
           SHCNE_SERVERDISCONNECT : OneParmEvent := fServerDisconnect;
           SHCNE_UPDATEDIR        : OneParmEvent := fUpdateDir;
           SHCNE_UPDATEIMAGE      : OneParmEvent := fUpdateImage;
           SHCNE_UPDATEITEM       : OneParmEvent := fUpdateItem;
           else begin
                   OneParmEvent := nil; // Unknown event;
                   TwoParmEvent := nil;
                end;
        end;
        if (assigned(OneParmEvent)) or (assigned(TwoParmEvent))
          then begin

                // Assign a pointer to the array of PIDLs sent
                // with the message.
                ptr := PIDARRAY(msg.wParam);

                // Parse the two PIDLs.
                p1 := ptr^.pidlist[1];
                try
                   SetLength(Path1,MAX_PATH);
                   Path1 := ParsePidl(p1);
                   p := pos(#00,Path1);
                   if p > 0
                      then SetLength(Path1,p - 1);
                except
                   Path1 := '';
                end;

                p2 := ptr^.pidlist[2];
                try
                   SetLength(Path2,MAX_PATH);
                   Path2 := ParsePidl(p2);
                   p := pos(#00,Path2);
                   if p > 0
                      then SetLength(Path2,p - 1);
                except
                   Path2 := '';
                end;

                // If this message is the same as the last one (which happens
                // a lot), bail out.
                try
                   repeated := (PrevMsg = event)
                                and (uppercase(prevpath1) = uppercase(Path1))
                                and (uppercase(prevpath2) = uppercase(Path2))
                except
                   repeated := false;
                end;

                // Save the elements of this message for comparison next time.
                PrevMsg    := event;
                PrevPath1  := Path1;
                PrevPath2  := Path2;

                // Convert the case of Path1 and Path2 if desired.
                case fTextCase of
                        tcUppercase : begin
                           Path1 := uppercase(Path1);
                           Path2 := uppercase(Path2);
                        end;
                        tcLowercase : begin
                           Path1 := lowercase(Path1);
                           Path2 := lowercase(Path2);
                        end;
                end;

                // Call the event handler according to the number
                // of paths we will pass to it.
                if not repeated then begin
                   case event of
                        SHCNE_ASSOCCHANGED,
                        SHCNE_RENAMEFOLDER,
                        SHCNE_RENAMEITEM   : parmcount := 2;
                   else parmcount := 1;
                   end;

                   if parmcount = 1
                      then OneParmEvent(self, event, Path1)
                      else TwoParmEvent(self, event, Path1, Path2);
                end;

        end;  // if assigned(OneParmEvent)...

  end;        // if Msg.Msg = fMessageNo...

  // Call the original message handler.
  OwnerWindowProc(Msg);
end;

procedure TSHChangeNotify.QueryEndSession(var msg: TMessage);
var
   CanEndSession : boolean;
begin
   CanEndSession := true;
   if Assigned(fEndSessionQuery)
      then fEndSessionQuery(Self, CanEndSession);
   if CanEndSession
      then begin
             Stop;
             Msg.Result := 1;
      end
      else Msg.Result := 0;
end;

destructor TSHChangeNotify.Destroy;
begin
   if not (csDesigning in ComponentState)
      then begin
             if Assigned(Owner)
               then (Owner as TWinControl).WindowProc := OwnerWindowProc;
             Stop;
   end;

   inherited;
end;

end.


{
********************************************
Zarko Gajic
About.com Guide to Delphi Programming
http://delphi.about.com
email: delphi@aboutguide.com
free newsletter: http://delphi.about.com/library/blnewsletter.htm
forum: http://forums.about.com/ab-delphi/start/
********************************************
}

Get Current User's SID

...Retrieve the current user's SID?

Author: Yorai Aminov 
Homepage: http://www.shorterpath.com 

Category: System

(******************************************************************************)
(* SPGetSid - Retrieve the current user's SID in text format                  *)
(*                                                                            *)
(* Copyright (c) 2004 Shorter Path Software                                   *)
(* http://www.shorterpath.com                                                 *)
(******************************************************************************)


{
  SID is a data structure of variable length that identifies user, group,
  and computer accounts.
  Every account on a network is issued a unique SID when the account is first created.
  Internal processes in Windows refer to an account's SID
  rather than the account's user or group name.
}


unit SPGetSid;

interface

uses
  Windows, SysUtils;

function GetCurrentUserSid: string;

implementation

const
  HEAP_ZERO_MEMORY = $00000008;
  SID_REVISION     = 1; // Current revision level

type
  PTokenUser = ^TTokenUser;
  TTokenUser = packed record
    User: TSidAndAttributes;
  end;

function ConvertSid(Sid: PSID; pszSidText: PChar; var dwBufferLen: DWORD): BOOL;
var
  psia: PSIDIdentifierAuthority;
  dwSubAuthorities: DWORD;
  dwSidRev: DWORD;
  dwCounter: DWORD;
  dwSidSize: DWORD;
begin
  Result := False;

  dwSidRev := SID_REVISION;

  if not IsValidSid(Sid) then Exit;

  psia := GetSidIdentifierAuthority(Sid);

  dwSubAuthorities := GetSidSubAuthorityCount(Sid)^;

  dwSidSize := (15 + 12 + (12 * dwSubAuthorities) + 1) * SizeOf(Char);

  if (dwBufferLen < dwSidSize) then
  begin
    dwBufferLen := dwSidSize;
    SetLastError(ERROR_INSUFFICIENT_BUFFER);
    Exit;
  end;

  StrFmt(pszSidText, 'S-%u-', [dwSidRev]);

  if (psia.Value[0] <> 0) or (psia.Value[1] <> 0) then
    StrFmt(pszSidText + StrLen(pszSidText),
      '0x%.2x%.2x%.2x%.2x%.2x%.2x',
      [psia.Value[0], psia.Value[1], psia.Value[2],
      psia.Value[3], psia.Value[4], psia.Value[5]])
  else
    StrFmt(pszSidText + StrLen(pszSidText),
      '%u',
      [DWORD(psia.Value[5]) +
      DWORD(psia.Value[4] shl 8) +
      DWORD(psia.Value[3] shl 16) +
      DWORD(psia.Value[2] shl 24)]);

  dwSidSize := StrLen(pszSidText);

  for dwCounter := 0 to dwSubAuthorities - 1 do
  begin
    StrFmt(pszSidText + dwSidSize, '-%u',
      [GetSidSubAuthority(Sid, dwCounter)^]);
    dwSidSize := StrLen(pszSidText);
  end;

  Result := True;
end;

function ObtainTextSid(hToken: THandle; pszSid: PChar;
  var dwBufferLen: DWORD): BOOL;
var
  dwReturnLength: DWORD;
  dwTokenUserLength: DWORD;
  tic: TTokenInformationClass;
  ptu: Pointer;
begin
  Result := False;
  dwReturnLength := 0;
  dwTokenUserLength := 0;
  tic := TokenUser;
  ptu := nil;

  if not GetTokenInformation(hToken, tic, ptu, dwTokenUserLength,
    dwReturnLength) then
  begin
    if GetLastError = ERROR_INSUFFICIENT_BUFFER then
    begin
      ptu := HeapAlloc(GetProcessHeap, HEAP_ZERO_MEMORY, dwReturnLength);
      if ptu = nil then Exit;
      dwTokenUserLength := dwReturnLength;
      dwReturnLength    := 0;

      if not GetTokenInformation(hToken, tic, ptu, dwTokenUserLength,
        dwReturnLength) then Exit;
    end 
    else 
      Exit;
  end;

  if not ConvertSid((PTokenUser(ptu).User).Sid, pszSid, dwBufferLen) then Exit;

  if not HeapFree(GetProcessHeap, 0, ptu) then Exit;

  Result := True;
end;

function GetCurrentUserSid: string;
var
  hAccessToken: THandle;
  bSuccess: BOOL;
  dwBufferLen: DWORD;
  szSid: array[0..260] of Char;
begin
  Result := '';

  bSuccess := OpenThreadToken(GetCurrentThread, TOKEN_QUERY, True,
    hAccessToken);
  if not bSuccess then
  begin
    if GetLastError = ERROR_NO_TOKEN then
      bSuccess := OpenProcessToken(GetCurrentProcess, TOKEN_QUERY,
        hAccessToken);
  end;
  if bSuccess then
  begin
    ZeroMemory(@szSid, SizeOf(szSid));
    dwBufferLen := SizeOf(szSid);

    if ObtainTextSid(hAccessToken, szSid, dwBufferLen) then
      Result := szSid;
    CloseHandle(hAccessToken);
  end;
end;

end.

Use a TPanel as a host for child windows (MDI simulation)

Problem/Question/Abstract:

I was wondering if someone can offer assistance with this application. Basically the application is for configuring our system. At present it is a MDI where child windows are various functions (security, report options, etc.). The number of functions are growing, currently around 15, which means an increase in different child forms and, overall, a growing exe. I would like the child forms to be standalone programs or dlls which can appear in the control program as child windows and also execute by themselves. Only one child form is displayed at a time and always maximised within the parent window. I did see some code about that provided for a dll as a child form, but this would not help as a standalone execution.

Answer:

This is an interesting problem. As it happens it is possible in Win32 to make another processes window appear like a child window in ones own windows. It does not work quite as well as a true child in your own process but takes care about moving the pseudo-child with your menu app.

The general design is this: the main/menu app has a form with menu, perhaps tool and status bars, and a client-aligned panel that will serve as the host for the child windows. It reads the available child apps from INI file or registry key and builds a menu or selection list from this info. On user request it launches the appropriate child app and passes the panels window handle on the commandline. The child app checks the command line, if there are no parameters it rans as designed, if there is a parameter it reads it, removes its border and bordericon, parents itself to the passed window handle and sizes itself to its client area. It also sends a message with *its* window handle to the panels parent (the main app form) to register itself. The main app can close the child with this handle and also resize it when the user resizes the main app.

Main app: has a menu with two entries (OpenMenu, CloseMenu), a toolbar with two buttons attached to the same events as the two menus, a statusbar, a client-aliged panel.

unit MenuApp;

interface

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

const
  UM_CHILDREGISTER = WM_USER + 111;
  UM_CHILDUNREGISTER = WM_USER + 112;

type
  TUmChildRegister = packed record
    msg: Cardinal;
    childwnd: HWND;
    unused: Integer;
    result: Integer;
  end;
  TUmChildUnregister = TUmChildregister;

  TForm1 = class(TForm)
    MainMenu1: TMainMenu;
    OpenMenu: TMenuItem;
    StatusBar1: TStatusBar;
    ToolBar1: TToolBar;
    ToolButton1: TToolButton;
    CloseMenu: TMenuItem;
    ToolButton2: TToolButton;
    Panel1: TPanel;
    procedure OpenMenuClick(Sender: TObject);
    procedure CloseMenuClick(Sender: TObject);
    procedure Panel1Resize(Sender: TObject);
    procedure FormClose(Sender: TObject; var Action: TCloseAction);
  private
    { Private declarations }
    FChildAppHandle: HWND;
    procedure UMChildRegister(var msg: TUmChildRegister);
      message UM_CHILDREGISTER;
    procedure UMChildUnRegister(var msg: TUmChildUnRegister);
      message UM_CHILDUNREGISTER;
  public
    { Public declarations }
  end;

var
  Form1: TForm1;

implementation

uses
  shellapi;

{$R *.DFM}

procedure TForm1.OpenMenuClick(Sender: TObject);
var
  path, param: string;
begin
  if FChildAppHandle = 0 then
  begin
    path := ExtractFilePath(Application.Exename) + 'childAppProj.exe';
    param := '$' + IntTohex(panel1.handle, 8);
    ShellExecute(handle, 'open', pchar(path), pchar(param), nil, SW_SHOWNORMAL);
  end
  else
    ShowMessage('Child already loaded');
end;

procedure TForm1.CloseMenuClick(Sender: TObject);
begin
  if FChildAppHandle <> 0 then
    SendMessage(FchildApphandle, WM_CLOSE, 0, 0);
end;

procedure TForm1.Panel1Resize(Sender: TObject);
begin
  if FChildAppHandle <> 0 then
    MoveWindow(FchildAppHandle, 0, 0, Panel1.ClientWidth, Panel1.ClientHeight, true);
end;

procedure TForm1.UMChildRegister(var msg: TUmChildRegister);
begin
  FChildAppHandle := msg.childwnd;
end;

procedure TForm1.UMChildUnRegister(var msg: TUmChildUnRegister);
begin
  if FChildAppHandle = msg.childwnd then
    FChildAppHandle := 0;
end;

procedure TForm1.FormClose(Sender: TObject; var Action: TCloseAction);
begin
  if FChildAppHandle <> 0 then
    SendMessage(FchildApphandle, WM_CLOSE, 0, 0);
end;

end.

Child app has a couple of edits, two buttons, a memo.

unit ChildApp;

interface

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

type
  TForm2 = class(TForm)
    Edit1: TEdit;
    Edit2: TEdit;
    Edit3: TEdit;
    Button1: TButton;
    Memo1: TMemo;
    Button2: TButton;
    ApplicationEvents1: TApplicationEvents;
    procedure Button1Click(Sender: TObject);
    procedure ApplicationEvents1Activate(Sender: TObject);
    procedure FormClose(Sender: TObject; var Action: TCloseAction);
    procedure FormResize(Sender: TObject);
  private
    { Private declarations }
    FMenuAppWnd: HWND;
    FParentPanelWnd: HWND;
  public
    { Public declarations }
    constructor Create(aOwner: TComponent); override;
    procedure CreateWnd; override;
    procedure DestroyWnd; override;
  end;

var
  Form2: TForm2;

implementation

{$R *.DFM}

const
  UM_CHILDREGISTER = WM_USER + 111;
  UM_CHILDUNREGISTER = WM_USER + 112;

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

procedure TForm2.ApplicationEvents1Activate(Sender: TObject);
begin
  if FMenuAppWnd <> 0 then
    SendMessage(FMenuAppWnd, WM_NCACTIVATE, 1, 0);
  memo1.lines.add('Activated');
end;

constructor TForm2.Create(aOwner: TComponent);
begin
  if ParamCount > 0 then
  begin
    FParentPanelWnd := StrToInt(ParamStr(1));
    FMenuAppWnd := Windows.GetParent(FParentPanelWnd);
  end;
  inherited;
  if FParentPanelWnd <> 0 then
  begin
    Borderstyle := bsNone;
    BorderIcons := [];
    {remove taskbar button for the child app}
    SetWindowLong(Application.Handle, GWL_EXSTYLE,
      GetWindowLong(Application.Handle, GWL_EXSTYLE)
      and not WS_EX_APPWINDOW or WS_EX_TOOLWINDOW);
  end;
end;

procedure TForm2.CreateWnd;
var
  r: Trect;
begin
  inherited;
  if FMenuAppWnd <> 0 then
  begin
    SendMessage(FMenuAppWnd, UM_CHILDREGISTER, handle, 0);
    Windows.SetPArent(handle, FParentPanelWnd);
    Windows.GetClientRect(FParentPanelWnd, r);
    SetBounds(r.left, r.top, r.right - r.left, r.bottom - r.top);
  end;
end;

procedure TForm2.DestroyWnd;
begin
  if FMenuAppWnd <> 0 then
    SendMessage(FMenuAppWnd, UM_CHILDUNREGISTER, handle, 0);
  inherited;
end;

procedure TForm2.FormClose(Sender: TObject; var Action: TCloseAction);
begin
  {Closing the main form does not fire DestroyWnd for some reason}
  if FMenuAppWnd <> 0 then
    SendMessage(FMenuAppWnd, UM_CHILDUNREGISTER, handle, 0);
end;

procedure TForm2.FormResize(Sender: TObject);
begin
  memo1.width := clientwidth - memo1.Left - 10;
  memo1.height := clientheight - memo1.Top - 10;
end;

end.

One problem I noted is that sometimes the main applications caption will loose the active look when switching between main and child despite the action taken in the childs Application.OnActivate handler.

Using Indy idHTTP to post binary and text

Problem/Question/Abstract:

Using Indy idHTTP to post binary and text

Answer:

This is a small example of using post to send data to web server. There is two different ways to do this operation.

Solve 1:

procedure TForm1.SendPostData;
const
CRLF = #13#10;
var
aStream: TMemoryStream;
Params: TMemoryStream;
S: string;
begin
aStream := TMemoryStream.create;
Params := TMemoryStream.Create;

HTTP.Request.ContentType := 'multipart/form-data;
boundary = - - - - - - - - - - - - - - - - - - - - - - - - - - - - -7
cf87224d2020a';

try
S := '-----------------------------7cf87224d2020a' + CRLF +
'Content-Disposition: form-data; name="file1"; filename="c:abc.txt"' +
CRLF +
'Content-Type: text/plain' + CRLF + CRLF +
'file one content. Contant-Type can be application/octet-stream or if
you want you can ask your OS fot the exact type
.' + CRLF +
'-----------------------------7cf87224d2020a' + CRLF +
'Content-Disposition: form-data; name="sys_return_url2"' + CRLF + CRLF +
'hello2' + CRLF +
'-----------------------------7cf87224d2020a--';

Params.Write(S[1], Length(S));

with HTTP do
begin
try
HTTP.Post('http://www.mydomain.com/postexampe.cgi', Params,
aStream);
except
on E: Exception do
showmessage('Error encountered during POST: ' + E.Message);
end;
end;
aStream.WriteBuffer(#0' ', 1);
showmessage(PChar(aStream.Memory));
except
end;
end;


Solve 2:

procedure TForm1.SendPostData;
var
aStream: TMemoryStream;
Params: TStringStream;
begin
aStream := TMemoryStream.create;
Params := TStringStream.create('');
HTTP.Request.ContentType := 'application/x-www-form-urlencoded';

try
Params.WriteString(URLEncode('sys_return_url=' + 'helo1' + '&'));
Params.WriteString(URLEncode('sys_return_url=' + 'helo2'));
with HTTP do
begin
try
HTTP.Post('http://www.mydomain.com/postexampe.cgi', Params,
aStream);
except
on E: Exception do
showmessage('Error encountered during POST: ' + E.Message);
end;
end;
aStream.WriteBuffer(#0' ', 1);
showmessage(PChar(aStream.Memory));
except
end;
end;

As you can see there is a difference in the way post stream is constructed and the ContentType. In the first example ContentType is "multipart/form-data; boundary=-----------------------------7cf87224d2020a" and this boundary is used to separate different parameters.

In the second example the ContentType is "application/x-www-form-urlencoded". In this case the paremeteras are passed in the form

ParamName=ParamValue&ParamName=ParamValue

Note that the Pramaeters in the second form must be URL encoded.

Where these two formats of post information are used?

The first one is used when you have binary data to post and the second one is when you are going to post only text fields.

Using SOAP with Delphi

Problem/Question/Abstract:

Using SOAP with Delphi

Answer:

Introduction

The growth of the Internet has recently opened a completely new world of possibilities that were extremely difficult if not impossible to achieve ten years ago. The access to information has apparently become easier and the ability to get your data anytime and from anywhere in the world is considered pretty much a normal thing these days. With an Internet connection and a browser you are immediately able to check what's the latest and greatest home computer, compare it with others, buy it and monitor its delivery until it gets to your door.

Unfortunately, as it often happens, when it comes to us developers it is not that easy to build what makes a user's life so easy. Data exchange, collaboration and cooperation are actually some of the most complex areas developers have to deal with. The devil is in the detail they say&#8230; Well, that area is definitely full of details.

Component software is targeted to make data exchange, collaboration and cooperation easier. Technologies such as Corba and COM+ provide us with the backbone to make applications talk seamlessly to each other, regardless of the language used to build them or their location. This is possible because they define a standard way to describe the services and the clients that access them know what to ask for and how to ask for it.

When it comes to the Internet, the solution that was perfect for your LAN based application doesn't work anymore. Scalability and standards become a real issue since you cannot predict the number of clients that will access your system and, worst of all, you don't know what is accessing your system. With so many standards around a standard client is the last thing you should expect.

Not too long ago a new acronym begun to spread across the web: SOAP, the Simple Object Access Protocol. This new, XML based standard promises the ultimate solution to all our problems. It promises to deliver a universally supported standard and to do it in one of the most scalable ways. Many companies such as Borland, Microsoft and IBM are moving fast in order to make this happen. Borland's Delphi 6 and Kylix have SOAP support built in. Microsoft provides the SOAP SDK 1, is working on version 2 and the future .Net platform will offer even greater support for this technology. IBM on the other side is providing a Java-based implementation.

SOAP?

However, what is SOAP? Should you use it and if so, how can you use it today?

SOAP enables you to encode complex data such as objects or procedure call parameters into an xml string (called a "SOAP Packet"). Because SOAP uses XML, it is not dependent on any particular language or operating system. SOAP packets can be stored in a database, posted in an email or a message queue or transmitted via HTTP. The most common use for SOAP is likely to be remote procedure calls implemented with SOAP transmitted over HTTP

There's nothing really complex or unique about SOAP, except maybe its simplicity.

As of today there's very little out there for a Delphi developer. Your best chance is to use what Microsoft provides at http://msdn.microsoft.com/xml with the SOAP SDKs version 1, and the beta of version 2 (currently Release Candidate 0 ). In my sample code you will find a Delphi component that wraps it and exposes some additional events.

It's worth noticing also Dave Nottage's PureSOAP. This is a simple implementation that doesn't support complex objects but comes with full source code that may be of some interest. You can find it at http://www.puresoftwaretech.com/puresoap

Luckily for us, As soon as Delphi 6 will be released, we will have much more to play with.

A practical example

In order to demonstrate a possible way to use SOAP today, I developed an example that is downloadable directly from here. The example includes the TSOAPClient component that wraps the equivalent SOAPClient COM component included in the Microsoft SOAP SDK version 2 (Release Candidate 0).

Be aware that the WSDL file definition has changed from Beta 1 to RC0. I updated the msdelphi.com source files in order to work with the latest version (Release Candidate 0). These files will not work properly with Beta 1. The files in CodeCentral are still the old ones.

The example demonstrates how to get a stock quote from a web server using SOAP.

In a future article, I will demonstrate how a similar component can be developed using Delphi, with or without COM. It's worth noticing that SOAP does not require COM at all. The only reason for which I have chosen this approach is that creating a full-blown SOAP component would have been too much overhead for this introduction to SOAP.

The instructions on how to install the example are contained in the file Readme.txt

The example

The SOAP server is a standard MTS object has only one method that given a ticker symbol returns its value. The method is defined as:

function GetQuote(const Symbol: WideString): Double

The client is a simple form that allows the user to enter a ticker symbol and displays the value that is returned by the server.



This is the sequence of events that occurs after the user presses the &#8220;Get Quote" button:

The TSOAPClient asks the web server for an XML file that describes the interface of the SOAP server.

The web server returns a standard Web Services Description Language (WSDL) file.

The client is now ready to invoke any method on the server and prepares the a GetQuote message which then sends to the server

The web sever grabs the message and passes it to the SOAPServer COM object

The SOAPServer object reads the SOAP message and invokes the GetQuote method of our test COM object

After the execution of the COM call, the SOAPServer packages a response returning either the ticker quote or an error and sends it to the client

The client finally displays the result

Demystifying SOAP &#8211; Client side

From the client perspective, SOAP method invocation is generally done using a proxy that simulates the interface of the SOAP server on the client side.

When you press the &#8220;Get Quote" button in the client application the following code is executed:

procedure TMainForm.bGetQuoteClick(Sender: TObject);
var
  quote: currency;
begin
  // Retrieves the WSDL information only the first time&#8230;
  if SOAPClient.Connected or SOAPClient.Connect then
  begin
    // Invokes the GetQuote method
    quote := SOAPClient.Client.GetQuote(eSticker.Text);
    // Displays the result
    ShowMessage(eSticker.Text + ' is worth ' + FloatToStr(quote) + '$');
  end;
end;

What is happening here is that the client is asking the server to provide a description of the interface of the StockQuote service. In SOAP this is achieved by loading a Web Services Description Language (WSDL) XML file.

In the example, this is accomplished by setting the WSDLURI property and calling the method Connect. The WSDL file that describes the StockQuote service looks like this:

<?xml version='1.0' encoding='UTF-8' ?>
<definitions  name ='StockQuote'   targetNamespace = 'http://tempuri.org/wsdl/'
xmlns:wsdlns='http://tempuri.org/wsdl/'
xmlns:typens='http://tempuri.org/type'
xmlns:soap='http://schemas.xmlsoap.org/wsdl/soap/'
xmlns:xsd='http://www.w3.org/2001/XMLSchema'
xmlns:stk='http://schemas.microsoft.com/soap-toolkit/wsdl-extension'
xmlns='http://schemas.xmlsoap.org/wsdl/'>
  <types>
    <schema targetNamespace='http://tempuri.org/type'
      xmlns='http://www.w3.org/2001/XMLSchema'
      xmlns:SOAP-ENC='http://schemas.xmlsoap.org/soap/encoding/'
      xmlns:wsdl='http://schemas.xmlsoap.org/wsdl/'
      elementFormDefault='qualified'>
    </schema>
  </types>
  <message name='StockQuote.GetQuote'>
    <part name='Symbol' type='xsd:string'/>
  </message>
  <message name='StockQuote.GetQuoteResponse'>
    <part name='Result' type='xsd:double'/>
  </message>
[..]
  <service name='StockQuote' >
    <port name='StockQuoteSoapPort' binding='wsdlns:StockQuoteSoapBinding' >
      <soap:address location='http://localhost/SOAP/StockQuote.ASP' />
    </port>
  </service>
[..]

As you can see, it says that the interface of the StockQuote SOAP service exposes one method called GetQuote. This method has string parameter called &#8220;Symbol" and returns a floating point.

Towards the end of the file, you will find another important information: the <service> tag that contains information on the destination of the SOAP messages. The URL specified in this section will be used by the client as HTTP destination of the SOAP message.

After the client has loaded and processed this file, it becomes aware of the interface of the service and knows what it can ask for and how to ask for it. The next step is to invoke the method GetQuote using the Client property of the SOAPClient.

If you are not familiar with Variant method calls and late binding, I recommend reading Binh Ly's article at http://www.techvanguards.com/com/concepts/automation.htm

After you call GetQuote, the proxy converts the method name and the parameters you invoked into a standard SOAP message and delivers it through HTTP to the destination. It is worth saying that you can implement the same behavior by building an object that implements IDispatch. You would just need to provide your own implementation of the methods GetIDsOfNames and Invoke. Another possible approach would be creating a regular Delphi class that would have a method such as:

function SOAPInvoke(aMethodName: string; someParameters: array of OleVariant):
  OleVariant;

It is also possible to send a SOAP message using other protocols than HTTP. Although it is the most commonly used, nothing stops you from using regular sockets or even an e-mail.

The server

On the server side, a listener is constantly waiting to receive SOAP requests.In this example, since we are using HTTP, the web server is the listener and the target of the SOAP messages is the ASP file StockQuote.asp. Remember how this was specified in the WSDL file the client initially received.

The SOAP Message that is received in this particular case is:

<?xml version="1.0" encoding="UTF-8" standalone="no"?>
<SOAP-ENV:Envelope SOAP-ENV:encodingStyle="http://schemas.xmlsoap.org/soap/encoding/" xmlns:SOAP-ENV="http://schemas.xmlsoap.org/soap/envelope/">
  <SOAP-ENV:Body>
    <m:GetQuote xmlns:m="http://tempuri.org/message/">
      <Symbol>BORL</Symbol>
    </m:GetQuote>
  </SOAP-ENV:Body>
</SOAP-ENV:Envelope>

As you can see, the message not only indicates the name of the method that has to be invoked in the node, but also specifies the names of the parameters that the method needs.

This instead, is part of the ASP file StockQuote.asp that illustrates what's happening on the server side:

<%@ LANGUAGE=VBScript %>
<% Response.ContentType = "text/xml"%>
<%
  [..]
  Set SoapServer = Server.CreateObject("MSSOAP.SoapServer")
  SoapServer.Init WSDLFilePath, WSMLFilePath
  SoapServer.SoapInvoke Request, Response, ""
  [..]
%>

As you can see, the SOAPServer COM object is created and the SOAP message is delivered to it in the last line by passing the Request object to the SOAPServer.SoapInvoke method. In this case, since we are using the Microsoft SDK, we can only invoke methods of COM objects.

Nothing would stop us from creating a similar component that would invoke methods of a Corba object or anything else you can imagine (an old COBOL application, a standard executable, a Java class, etc). The SOAP stub on the server will be specific to the platform you chose to adopt in-house. Microsoft obviously automated the translation of SOAP messages into COM calls. Other companies are currently doing the same for Corba and Java objects. This is the key behind the SOAP idea: you are completely free to use any technology you want to develop your in-house application . Whenever you need to expose some of these services to the outside world, you just put the appropriate SOAP translator on top of it.

The following diagram illustrates this:



Now, the last part of the puzzle is the response the server sends back to the client. Successful or failed responses must follow a standard too.

This is how a successful result would look in our previous example:

<?xml version="1.0" encoding="UTF-8" standalone="no"?>
<SOAP-ENV:Envelope SOAP-ENV:encodingStyle="http://schemas.xmlsoap.org/soap/encoding/" xmlns:SOAP-ENV="http://schemas.xmlsoap.org/soap/envelope/">
  <SOAP-ENV:Body>
    <m:GetQuoteResponse xmlns:m="http://tempuri.org/message/">
      <Result>100</Result>
    </m:GetQuoteResponse>
  </SOAP-ENV:Body>
</SOAP-ENV:Envelope>

In the event of any error instead (such an exception in the COM object) the standard format of a SOAP error message would look like this:

<?xml version="1.0" encoding="UTF-8" standalone="no"?>
  <SOAP-ENV:Envelope SOAP-ENV:encodingStyle="http://schemas.xmlsoap.org/soap/encoding/" xmlns:SOAP-ENV="http://schemas.xmlsoap.org/soap/envelope/">
    <SOAP-ENV:Body>
      <SOAP-ENV:Fault>
        <faultcode>SOAP-ENV:Server</faultcode>
<faultstring>WSDLOperation: Executing method GetQuote failed</faultstring>
<faultactor>http://tempuri.org/action/StockQuote.GetQuote</faultactor>
<detail>
[..]
<mserror:description>A symbol must be specified</mserror:description>
[..]
        </detail>
     </SOAP-ENV:Fault>
   </SOAP-ENV:Body>
</SOAP-ENV:Envelope>

The elements faultcode, faultstring and detail are accessible through the TSOAPClient. They are the standard way for SOAP to signal an error. The detail node has been extended in this case to provide additional error information. The subnodes msXXXX provide information that is usually available when trapping COM exceptions. You are free to put as much information as you need to in the detail tag and still be compliant to the SOAP standard.

You can find a sample of each of these files (the request, the response and the error) in the Web directory included in the sample code.

Pros and cons

As any technology, SOAP comes with its sets of pros and cons.

Simplicity and the fact that is becoming an industry accepted standard are probably the most important two pros for SOAP but another critical element plays a major role when developing internet application: scalability. SOAP is commonly used on top of HTTP although almost any other transport mechanisms can be used. When it's used like this and the stateless HTTP request/response model is maintained, SOAP provides a higher scalability than any other protocol (COM's DCE-RPC, Corba's IIOP or Java's JRMP). There are multiple reasons behind this statement but the most important is the fact that HTTP is stateless in nature.

You can read more about this in the book "Understanding SOAP" mentioned at the end of this article. I'd also like to mention that using SOAP in a browser-based application could lead to unprecedented results in terms of ease of coding and functionality. For instance, instead of building URL strings such as http://myserver/ GetQuote?Symbol=BORL, more natural and object oriented calls such as StockServer.GetQuote('BORL') can now be easily performed.

On the server side the result is similar: the need to access the Form or QueryString properties of the Request object becomes superfluous and you can let the SOAP listeners do the job for you. You only need to code your COM/Corba objects and the activation is taken care of by SOAP .

Where SOAP falls short today is in security and data compression. XML is a textual representation of information and if the network you are running on is not secure, packets are extremely easy to sniff and then read with an application as simple as Notepad.

XML and the SOAP convention for packaging messages add a lot of extra overhead.

The example above demonstrated how costly sending a simple floating point number became (357 bytes). This is obviously an extreme example and sending such a small packet wouldn't really affect performances that much.

Conclusion

SOAP won't replace technologies like COM or Corba for in-house development for a long time, if ever. These technologies and the tools built on top of them deliver wider functionality than what SOAP offers today. Application servers such as Borland AppServer or Microsoft Transaction Server allow object pooling, just in time activation and much more. SOAP is mostly meant as an Internet lingua franca . Its stateless nature perfectly fits the Internet. LAN based application usually don't suffer of bandwidth limits, reliable communication or other problems as much as a wide area connection does.

Its simplicity and the fact that is quickly becoming a standard are key factors.

SOAP is the perfect candidate for those areas in which a system needs to exchange data or to use services provided by third parties. SOAP-enabled web services will lead to a more inter operable and collaborative Internet, which in turn may make development easier, less bug-prone and ultimately standardized.

Resources

If you want to know more about SOAP, the following resources may be very helpful:

The SOAP specification (version 1.1) is located at http://www.w3.org/TR/2000/NOTE-SOAP-20000508/

The Microsoft SOAP SDKs and other interesting articles can be found at http://www.msdn.microsoft.com/xml/default.asp

The Java based IBM Web Services Toolkit runtime environment can be found at http://www.alphaworks.ibm.com/tech/webs ervicestoolkit

The book &#8220;Understanding SOAP" written by Scrinber and Stiver and published by Sams is a great and detailed source of information on this topic.

Special thanks

I want to express my most sincere gratitude to John Beyer, Renzo Barduagni, Dave Nottage and Mark Chambers for helping me in reviewing this article and in providing excellent feedback.

MySQL and Delphi

Problem/Question/Abstract:

I've always wanted a better way to interface with my favorite (I would argue the best) database and Delphi - and after much searching I bring you an excellent and sensible way to do it.

Answer:

This is based on the Open source MySQL connector "Objects".

To start with you'll need Delphi of course - I believe this will work with 5 pro and higher although I've only used it with 7. Also I assume you have or have access to a properly configured and working MySQL server. If you don't there are plenty of excellent tutorials available.  I'll also assume you have moderate knowledge of Delphi and can navigate, add buttons and all that basic stuff.

First also need a copy of the actual connector objects. Which can be found at:
http://sourceforge.net/projects/directsql/
http://prdownloads.sourceforge.net/directsql/DirectMysqlObjects.zip?download

If your interested there is also a demo which shows off its capabilities which can be found:
http://prdownloads.sourceforge.net/directsql/DemoObjectsWin.zip?download


To use the MySQL objects - simply unzip the contents of the zip you just downloaded into {Delphi}/lib/ folder.

Now to use them all you need to do is add a couple of things to the uses of your interface:
uMySqlVio, uMysqlCT, uMysqlClient, uMysqlHelpers

Its as easy as that!

I suggest trying to compile your application after adding the "uses" for the first time to make sure Delphi can find them okay. Now I'll run through a quick tutorial on how to use the library to get you started.


Connection Example

First add "MySQLClient: TMySQLClient;" to your main form's public. This will make the actual client that you'll do all the work with.

Also add "MySQLResult: TMysqlResult;" to your main form's public as well. This will create an 'instance' of the MySQL result type for "catching" queries and other stuff that you'll want a result from.

Great, so now the naming is done we'll add some code to actually connect to your database. Add this code to your form's OnCreate procedure (double click on your form):
MySQLClient := TMySQLClient.Create;

Next add the following to the OnDestroy procedure:
MySQLClient.Free;
if MySQLResult <> nil then
MySQLResult.Free;

Okay, now make a new button on your form and give it the caption of "Connect". To get it to actually connect first we'll need to define a few things like the host and user and stuff. You can either "hard code" the values  (or read from your own config files / registry or whatever) or use edit boxes and such. Since this is a simple tutorial I'll leave the reading in values from cfg files up to you and use the easiest which is just a few edit boxes on your form.

Add 5 edit boxes to your form and 3 check boxes. For quick reference label (leave the names the same)  them
Edit1 - Host
Edit2 - Port
Edit3 - User
Edit4 - Password
Edit5 - Db
Check1 - Use named pipes
Check2 - Use SSL
Check3 - Compress

Now add the following code to your OnClick procedure for the connect button you added earlier:
MySQLClient.Host := Edit1.Text;
MySQLClient.port := StrToInt(Edit2.text);
MySQLClient.user := Edit3.text;
MySQLClient.password := Edit4.text;
MySQLClient.Db := Edit5.Text;
MySQLClient.UseNamedPipe := CheckBox1.Checked;
MySQLClient.UseSSL := CheckBox2.Checked;
MySQLClient.Compress := CheckBox3.Checked;

if MySQLClient.Connect then ShowMessage('connected ok!')
else ShowMessage('Somthing went wrong!");

Or instead of the big chunk of text you can use:
if FMysql.Connect(Edit1.Text, Edit3.Text, Edit4.Text, 'db', StrToInt(Edit2.text), '', false, 0) then ShowMessage('connected ok!')
else ShowMessage('Somthing went wrong!");

But its much easier for the second to go wrong, and harder to figure out what went wrong.

Now run your program, fill in the edit boxes and see if it works!

I'm assuming it did - so lets move along, almost there.

Now we come to actually making the query - which is just like a query in any other language or interface. When you make a new query you need to assign the result to MySQLResult and use MySQLClient to run the query. There are 3 parameters, the query, if you want it to save the result, a boolean to store if it executed ok:
MySQLResult := MySQLClient.Query('SELECT * FROM users WHERE username=''username'' and password=''pass''', True, OK);

(just a quick note for the inexperienced - often you'll need to use a ' in a sql query (ie - select * from user where name = 'joe bloggs') - which also signifies to Delphi that the string you are making has ended and will make it "freak out"(TM) - so there thankfully is an easy way around it, which is simply to wherever you need a ' in a string put two together - so select * from user where name = 'joe bloggs' would be 'select * from user where name = ''joe bloggs''')

Now that you have the result of the query there's all sorts of things you can do with it. Have a go at browsing through the list of properties and procedures available. But to get you started - to get a field by using its name:
MySQLResult.FieldValueByName('username');

Hint for a login type script -
if (MySQLResult.FieldValueByName('username') <> 'dummy_username') or (MySQLResult.FieldValueByName('password') <> 'dummy_pass') then ...


So that's it - I hope that all helped - if you have any problems or questions or feedback feel free to e-mail me - ipvariance@hotmail.com.

Special thanks to "Dumbass" who wrote the page where I first found the open source MySQL connector libraries.

Outlook from Delphi

Problem/Question/Abstract:

Outlook from Delphi

Answer:

Automating Microsoft Outlook

Microsoft Office 97 appears to be five well-integrated applications. It is, in fact, much more. Office 97 was created using Microsoft's Component Object Model (COM). The Office applications are composed of a series of COM servers you can access from your Delphi applications using Automation (formerly know as OLE Automation). Beginning with Outlook 98, this article series will explore the object model of each of the office applications - and how you can use them from Delphi.

The Outlook object model consists of objects and collections of objects (see Figure 1). The top-level object in Outlook 98 is the Application object. The Application object is the root of the object tree and provides access to all the other Outlook objects. The Application object is unique in that it's the only object you can gain access to by calling CreateOleObject from a Delphi (or any other) application. Next comes the NameSpace object, which provides access to a data source. The only available data source in Outlook 98 is the MAPI message store.


Figure 1: The Outlook object model.

The MAPIFolders collection is just that - a collection of MAPI folders. You can think of collections as arrays of objects, somewhat like a Delphi TList. However, collection objects can be referenced by name or number. The MAPIFolder object in Figure 1 represents one of the folders in the MAPIFolders collection. Each MAPIFolder contains a Folders collection, and each of these contains an Items collection that contains the items appropriate to that folder. For example, the Contacts folder contains contact items.

Figure 2 shows the main form of a Delphi project that displays the MAPIFolders collection, the Folders collection of the MAPI Personal folder, and the Items in the Contacts folder. Listing One  displays the code from the Open Outlook button's OnClick event handler.


Figure 2: The MAPI Folders collection displayed in a Delphi form.

The code in Listing One begins by declaring four Variant variables for use as references to various Outlook objects. The call to CreateOleObject loads the Outlook server and returns a reference to the Application object. The parameter passed to CreateOleObject, Outlook.Application, is the class name Outlook registers itself as when it's installed. Using the Application object you can get a reference to any other Outlook object.

Calling the Application object's GetNameSpace method returns a reference to the NameSpace passed as a parameter. Using the MAPI NameSpace reference variable, Mapi, the code loops through the MAPIFolders collection and adds the name of each folder to the MapiList listbox. As with all objects in object-oriented programming, Outlook objects have properties, methods, and events. The Count property of the Folders collection is used to limit the number of times the for loop executes. All collections have a Count property to provide the number of objects in the collection. Each Folder in the MAPIFolders collection also has a Name property.

As you can see in Figure 2, the MAPIFolders collection contains two folders, Microsoft Mail Shared Folders and Personal Folders. The following statement gets a reference to the Personal Folders collection from the MAPIFolders collection. While the for loop that displayed the names of the MAPI Folders accessed the MAPIFolders collection by number, the statement:

Personal := Mapi.Folders('Personal Folders');

indexes the collection by name. The next for loop uses the reference to the Personal Folder to display the names of all the folders in its Folders collection in the second listbox in Figure 2. The code then gets a reference to the Contacts folder and uses it to loop through the Contacts folder's Items collection. One of the properties of a Contact item is FullName; this property is added to the third listbox to display the names of the contacts.

Clearly, the secret to working with Outlook 98 from your Delphi applications is understanding the Outlook object hierarchy and the properties, methods, and events of each object. Outlook 97 includes a Help file, VBAOUTL.HLP, that contains this information; however, I have been unable to find it on the Outlook 98 CD. Fortunately, very little has changed in Outlook 98. (Outlook 2000 is a different story, and will be the topic of a future article.)

Working with Contacts

Listing Two  shows the OnClick event handler from the LoadTbl project that accompanies this article. This code demonstrates how to search the Outlook Contacts folder for the records you wish to select and copy them to a database table.

As in the example shown in Listing One, this one begins by getting the Application object and the MAPI NameSpace object. Next, a reference is obtained using the statement:

ContactItems := Mapi.Folders('Personal Folders').
Folders('Contacts').Items;

This statement demonstrates how you can chain objects together using dot notation to get a reference to a low-level object without having to get individual references to each of the higher level objects. In this case, five levels of intervening objects are specified to get to the Items object of the Contacts folder. These objects are:

The MAPI NameSpace object
The Folders collection
The Personal Folders object
The Folders collection
The Contacts object

You can use this notation to get a reference to any Outlook object in a single statement. The next new feature of this method is the call to the Find method of the ContactItems collection. Almost all collection objects have a Find method you can use to locate a particular item in the collection using one or more of its properties. In this example, the statement:

CurrentContact := ContactItems.Find(' [CompanyName] = ' +
  QuotedStr('Borland International'));

finds the first contact item where the value of the CompanyName property is equal to Borland International. If no matching item is found, the Variant CurrentContact will be empty. The while loop inserts a new record into the database table, and assigns each of the Contact item's properties to the corresponding field in the table. The while loop continues until CurrentContact is empty, indicating that no more items matching the search criteria can be found. At the end of the while loop, the call to FindNext finds the next matching record, if there is one. If no record is found, CurrentContact is set to empty and the loop terminates.

Creating new Contact folders and records is just as easy. Suppose you want to copy all your Contact records for Borland employees into a new folder. The code in Listing Three  from the NewFolder sample project will do the job.

This method begins by getting the Application, MAPI NameSpace, and Contacts folder's Items object. Next, it uses a for loop to scan the Folders collection looking for the Borland Contacts folder. If the folder is found, its number is assigned to the ToRemove variable. The Borland Contacts folder is deleted by calling the Folders collection's Remove method and passing the ToRemove variable as the parameter.

Next, a call to the Folders collection's Add method creates the Borland Contacts folder. Add takes two parameters. The first is the name of the folder to be created. The second parameter is the folder type and can be olFolderCalendar, olFolderContacts, olFolderInbox, olFolderJournal, olFolderNotes, or olFolderTasks. To find the values of these and any other constants you need, search the VBAOUTL.HLP file for Microsoft Outlook Constants. The next statement gets a reference to the new Borland Contacts folder and stores it in the BorlandContacts variable.

A call to the Contacts folder's Items collection's Find method locates the first record for a Borland employee. The while loop is used to iterate through all the Borland employees in the Contacts folder. At the top of the loop a new record is added to the Borland Contacts folder by calling the folder's Items collection's Add method.

Add takes no parameters; it simply inserts a new empty record and returns a reference to the new record, which is saved in the NewContact variable. The statements that follow assign values from the existing record to the new one. Finally, the new record's Save method is called. This is a critical step. If you don't call Save, no errors will be generated - but there will be no new records in the folder. When the while loop terminates Outlook is closed by assigning the constant Unassigned to the OutlookApp variable.

Other Outlook Objects

The Folders collection of the Personal Folder object contains the following folders:

Deleted Items
Inbox
Outbox
Sent Items
Calendar
Contacts
Journal
Notes
Tasks
Drafts

You can work with the Items collection of any of these folders using the same code shown for working with Contacts. Only the properties of the items are different. Listing Four  shows a method that copies to a Paradox table all appointments that are all-day events and whose start date is greater than 4/27/99. This example copies the Start, End, Subject and BusyStatus properties to the table. Note that this example uses a more sophisticated find expression than previous examples. Find supports the >, <, >=, <=, = and <> operators, as well as the logical operators and, or, and not, which allows you to construct complex search expressions.

Conclusion

Delphi applications can easily act as Automation clients, allowing your applications to interact with the Microsoft Office Suite applications in any way you wish. Using Outlook you can extract contact information to update a central database, add new contacts derived from other sources, create new folders, and add items of any type. One of Outlook's limitations is its lack of a powerful reporting tool. With a Delphi application you can provide much more powerful reporting capabilities for Outlook data. With a basic understanding of the Outlook object model and a copy of the VBAOUTL.HLP help file you are well on your way.


Begin Listing One - Displaying Outlook objects
procedure TForm1.OpenBtnClick(Sender: TObject);
var
  OutlookApp,
    Mapi,
    Contacts,
    Personal: Variant;
  I: Integer;
begin
  { Get the Outlook Application object. }
  OutlookApp := CreateOleObject('Outlook.Application');
  { Get the MAPI NameSpace object. }
  Mapi := OutlookApp.GetNameSpace('MAPI');
  { Loop through the MAPI Folders collection and add the
   Name of each folder to the listbox. }
  for I := 1 to Mapi.Folders.Count do
    MapiList.Items.Add(Mapi.Folders(I).Name);
  { Get the Personal folder from the MAPI folders
   collection. }
  Personal := Mapi.Folders('Personal Folders');
  { Loop through the Personal Folders Collection and add
   the name of each folder to the listbox. }
  for I := 1 to Personal.Folders.Count do
    PersonalList.Items.Add(Personal.Folders(I).Name);
  { Get the Contacts folder from the Personal Folders
   collection. }
  Contacts := Personal.Folders('Contacts');
  { Loop through the Contacts folder's Items collection
   and add the FullName property of each Item
   to the listbox. }
  for I := 1 to Contacts.Items.Count do
    ContactsList.Items.Add(Contacts.Items(I).FullName);
  { Close Outlook. }
  OutlookApp := Unassigned;
end;
End Listing One

Begin Listing Two - Searching for contacts
procedure TLoadTableForm.LoadBtnClick(Sender: TObject);
var
  OutlookApp,
    Mapi,
    ContactItems,
    CurrentContact: Variant;
begin
  { Get the Outlook Application object. }
  OutlookApp := CreateOleObject('Outlook.Application');
  { Get the MAPI NameSpace object. }
  Mapi := OutlookApp.GetNameSpace('MAPI');
  { Get the Items collection from the Contacts folder. If
   you don't do this, FindNext will not work. }
  ContactItems := Mapi.Folders('Personal Folders').
    Folders('Contacts').Items;
  { Load Contacts into table. }
  with ContactTable do
  begin
    EmptyTable;
    Open;
    DisableControls;
    CurrentContact :=
      ContactItems.Find('[CompanyName] = ' +
      QuotedStr('Borland International'));
    while not VarIsEmpty(CurrentContact) do
    begin
      Insert;
      FieldByName('EntryId').AsString :=
        CurrentContact.EntryId;
      FieldByName('LastName').AsString :=
        CurrentContact.LastName;
      FieldByName('FirstName').AsString :=
        CurrentContact.FirstName;
      FieldByName('CompanyName').AsString :=
        CurrentContact.CompanyName;
      FieldByName('BusAddrStreet').AsString :=
        CurrentContact.BusinessAddressStreet;
      FieldByName('BusAddrPOBox').AsString :=
        CurrentContact.BusinessAddressPostOfficeBox;
      FieldByName('BusAddrCity').AsString :=
        CurrentContact.BusinessAddressCity;
      FieldByName('BusAddrState').AsString :=
        CurrentContact.BusinessAddressState;
      FieldByName('BusAddrPostalCode').AsString :=
        CurrentContact.BusinessAddressPostalCode;
      FieldByName('BusinessPhone').AsString :=
        CurrentContact.BusinessTelephoneNumber;
      Post;
      CurrentContact := ContactItems.FindNext;
    end; // while
    EnableControls;
  end; // with
  { Close Outlook. }
  OutlookApp := Unassigned;
end;
End Listing Two

Begin Listing Three - Creating a Contacts folder and new contacts
procedure TCreateFolderFrom.CreateBtnClick(Sender: TObject);
const
  olFolderContacts = 10;
  olContactItem = 2;
var
  OutlookApp,
    Mapi,
    NewContact,
    BorlandContacts,
    ContactItems,
    CurrentContact: Variant;
  I,
    ToRemove: Integer;
begin
  { Get the Outlook Application object. }
  OutlookApp := CreateOleObject('Outlook.Application');
  { Get the MAPI NameSpace object. }
  Mapi := OutlookApp.GetNameSpace('MAPI');
  { Get the Items collection from the Contacts folder. If
   you don't do this,FindNext will not work. }
  ContactItems := Mapi.Folders('Personal Folders').
    Folders('Contacts').Items;
  { Remove the test folder. }
  ToRemove := 0;
  for I := 1 to Mapi.Folders('Personal Folders').
    Folders.Count do
    if Mapi.Folders('Personal Folders').Folders(I).Name =
      'Borland Contacts' then
    begin
      ToRemove := I;
      Break;
    end; // if
  if ToRemove <> 0 then
    Mapi.Folders('Personal Folders').
      Folders.Remove(ToRemove);
  { Create a new folder. }
  Mapi.Folders('Personal Folders').
    Folders.Add('Borland Contacts', olFolderContacts);
  BorlandContacts := Mapi.Folders('Personal Folders').
    Folders('Borland Contacts');
  { Load Contacts into new folder. }
  CurrentContact := ContactItems.Find('[CompanyName] = ' +
    QuotedStr('Borland International'));
  while not VarIsEmpty(CurrentContact) do
  begin
    { Add a new item to the folder. }
    NewContact := BorlandContacts.Items.Add;
    { Assign values to the fields in the item record. }
    NewContact.FullName := 'John Doe';
    NewContact.LastName := CurrentContact.LastName;
    NewContact.FirstName := CurrentContact.FirstName;
    NewContact.CompanyName := CurrentContact.CompanyName;
    NewContact.BusinessAddressStreet :=
      CurrentContact.BusinessAddressStreet;
    NewContact.BusinessAddressPostOfficeBox :=
      CurrentContact.BusinessAddressPostOfficeBox;
    NewContact.BusinessAddressCity :=
      CurrentContact.BusinessAddressCity;
    NewContact.BusinessAddressState :=
      CurrentContact.BusinessAddressState;
    NewContact.BusinessAddressPostalCode :=
      CurrentContact.BusinessAddressPostalCode;
    NewContact.BusinessTelephoneNumber :=
      CurrentContact.BusinessTelephoneNumber;
    { Save the new record. }
    NewContact.Save;
    { Find the next record in the Contacts folder. }
    CurrentContact := ContactItems.FindNext;
  end; // while
  { Close Outlook. }
  OutlookApp := Unassigned;
end;
End Listing Three

Begin Listing Four - Reading Calendar folder
procedure TLoadTableForm.LoadBtnClick(Sender: TObject);
var
  OutlookApp,
    Mapi,
    ApptItems,
    CurrentAppt: Variant;
begin
  { Get the Outlook Application object. }
  OutlookApp := CreateOleObject('Outlook.Application');
  { Get the MAPI NameSpace object. }
  Mapi := OutlookApp.GetNameSpace('MAPI');
  { Get the Items collection from the Contacts folder. If
   you don't do this, FindNext will not work. }
  ApptItems := Mapi.Folders('Personal Folders').
    Folders('Calendar').Items;
  { Load Contacts into table. }
  with ApptTable do
  begin
    EmptyTable;
    Open;
    DisableControls;
    CurrentAppt := ApptItems.Find('[Start] > ' +
      '"4/27/99" and [AllDayEvent] = True');
    while not VarIsEmpty(CurrentAppt) do
    begin
      Insert;
      FieldByName('Start').AsDateTime := CurrentAppt.Start;
      FieldByName('Subject').AsString :=
        CurrentAppt.Subject;
      FieldByName('End').AsDateTime := CurrentAppt.End;
      FieldByName('Busy').AsBoolean :=
        CurrentAppt.BusyStatus;
      Post;
      CurrentAppt := ApptItems.FindNext;
    end; // while
    EnableControls;
  end; // with
  { Close Outlook. }
  OutlookApp := Unassigned;
end;
End Listing Four


Component Download: outlook_from_delphi.zip

How to create a transparent TPanel

Problem/Question/Abstract:

How to create a transparent TPanel

Answer:

Solve 1:

Particularly note the SetParent bit. It works even with movement. It should even work in Delphi 1, as it doesn't use the Win32 non-rectangular-window method for creating transparency. The code is simple so can be easily retro-fitted to any control that you wished were transparent. I put this together in ten minutes, so it needs proper testing to make sure it doesn't cause any problems, but here it is. Create one on a form, and drag it about over some edits, combo boxes etc. (and TImages and you'll get major flicker).

type
  TTransparentPanel = class(TPanel)
  private
    procedure SetParent(AParent: TWinControl); override;
    procedure WMEraseBkGnd(var Message: TWMEraseBkGnd); message WM_EraseBkGnd;
  protected
    procedure CreateParams(var Params: TCreateParams); override;
    procedure Paint; override;
  public
    constructor Create(AOwner: TComponent); override;
    procedure Invalidate; override;
  end;

constructor TTransparentPanel.Create(AOwner: TComponent);
begin
  inherited Create(AOwner);
  ControlStyle := ControlStyle - [csOpaque];
end;

procedure TTransparentPanel.CreateParams(var Params: TCreateParams);
begin
  inherited CreateParams(Params);
  Params.ExStyle := Params.ExStyle or WS_EX_TRANSPARENT;
end;

procedure TTransparentPanel.Paint;
begin
  Canvas.Brush.Style := bsClear;
  Canvas.Rectangle(0, 0, Width, Height);
  Canvas.TextOut(Width div 2, Height div 2, 'Transparent');
end;

procedure TTransparentPanel.WMEraseBkGnd(var Message: TWMEraseBkGnd);
begin
  {Do Nothing}
  Message.Result := 1;
end;

procedure TTransparentPanel.SetParent(AParent: TWinControl);
begin
  inherited SetParent(AParent);
  {The trick needed to make it all work! I don't know if changing the parent's
        style is a good idea, but it only removes the WS_CLIPCHILDREN style which shouldn't    cause any problems.}
  if Parent <> nil then
    SetWindowLong(Parent.Handle, GWL_STYLE, GetWindowLong
      (Parent.Handle, GWL_STYLE) and not WS_ClipChildren);
end;

procedure TTransparentPanel.Invalidate;
var
  Rect: TRect;
begin
  Rect := BoundsRect;
  if (Parent <> nil) and Parent.HandleAllocated then
    InvalidateRect(Parent.Handle, @Rect, True)
  else
    inherited Invalidate;
end;


Solve 2:

unit TransparentPanel;

interface

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

type
  TTransparentPanel = class(TPanel)
  private
    { Private declarations }
    FBackground: TBitmap;
    procedure WMEraseBkGnd(var msg: TWMEraseBkGnd); message WM_ERASEBKGND;
  protected
    { Protected declarations }
    procedure CaptureBackground;
    procedure Paint; override;
  public
    { Public declarations }
    procedure SetBounds(ALeft, ATop, AWidth, AHeight: Integer); override;
    property Canvas;
    constructor Create(aOwner: TComponent); override;
    destructor Destroy; override;
  published
    { Published declarations }
  end;

procedure Register;

implementation

procedure Register;
begin
  RegisterComponents('PBGoodies', [TTransparentPanel]);
end;

procedure TTransparentPanel.CaptureBackground;
var
  canvas: TCanvas;
  dc: HDC;
  sourcerect: TRect;
begin
  FBackground := TBitmap.Create;
  with Fbackground do
  begin
    width := clientwidth;
    height := clientheight;
  end;
  sourcerect.TopLeft := ClientToScreen(clientrect.TopLeft);
  sourcerect.BottomRight := ClientToScreen(clientrect.BottomRight);
  dc := CreateDC('DISPLAY', nil, nil, nil);
  try
    canvas := TCanvas.Create;
    try
      canvas.handle := dc;
      Fbackground.Canvas.CopyRect(clientrect, canvas, sourcerect);
    finally
      canvas.handle := 0;
      canvas.free;
    end;
  finally
    DeleteDC(dc);
  end;
end;

constructor TTransparentPanel.Create(aOwner: TComponent);
begin
  inherited;
  ControlStyle := controlStyle - [csSetCaption];
end;

destructor TTransparentPanel.Destroy;
begin
  FBackground.free;
  inherited;
end;

procedure TTransparentPanel.Paint;
begin
  if csDesigning in ComponentState then
    inherited
      {would need to draw frame and optional caption here do not call
    inherited, the control fills its client area if you do}
end;

procedure TTransparentPanel.SetBounds(ALeft, ATop, AWidth, AHeight: Integer);
begin
  if Visible and HandleAllocated and not (csDesigning in ComponentState) then
  begin
    Fbackground.Free;
    Fbackground := nil;
    Hide;
    inherited;
    Parent.Update;
    Show;
  end
  else
    inherited;
end;

procedure TTransparentPanel.WMEraseBkGnd(var msg: TWMEraseBkGnd);
var
  canvas: TCanvas;
begin
  if csDesigning in ComponentState then
    inherited
  else
  begin
    if not Assigned(FBackground) then
      Capturebackground;
    canvas := TCanvas.create;
    try
      canvas.handle := msg.DC;
      canvas.draw(0, 0, FBackground);
    finally
      canvas.handle := 0;
      canvas.free;
    end;
    msg.result := 1;
  end;
end;

end.


Solve 3:

This panel will be transparent only at runtime.

{ ... }
type
  TMyPopUpTransPanel = class(TPanel)
  protected
    procedure CMHitTest(var Message: TCMHitTest); message CM_HITTEST;
    procedure WndProc(var Message: TMessage); override;
    procedure CreateParams(var Params: TCreateParams); override;
    procedure Paint; override;
  end;
  { ... }

procedure TMyPopUpTransPanel.CMHitTest(var Message: TCMHitTest);
begin
  Message.Result := Windows.HTNOWHERE;
end;

procedure TMyPopUpTransPanel.WndProc(var Message: TMessage);
var
  XControl: TControl;
  XPos: TPoint;
begin
  if not (csDesigning in ComponentState) and ((Message.Msg >= WM_MOUSEFIRST)
    and (Message.Msg <= WM_MOUSELAST)) then
  begin
    XPos := ClientToScreen(POINT(TWMMouse(Message).XPos, TWMMouse(Message).YPos));
    XControl := Parent.ControlAtPos(POINT(TWMMouse(Message).XPos +
      Left, TWMMouse(Message).YPos + Top), true, true);
    if Assigned(XControl) and (XControl is TWinControl) then
    begin
      XPos := TWinControl(XControl).ScreenToClient(XPos);
      TWMMouse(Message).XPos := XPos.X;
      TWMMouse(Message).YPos := XPos.Y;
      PostMessage(TWinControl(XControl).Handle, Message.Msg,
                         Message.WParam, Message.LParam);
    end
    else
    begin
      XPos := Parent.ScreenToClient(XPos);
      TWMMouse(Message).XPos := XPos.X;
      TWMMouse(Message).YPos := XPos.Y;
      PostMessage(Parent.Handle, Message.Msg, Message.WParam, Message.LParam);
    end;
    Message.Result := 0;
  end
  else
    inherited WndProc(Message);
end;

procedure TMyPopUpTransPanel.CreateParams(var Params: TCreateParams);
begin
  inherited CreateParams(Params);
  if not (csDesigning in ComponentState) then
    Params.ExStyle := Params.ExStyle or WS_EX_TRANSPARENT;
end;

procedure TMyPopUpTransPanel.Paint;
var
  XBitMap: TBitMap;
  XOldDC: HDC;
  XRect: TRect;
begin
  if (csDesigning in ComponentState) then
    inherited Paint
  else
  begin
    XRect := ClientRect;
    XOldDC := Canvas.Handle;
    XBitMap := TBitMap.Create;
    try
      XBitMap.Height := Height;
      XBitMap.Width := Width;
      Canvas.Handle := XBitMap.Canvas.Handle;
      inherited Paint;
      RedrawWindow(Parent.Handle, @XRect, 0, RDW_ERASE or RDW_INVALIDATE or
        RDW_NOCHILDREN or RDW_UPDATENOW);
    finally
      Canvas.Handle := XOldDC;
      Canvas.BrushCopy(XRect, XBitMap, XRect, Color);
      XBitMap.Free;
    end;
  end;
end;