Author: matt

To create a transparent splashscreen, like for example the splash displayed when adobe acrobat reader starts, do the following:

1. Create the a new form
2. Set the Border Style to bsNone
3. Set the Position to poScreenCenter
4. Overide the create constuctor and add the line Brush.Style = bsClear
5. Override the createparams method and add the line
   Params.ExStyle := Params.ExStyle + WS_EX_TRANSPARENT +WS_EX_TOPMOST;
   after the call to inherited
6. Add an image componet to the form and load your transparent image into it. I use PNG’s rather than bitmaps with a transparent color.  PNGImage (a PNG wrapper for TPicture is available at sourceforge).
7. Set the image and form’s Autosize to true.
8. Slap on a timer to close the form after a couple of seconds.

I can’t remember where I found this code, if I come across the site again, I’ll put a credit to it in this article. 
When trying to load / save PNG Images from a stream using GDI+ routines to load and save from IStream, there were problems, it turns out with the date/time information returned in the Istream Stats.
The following unit provides a Fixed Stream Adapter that correctly returns the stat information.

unit FixedStreamAdapter;
interface
uses
  classes, sysUtils, activex, windows;
type
  TFixedStreamAdapter = class(TStreamAdapter)
public
function Stat(out statstg: TStatStg;
      grfStatFlag: Longint): HResult; override; stdcall;
end;
implementation

function DateTimeToFileTime(DateTime: TDateTime): TFileTime;
// copied from JclDateTime.pas
const
  FileTimeBase      = -109205.0;
  FileTimeStep: Extended = 24.0 * 60.0 * 60.0 * 1000.0 * 1000.0 *10.0; // 100 nSek per Day
var
  E: Extended;
  F64: Int64;
begin
  E := (DateTime – FileTimeBase) * FileTimeStep;
  F64 := Round(E);
  Result := TFileTime(F64);
end;
function TFixedStreamAdapter.Stat(out statstg: TStatStg; grfStatFlag: Longint): HResult;
Begin
  Result := S_OK;
try
if (@statstg <> nil) then
with statstg do
begin
        FillChar(statstg, sizeof(statstg), 0);
        dwType := STGTY_STREAM;
        cbSize := Stream.size;
        mTime := DateTimeToFileTime(now);
        cTime := DateTimeToFileTime(now);
        aTime := DateTimeToFileTime(now);
        grfLocksSupported := LOCK_WRITE;
end;
except
    Result := E_UNEXPECTED;
end;
end;
end.

When an interface returns a delegated object that causes an error, the factory or autofactory has not been assigned.

The default implementation of SafeCallException refers to FFactory which, in this case is NIL. Override SafeCallException to fix. In COMOBJ.pas, the SafeCallException procedure refers to FFactory.ErrorID, FFactory.ProgID, etc in the call to HandleSafeCallException. FFactory is nil, causing a AV in the error handler, which causes a Catastrophic Error to be raise.

If you descend your objects from a TFudgedAutoObject which simply overrides the SafeCallException message, you can solve the problem.

function TFudgedAutoObject.SafeCallException(ExceptObject: TObject;ExceptAddr: Pointer): HRESULT;
var
  E: TObject;
  CreateError: ICreateErrorInfo;
  ErrorInfo: IErrorInfo;
begin
  Result := E_UNEXPECTED;
  E := ExceptObject;
if Succeeded(CreateErrorInfo(CreateError)) then
begin
    CreateError.SetGUID(Class_EPO);
    CreateError.SetSource(PWideChar(‘MY ERROR SOURCE’));
    CreateError.SetHelpFile(PWideChar(‘MY HELPFILE NAME.HLP’));
if E is Exception then
begin
      CreateError.SetDescription(PWideChar(WideString(Exception(E).Message)));
      CreateError.SetHelpContext(Exception(E).HelpContext);
if (E is EOleSysError) and (EOleSysError(E).ErrorCode < 0) then
        Result := EOleSysError(E).ErrorCode;
end;
if CreateError.QueryInterface(IErrorInfo, ErrorInfo) = S_OK then
    SetErrorInfo(0, ErrorInfo);
end;
end;

Comments

Very cool tip!
Written by Guest on 2005-06-08 15:53:46

I’ve been stuck on this problem for a bit. Hopefully this will fix it. Thank you! 
In D7 I had to 
1. Add ActiveX to my uses clause 
2. Define a string constant GUID like this 
const 
MYGUID = ‘{678077B3-095F-4ECE-836D-7E1172C20979}’; 
3. Change the call to SetGUID to  
CreateError.SetGUID(StringToGUID(MYGUID)); 
4. Change the calls to SetSource and SetHelpFile to 
CreateError.SetSource(StringToOleStr(‘MY ERROR SOURCE’));

Written by lummie on 2005-06-09 11:19:00

Ah yes I left my application GUID in SetGUID. 
Customize it to your application as above. Thanks Guest

Use the following function to return them. A quck adaption and you should be able to set them as well. For more values to pass into the function check the current contents of the registry key.

function GetSpecialDir(ValueName : string): String;
//  gets the path to a windows special folder and ensures the trailing backslash is on the path.
//  Some Valid ValueNames are
//  ‘Personal’ – My Documents
//  ‘Desktop’ – User’s Desktop
//  ‘Favorites’ – The User Favorites store
var
  Reg: TRegistry;
begin
  result := ”;
  Reg := TRegistry.Create;
try
    Reg.RootKey := HKey_Current_User;
if Reg.OpenKeyReadOnly(‘SoftwareMicrosoftWindowsCurrentVersionExplo
rerShell Folders’) then
      result := IncludeTrailingPathDelimiter(Reg.ReadString(ValueName));
finally
    Reg.Free;
end;
end;

Having written your nice COM Object model to allow access to your application, how do you find out if you have neen clearing up the objects correctly and check you are handling zombie objects correctly too.

If you add the following unit to your aplication and descend your comobjects from TTracker instead of TAutoObject, this unit will count the number of addrefs and releases that occur on the object.

All you need to do is call TTrackerlog.dump to get a list of all the objects, the maximum number of instances ever alive and the current number alive.

All we are doing, is overriding the addref and release implementation, and maintaing a list of stats based up on the objects classname.

unit ObjectTracker;
interface
uses
   Classes, SysUtils, ComObj, Contnrs, SyncObjs, ActiveX;
type
   TTrackedItemInfo = (iiCreationOnAdd, iiCreationOnRelease);
   TTrackedItemInfos = set of TTrackedItemInfo;
   TTracker = class (TAutoObject)
     FTrackedClassName: string;
public
constructor create; virtual;
function ObjAddRef: Integer; override; stdcall;
function ObjRelease: Integer; override; stdcall;
end;
   TTrackedItem = class (TObject)
private
     FDesc: string;
     FInfo: TTrackedItemInfos;
     FMaxCount: Integer;
     FMinCount: Integer;
     FObjAddress: Pointer;
     FRefCount: Integer;
public
constructor Create(AnObj : pointer);
procedure AddReference;
procedure RemoveReference;
property Desc: string read FDesc write FDesc;
property Info: TTrackedItemInfos read FInfo write FInfo;
property MaxCount: Integer read FMaxCount;
property MinCount: Integer read FMinCount;
property ObjAddress: Pointer read FObjAddress write FObjAddress;
property RefCount: Integer read FRefCount;
end;
   TTrackerLog = class (TObject)
     FList: TObjectList;
     FLock: TMultiReadExclusiveWriteSynchronizer;
protected
constructor CreateInstance;
class function AccessInstance(Request: Integer): TTrackerLog;
public
constructor Create; virtual;
destructor Destroy; override;
procedure AddReference(AnObj : TObject; TrackedClassName : string);
procedure Dump(const AFilename : widestring);
class function Instance: TTrackerLog;
class procedure ReleaseInstance;
procedure ReleaseReference(AnObj : TObject; TrackedClassName : string);
end;
implementation
{ TTracker }
{
*************************** TTracker ***************************
}
constructor TTracker.create;
begin
inherited;
   FTrackedClassName := Classname;
end;
function TTracker.ObjAddRef: Integer;
begin
   result := inherited ObjAddRef;
   TTrackerLog.Instance.AddReference(self,FTrackedClassName);
end;
function TTracker.ObjRelease: Integer;
begin
   result := inherited ObjRelease;
   TTrackerLog.Instance.ReleaseReference(self,FTrackedClassName);
end;
{ TTrackerLog }
{
**************************** TTrackedItem *************************
}
constructor TTrackedItem.Create(AnObj : pointer);
begin
inherited Create;
   FMinCount := 0;
   FMaxCount := 0;
   FObjAddress := Anobj;
   FRefCount := 0;
   FInfo := [];
end;
procedure TTrackedItem.AddReference;
begin
   inc(FRefCount);
if FMaxCount < FRefCount then FMaxCount := FRefCount;
end;
procedure TTrackedItem.RemoveReference;
begin
   Dec(FRefCount);
if FMinCount > FRefCount then FMinCount := FRefCount;
end;
{
**************************** TTrackerLog ****************************
}
constructor TTrackerLog.Create;
begin
raise Exception.CreateFmt(‘Access class %s through Instance only’, [ClassName]);
inherited create;
end;
constructor TTrackerLog.CreateInstance;
begin
inherited Create;
   FList := TObjectList.create(true);
   FLock := TMultiReadExclusiveWriteSynchronizer.create;
end;
destructor TTrackerLog.Destroy;
begin
if AccessInstance(0) = Self then AccessInstance(2);
   FreeAndNil(FLock);
   FreeAndNil(FList);
inherited Destroy;
end;
class function TTrackerLog.AccessInstance(Request: Integer): TTrackerLog;
{$WRITEABLECONST ON}
const FInstance: TTrackerLog = nil;
{$WRITEABLECONST OFF}
begin
case Request of
0 : ;
1 : if not Assigned(FInstance) then FInstance := CreateInstance;
2 : FInstance := nil;
else
raise Exception.CreateFmt(‘Illegal request %d in AccessInstance’, [Request]);
end;
   Result := FInstance;
end;
procedure TTrackerLog.AddReference(AnObj : TObject; TrackedClassName : string);
var
   i: Integer;
   Item: TTrackedItem;
begin
   FLock.BeginWrite;
try
     i := FList.count -1;
while (i >= 0) and (TTrackedItem(FList.items[i]).ObjAddress <> AnObj) do dec(i);
if i = -1 then // not found
begin
       item := TTrackedItem.create(AnObj);
       item.Info := Item.Info + [iiCreationOnAdd];
       item.Desc := TrackedClassName;
       Flist.add(item);
end
else
       item := TTrackedItem(FList.items[i]);
     item.AddReference;
finally
   &nbsp
; FLock.EndWrite
end;
end;
procedure TTrackerLog.Dump(const AFilename : widestring);
var
   FName: string;
   i: Integer;
   Item: TTrackedItem;
   fs: TFileStream;
   t: string;
begin
   FLock.BeginRead;
try
//  FName := GetModuleName(HInstance);
//  FName := ChangeFileExt(FName,formatdatetime(‘.hhnnss’,now)) + ‘.csv’;
     FName := AFilename;
if FList.Count > 0 then
begin
       fs := TFileStream.create(fname,fmCreate);
       t := ‘”Address”,”ClassName”,”RefCount&quo
t;,”Max”,”Min”‘ + #13#10;
       fs.Write(t[1],length(t));
for i := 0 to FList.count -1 do
begin
         item := TTrackedItem(FList.items[i]);
         t := format(‘”%x”,”%s”,%d,%d,%d’,[integer(item.
ObjAddress),item.Desc, item.RefCount, item.MaxCount, item.MinCount]) + #13#10;
         fs.Write(t[1],length(t));
end;
       fs.free;
end;
finally
     FLock.EndRead;
end;
end;
class function TTrackerLog.Instance: TTrackerLog;
begin
   Result := AccessInstance(1);
end;
class procedure TTrackerLog.ReleaseInstance;
begin
   AccessInstance(0).Free;
end;
procedure TTrackerLog.ReleaseReference(AnObj : TObject; TrackedClassName : string);
var
   i: Integer;
   Item: TTrackedItem;
begin
   FLock.BeginWrite;
try
     i := FList.count – 1;
while (i >= 0) and (TTrackedItem(FList.items[i]).ObjAddress <> AnObj) do dec(i);
if i = -1 then // not found
begin
       item := TTrackedItem.create(AnObj);
       item.Info := Item.Info + [iiCreationOnRelease];
       item.Desc := TrackedClassName;
       Flist.add(item);
end
else
       item := TTrackedItem(FList.items[i]);
     item.RemoveReference;
finally
     FLock.EndWrite
end;
end;
initialization
finalization
if TTrackerLog.Instance <> nil then TTrackerLog.ReleaseInstance;
end.

The object inspector has an inbuilt ability to edit any TPersistent based object.
It uses RTTI to inspect the published properties of the TPersistent descendant and displays them as an expandable property. This is how the constraints property is implemented for example.

The following unit provides an implementation of an editable TRect. I use this in controls for specifing margins for example.

unit PersistentRect;
interface
uses
   Classes, SysUtils, types;
type
   TPersistentRect = class(TPersistent)
private
     FRect : TRect;
     FOnChange: TNotifyEvent;
function GetRect: TRect;
procedure SetRect(const Value: TRect);
procedure SetRectBottom(const Value: integer);
procedure SetRectLeft(const Value: integer);
procedure SetRectRight(const Value: integer);
procedure SetRectTop(const Value: integer);
protected
procedure AssignTo(Dest: TPersistent); override;
public
property AsRect : TRect read GetRect Write SetRect;
constructor create; virtual;
published
property Left : integer read FRect.Left write SetRectLeft;
property Top : integer read FRect.Top write SetRectTop;
property Right : integer read FRect.Right write SetRectRight;
property Bottom : integer read FRect.Bottom write SetRectBottom;
property OnChange : TNotifyEvent read FOnChange write FOnChange;
end;
implementation
{ TPersistentRect }
procedure TPersistentRect.AssignTo(Dest: TPersistent);
begin
if Dest is TPersistentRect then
with TPersistentRect(Dest) do
begin
       AsRect := Self.AsRect;
end
else inherited AssignTo(Dest);
end;
constructor TPersistentRect.create;
begin
inherited;
   FOnChange := nil;
end;
function TPersistentRect.GetRect: TRect;
begin
   result := FRect;
end;
procedure TPersistentRect.SetRect(const Value: TRect);
begin
   FRect.Left := value.left;
   FRect.top := value.top;
   FRect.right := value.right;
   FRect.bottom := value.bottom;
if assigned(FOnChange) then FOnChange(self);
end;
procedure TPersistentRect.SetRectBottom(const Value: integer);
begin
   FRect.Bottom := Value;
if assigned(FOnChange) then FOnChange(self);
end;
procedure TPersistentRect.SetRectLeft(const Value: integer);
begin
   FRect.Left := Value;
if assigned(FOnChange) then FOnChange(self);
end;
procedure TPersistentRect.SetRectRight(const Value: integer);
begin
   FRect.Right := Value;
if assigned(FOnChange) then FOnChange(self);
end;
procedure TPersistentRect.SetRectTop(const Value: integer);
begin
   FRect.Top := Value;
if assigned(FOnChange) then FOnChange(self);
end;
end.

Example of usage
In the Component that you want an editable rect for add the following :

 TPanelWithMargins = class(TCustomPanel)
private
{ Private declarations }
     FMargins: TPersistentRect;
protected
{ Protected declarations }
procedure MarginsChanged(Sender : TObject);
procedure AdjustClientRect(var Rect: TRect); override;
public
{ Public declarations }
constructor Create(AOwner: TComponent); override;
destructor Destroy; override;
published
{ Published declarations }
property Margins : TPersistentRect read FMargins write FMargins;
end;
procedure TPanelWithMargins.AdjustClientRect(var Rect: TRect);
begin
inherited;
   Rect.Left := rect.Left + FMargins.Left;
   Rect.Top := rect.top + FMargins.Top;
   Rect.Right := rect.Right – FMargins.Right;
   Rect.Bottom := rect.Bottom – FMargins.Bottom;
end;
constructor TPanelWithMargins.Create(AOwner: TComponent);
begin
inherited;
   FMargins := TPersistentRect.create;
   FMargins.OnChange := MarginsChanged;
   FMargins.AsRect := Rect(2,2,2,2);
end;
destructor TPanelWithMargins.Destroy;
begin
   FreeAndNil(FMargins);
inherited;
end;
procedure TPanelWithMargins.MarginsChanged(Sender: TObject);
begin
   Realign;
end;