I have the two overload methods:
procedure TProps.SetProp(Value: TObject); overload;
procedure TProps.SetProp(const Value: Variant); overload;
They do pretty much the same repeating code except from minor variations depending on whether the Value is Variant or TObject.
I want to use a common method:
procedure TProps.DoSetProp(Value: <what type here?>); // <--
So I can pass both Variant or TObject from SetProp and be able to distinguish between the two types. what are my options?
Edit: for now I used:
procedure TProps.DoSetProp(Value: Pointer; IsValueObject: Boolean);
begin
// common code...
if IsValueObject then
PropValue.Obj := Value
else
PropValue.V := PVariant(Value)^;
// common code...
if IsValueObject then
PropValue.Obj := Value
else
PropValue.V := PVariant(Value)^;
// etc...
end;
and the overload methods:
procedure TProps.SetProp(const Value: Variant); overload;
begin
DoSetProp(#Value, False);
end;
procedure TProps.SetProp(Value: TObject); overload;
begin
DoSetProp(Value, True);
end;
I'm not sure I like this solution because of the IsValueObject. I would rather detect the type from a common type "container".
I could use TVarRec:
VarRec: TVarRec;
// for Variant:
VarRec.VType := vtVariant;
VarRec.VVariant := #Value;
// for TObject
VarRec.VType := vtObject;
VarRec.VObject := Value;
And pass the VarRec to the common method. but I'm not sure I like it either.
EDIT 2: What I am trying to do? I'm trying to extend properties for any TObject similar to SetProp API.
Here is the entire MCVE:
function ComparePointers(A, B: Pointer): Integer;
begin
if Cardinal(A) = Cardinal(B) then
Result := 0
else if Cardinal(A) < Cardinal(B) then
Result := -1
else
Result := 1
end;
type
TPropValue = class
private
V: Variant;
Obj: TObject;
procedure SetValue(const Value: Pointer; IsValueObject: Boolean);
end;
TPropNameValueList = class(TStringList)
public
destructor Destroy; override;
procedure Delete(Index: Integer); override;
end;
TObjectProps = class
private
BaseObject: TObject;
PropList: TPropNameValueList;
public
constructor Create(AObject: TObject);
destructor Destroy; override;
end;
TProps = class(TComponent)
private
FList: TObjectList;
protected
procedure DoSetProp(AObject: TObject; const PropName: string; const Value: Pointer; IsValueObject: Boolean);
procedure Notification(AComponent: TComponent; Operation: TOperation); override;
public
function Find(AObject: TObject; var Index: Integer): Boolean;
procedure SetProp(AObject: TObject; const PropName: string; const Value: Variant); overload;
procedure SetProp(AObject: TObject; const PropName: string; Value: TObject); overload;
function RemoveProp(AObject: TObject; const PropName: string): Boolean;
function RemoveProps(AObject: TObject): Boolean;
constructor Create(AOwner: TComponent); override;
destructor Destroy; override;
end;
{ TPropValue }
procedure TPropValue.SetValue(const Value: Pointer; IsValueObject: Boolean);
begin
if IsValueObject then
Obj := Value
else
V := PVariant(Value)^;
end;
{ TPropNameValueList }
destructor TPropNameValueList.Destroy;
var
I: Integer;
begin
for I := 0 to Count - 1 do
Objects[I].Free; // TPropValue
inherited;
end;
procedure TPropNameValueList.Delete(Index: Integer);
begin
Objects[Index].Free;
inherited;
end;
{ TObjectProps }
constructor TObjectProps.Create(AObject: TObject);
begin
BaseObject := AObject;
PropList := TPropNameValueList.Create;
PropList.Sorted := True;
PropList.Duplicates := dupError;
end;
destructor TObjectProps.Destroy;
begin
PropList.Free;
inherited;
end;
{ TProps }
constructor TProps.Create(AOwner: TComponent);
begin
inherited;
FList := TObjectList.Create(true);
end;
procedure TProps.Notification(AComponent: TComponent; Operation: TOperation);
begin
inherited;
if (Operation = opRemove) and (AComponent <> nil) then
begin
RemoveProps(AComponent);
end;
end;
destructor TProps.Destroy;
begin
FList.Free;
inherited;
end;
function TProps.Find(AObject: TObject; var Index: Integer): Boolean;
var
L, H, I, C: Integer;
begin
Result := False;
L := 0;
H := FList.Count - 1;
while L <= H do
begin
I := (L + H) shr 1;
C := ComparePointers(TObjectProps(FList[I]).BaseObject, AObject);
if C < 0 then L := I + 1 else
begin
H := I - 1;
if C = 0 then
begin
Result := True;
L := I;
end;
end;
end;
Index := L;
end;
procedure TProps.DoSetProp(AObject: TObject; const PropName: string; const Value: Pointer;
IsValueObject: Boolean);
var
OP: TObjectProps;
PropValue: TPropValue;
Index, NameIndex: Integer;
Found: Boolean;
I: Integer;
begin
Found := Find(AObject, Index);
if not Found then
begin
OP := TObjectProps.Create(AObject);
if AObject is TComponent then
TComponent(AObject).FreeNotification(Self);
PropValue := TPropValue.Create;
PropValue.SetValue(Value, IsValueObject);
OP.PropList.AddObject(PropName, PropValue);
FList.Insert(Index, OP);
end
else
begin
OP := TObjectProps(FList[Index]);
NameIndex := OP.PropList.IndexOf(PropName);
if NameIndex <> -1 then
begin
PropValue := TPropValue(OP.PropList.Objects[NameIndex]);
PropValue.SetValue(Value, IsValueObject);
end
else
begin
PropValue := TPropValue.Create;
PropValue.SetValue(Value, IsValueObject);
OP.PropList.AddObject(PropName, PropValue);
end;
end;
end;
procedure TProps.SetProp(AObject: TObject; const PropName: string; const Value: Variant);
begin
DoSetProp(AObject, PropName, #Value, False);
end;
procedure TProps.SetProp(AObject: TObject; const PropName: string; Value: TObject);
begin
DoSetProp(AObject, PropName, Value, True);
end;
function TProps.RemoveProp(AObject: TObject; const PropName: string): Boolean;
var
Index, NameIndex: Integer;
OP: TObjectProps;
begin
Result := False;
if not Find(AObject, Index) then Exit;
OP := TObjectProps(FList[Index]);
NameIndex := OP.PropList.IndexOf(PropName);
if NameIndex <> -1 then
begin
OP.PropList.Delete(NameIndex);
Result := True;
end;
end;
function TProps.RemoveProps(AObject: TObject): Boolean;
var
Index: Integer;
OP: TObjectProps;
begin
if not Find(AObject, Index) then
begin
Result := False;
Exit;
end;
OP := TObjectProps(FList[Index]);
Result := FList.Remove(OP) <> -1;
end;
Usage:
Props := TProps.Create(Self);
Props.SetProp(Button1, 'myprop1', Self); // TObject property
Props.SetProp(Button1, 'myprop2', 666); // variant
Props.SetProp(Button2, 'myprop', 'Hello'); // variant
Props.SetProp(MyObject, 'foo', 123.123);
Note: TProps.GetProp is not yet implemented.
You are fighting the compiler; You should continue to use overloads.
"I would rather detect the type from a common type 'container'."
Your choices are variant or untyped pointer. You are going to have to unpack the "Value" parameter. With an untyped pointer you will have to do all the work; with a variant you will have to do most of the work. Very messy.
"They do pretty much the same repeating code except from minor variations depending on whether the Value is Variant or TObject."
If that is really true then you should still continue to use overloads but add an internal "SetProp" method that takes "normalized" data that does the actual work. Your "repeating" code is the setting of the property values. But you still have specific code to write to crack the incoming "Value" parameter whether you have one method that accepts a "container" type or multiple overloaded methods that take the various types you want to accept. In the one-method-container type you will have a (complex) if-then-else block that cracks the Value. In the overloaded-methods type there is no if-testing; you just crack the Value for the type that each method accepts.
The major advantage is that your object is better documented: you can see what types are acceptable for "Value" and, better still, the compiler helps you because it "knows" what types are acceptable. With your one-method approach the compiler will not be able to help you enforce the type of "Value"; you are doing all the work.
Also, using the overloaded methods, I wouldn't have one that accepts variant (although the example below does). Have an separate overload for each of string, integer, double, etc.
type
TNormalizedPropValue = record
// ....
end;
procedure TProps.internalSetProp(Value : TNormalizedPropValue);
begin
//
// Set the property value from the "Normalized" pieces and parts.
//
end;
procedure TProps.SetProp(Value : TObject);
var
NormalizedObjectPropValue : TNormalizedPropValue;
begin
// Copy the pieces and parts from "Value" into NormalizedObjectPropValue
//
internalSetProp(NormalizedObjectPropValue);
end;
procedure TProps.SetProp(Value : variant);
var
NormalizedVariantPropValue : TNormalizedPropValue;
begin
// Crack "Value" variant and copy the pieces and parts into NormalizedVariantPropValue
//
internalSetProp(NormalizedVariantPropValue);
end;
I rarely use threads and I have question about this class:
unit ExpectingThread;
interface
uses
System.Classes;
type
TExpectingThread = class(TThread)
private
_timeoutMs: Integer;
_buff: string;
_patterns: TArray<string>;
_result: Integer;
function Timeouted(startTime: Cardinal): Boolean;
function ExpectedDetected: Boolean;
protected
procedure Execute; override;
public
constructor Create(patterns: TArray<string>; buff: string; timeoutMs: Integer);
//this method is called from other NOT MAIN thread
procedure BuffUpdate(text: string);
end;
implementation
uses
Winapi.Windows,
System.RegularExpressions;
{ TExpectingThread }
constructor TExpectingThread.Create(patterns: TArray<string>; buff: string; timeoutMs: Integer);
begin
_patterns := patterns;
_timeoutMs := timeoutMs;
_buff := buff;
end;
//this method is called from other NOT MAIN thread
procedure TExpectingThread.BuffUpdate(text: string);
begin
// lock
TThread.Synchronize(Self, procedure
begin
_buff := _buff + text;
end);
// unlock
end;
procedure TExpectingThread.Execute;
var
startTime: Cardinal;
begin
inherited;
startTime := GetTickCount;
while true do
begin
if Timeouted(startTime) then
begin
Self.ReturnValue := 0; // timeouted
Exit;
end;
if ExpectedDetected then
begin
Self.ReturnValue := 1; // found
Exit;
end;
end;
end;
function TExpectingThread.ExpectedDetected: Boolean;
var
regex: TRegEx;
i: Integer;
begin
// lock
result := 0;
for i := 0 to High(_patterns) do
begin
regex.Create(_patterns[i]);
if regex.IsMatch(_buff) then
begin
_result := i;
Exit(true);
end;
end;
// unlock
end;
function TExpectingThread.Timeouted(startTime: Cardinal): Boolean;
var
currentTime: Cardinal;
begin
currentTime := GetTickCount;
result := currentTime - startTime > _timeoutMs;
end;
end.
Thread has to cheacking if any pattern is match to buffer over timeout. But other thread(NOT MAIN) can change buffer by using BuffUpdate method. Did I use Synchronization method correctly?
Synchronize() is specifically designed to work with the main UI thread. You can use it for inter-thread syncing, however ALL threads involved would have to use it. In your example, only the thread(s) that write to _buff are using it, but the thread that reads from _buff is not. So that is a hole in your logic.
That being said, if the main UI thread does not need to touch your data, then Synchronize() is not the best solution to use. You can just wrap the data access with a synchronization object instead, like a TCriticalSection, TMutex, TEvent, TMREWSync, Sytem.TMonitor, etc. For example:
unit ExpectingThread;
interface
uses
System.Classes, System.SyncObjs;
type
TExpectingThread = class(TThread)
private
_timeoutMs: Integer;
_buff: string;
_buffLock: TCriticalSection;
_buffChanged: Boolean;
_patterns: TArray<string>;
_result: Integer;
function Timeouted(startTime: Cardinal): Boolean;
function ExpectedDetected: Boolean;
protected
procedure Execute; override;
public
constructor Create(patterns: TArray<string>; buff: string; timeoutMs: Integer);
destructor Destroy; override;
//this method is called from other NOT MAIN thread
procedure BuffUpdate(text: string);
end;
implementation
uses
Winapi.Windows, System.RegularExpressions;
{ TExpectingThread }
constructor TExpectingThread.Create(patterns: TArray<string>; buff: string; timeoutMs: Integer);
begin
inherited Create(False);
_buffLock := TCriticalSection.Create;
_patterns := patterns;
_timeoutMs := timeoutMs;
_buff := buff;
_buffChanged := True;
end;
destructor TExpectingThread.Destroy;
begin
_buffLock.Free;
inherited;
end;
//this method is called from other NOT MAIN thread
procedure TExpectingThread.BuffUpdate(text: string);
begin
_buffLock.Enter;
try
_buff := _buff + text;
_buffChanged := True;
finally
_buffLock.Leave;
end;
end;
procedure TExpectingThread.Execute;
var
startTime: DWORD;
begin
startTime := GetTickCount;
while not Terminated do
begin
if Timeouted(startTime) then
begin
Self.ReturnValue := 0; // timeouted
Exit;
end;
if ExpectedDetected then
begin
Self.ReturnValue := 1; // found
Exit;
end;
end;
end;
function TExpectingThread.ExpectedDetected: Boolean;
var
i: Integer;
buff: string;
begin
Result := False;
_buffLock.Enter;
try
If not _buffChanged then Exit;
buff := _buff;
UniqueStr(buff);
_buffChanged := False;
finally
_buffLock.Leave;
end;
for i := Low(_patterns) to High(_patterns) do
begin
if TRegEx.IsMatch(buff, _patterns[i]) then
begin
_result := i;
Exit(True);
end;
end;
end;
function TExpectingThread.Timeouted(startTime: Cardinal): Boolean;
var
currentTime: DWORD;
begin
currentTime := GetTickCount;
result := currentTime - startTime > _timeoutMs;
end;
end.
I would like to implement a simple watchdog timer in Delphi XE 7 with two use cases:
• Watchdog ensures that a operation doesn't execute longer than x seconds
• Watchdog ensures that when errors occur then message exception will be stored in log file
Could you please suggest me any solution?
Here is my solution. I'm not sure that is a proper, but its works. I crated a new thread:
type
// will store all running processes
TProcessRecord = record
Handle: THandle;
DateTimeBegin, DateTimeTerminate: TDateTime;
end;
TWatchDogTimerThread = class(TThread)
private
FItems: TList<TProcessRecord>;
FItemsCS: TCriticalSection;
class var FInstance: TWatchDogTimerThread;
function IsProcessRunning(const AItem: TProcessRecord): Boolean;
function IsProcessTimedOut(const AItem: TProcessRecord): Boolean;
procedure InternalKillProcess(const AItem: TProcessRecord);
protected
constructor Create;
procedure Execute; override;
public
class function Instance: TWatchDogTimerThread;
destructor Destroy; override;
procedure AddItem(AProcess: THandle; ADateStart: TDateTime; ATimeOutMS: Cardinal);
end;
const
csPocessThreadLatencyTimeMs = 500;
And here is an implementation part:
procedure TWatchDogTimerThread.Execute;
var
i: Integer;
begin
while not Terminated do
begin
Sleep(csPocessThreadLatencyTimeMs);
FItemsCS.Enter;
try
i := 0;
while i < FItems.Count do
begin
if not IsProcessRunning(FItems[i]) then
begin
FItems.Delete(i);
end
else if IsProcessTimedOut(FItems[i]) then
begin
InternalKillProcess(FItems[i]);
FItems.Delete(i);
end
else
Inc(i);
end;
finally
FItemsCS.Leave;
end;
end;
end;
procedure TWatchDogTimerThread.AddItem(AProcess: THandle; ADateStart: TDateTime; ATimeOutMS: Cardinal);
var
LItem: TProcessRecord;
begin
LItem.Handle := AProcess;
LItem.DateTimeBegin := ADateStart;
LItem.DateTimeTerminate := IncMilliSecond(ADateStart, ATimeOutMS);
FItemsCS.Enter;
try
FItems.Add(LItem);
finally
FItemsCS.Leave;
end;
end;
constructor TWatchDogTimerThread.Create;
begin
inherited Create(False);
FItems := TList<TProcessRecord>.Create;
FItemsCS := TCriticalSection.Create;
end;
destructor TWatchDogTimerThread.Destroy;
begin
FreeAndNil(FItemsCS);
FItems.Free;
FInstance := nil;
inherited;
end;
class function TWatchDogTimerThread.Instance: TWatchDogTimerThread;
begin
if not Assigned(FInstance) then
FInstance := Create;
Result := FInstance;
end;
procedure TWatchDogTimerThread.InternalKillProcess(const AItem: TProcessRecord);
begin
if AItem.Handle <> 0 then
TerminateProcess(AItem.Handle, 0);
end;
function TWatchDogTimerThread.IsProcessRunning(const AItem: TProcessRecord): Boolean;
var
LPID: DWORD;
begin
LPID := 0;
if AItem.Handle <> 0 then
GetWindowThreadProcessId(AItem.Handle, #LPID);
Result := LPID <> 0;
end;
function TWatchDogTimerThread.IsProcessTimedOut(const AItem: TProcessRecord): Boolean;
begin
Result := (AItem.DateTimeTerminate < Now);// and IsProcessRunning(AItem);
end;
end.
This article
http://msdn.microsoft.com/en-gb/library/bb776867.aspx
describes preview handlers in Windows as
Preview handlers are called when an
item is selected to show a
lightweight, rich, read-only preview
of the file's contents in the view's
reading pane. This is done without
launching the file's associated
application.
and ...
A preview handler is a hosted
application. Hosts include the
Microsoft Windows Explorer in Windows
Vista or Microsoft Outlook 2007.
Is there some Delphi VCL code which can be used as a startingpoint for such a handler?
#Mjn, right know I'm writing an article for my blog to implement Preview Handlers from Delphi, but due to lack of time, I do not know when this is complete, as others users mention by the moment no exist a VCL component in Delphi to implement preview handlers, in the past I implemented a couple of preview handlers for a customer but using Delphi-Prism and C#.
As starting point here I leave some tips.
You must use the IPreviewHandler, InitializeWithFile, InitializeWithStream, IPreviewHandlerFrame, IPreviewHandlerVisuals interfaces.
This is the Delphi translation of the headers of these interfaces
uses
Windows, ActiveX, AxCtrls, ShlObj, ComObj;
type
IIPreviewHandler = interface(IUnknown)
['{8895b1c6-b41f-4c1c-a562-0d564250836f}']
function SetWindow(hwnd: HWND; var RectangleRef: TRect): HRESULT; stdcall;
function SetRect(var RectangleRef: TRect): HRESULT; stdcall;
function DoPreview(): HRESULT; stdcall;
function Unload(): HRESULT; stdcall;
function SetFocus(): HRESULT; stdcall;
function QueryFocus(phwnd: HWND): HRESULT; stdcall;
function TranslateAccelerator(PointerToWindowMessage: MSG): HRESULT; stdcall;
end;
IInitializeWithFile = interface(IUnknown)
['{b7d14566-0509-4cce-a71f-0a554233bd9b}']
function Initialize(pszFilePath: LPWSTR; grfMode: DWORD):HRESULT;stdcall;
end;
IInitializeWithStream = interface(IUnknown)
['{b824b49d-22ac-4161-ac8a-9916e8fa3f7f}']
function Initialize(pstream: IStream; grfMode: DWORD): HRESULT; stdcall;
end;
IIPreviewHandlerFrame = interface(IUnknown)
['{fec87aaf-35f9-447a-adb7-20234491401a}']
function GetWindowContext(pinfo: HWND): HRESULT; stdcall;
function TranslateAccelerator(PointerToWindowMessage: MSG): HRESULT; stdcall;
end;
IIPreviewHandlerVisuals = interface(IUnknown)
['{8327b13c-b63f-4b24-9b8a-d010dcc3f599}']
function SetBackgroundColor(color: COLORREF ): HRESULT; stdcall;
function SetFont(plf:LOGFONTW): HRESULT; stdcall;
function SetTextColor(color: COLORREF): HRESULT; stdcall;
end;
You must create a com dll with a class which descend from these interfaces IIPreviewHandler, IIPreviewHandlerVisuals, IOleWindow, IObjectWithSite to manage the visualization and a second class to load the files to show. this class must descend from IPreviewHandler, IInitializeWithStream.
something like this
TMyPreviewHandler = class(IIPreviewHandler, IIPreviewHandlerVisuals, IOleWindow, IObjectWithSite)
TMyStream = class(IIPreviewHandler, IInitializeWithStream, IStream)
Now you must create your own implementation of the methods for the parent interfaces.
this is the list of the methods which you need implement.
IPreviewHandler -> DoPreview, SetWindow, SetRect, Unload, SetFocus, TranslateAccelerator, QueryFocus.
IObjectWithSite -> GetSite, SetSite.
IOleWindow -> GetWindow
IPreviewHandlerVisuals - > SetBackgroundColor, SetFont, SetColor
InitializeWithStream -> Initialize
finally you must register your COM in the system as well as the file extensions which will use you PrevieHandler class.
Check this project as a starting point Windows Preview Handler Pack (is written in C#) and this article View Data Your Way With Our Managed Preview Handler Framework
I have made this unit to handle all the preview handler stuff:
unit PreviewHandler;
{$WARN SYMBOL_PLATFORM OFF}
{.$DEFINE USE_CODESITE}
interface
uses
Classes, Controls, ComObj;
type
TPreviewHandler = class abstract
public
{ Create all controls needed for the preview and connect them to the
parent given. The parent follows the size, color and font of the preview
pane. The parent will stay valid until this instance is destroyed, so if
you make the parent also the owner of the controls you don't need to free
them in Destroy. }
constructor Create(AParent: TWinControl); virtual;
class function GetComClass: TComClass; virtual; abstract;
class procedure Register(const AClassID: TGUID; const AName, ADescription, AFileExtension: string);
{$REGION 'Clear Content'}
/// <summary>Clear Content</summary>
/// <remarks>This method is called when the preview should be cleared because
/// either another item was selected or the PreviewHandler will be
/// closed.</remarks>
{$ENDREGION}
procedure Unload; virtual;
end;
TStreamPreviewHandler = class abstract(TPreviewHandler)
public
{$REGION 'Render the preview from the stream data'}
/// <summary>Render the preview from the stream data</summary>
/// <remarks>Here you should render the data from the stream in whatever
/// fashion you want.</remarks>
{$ENDREGION}
procedure DoPreview(Stream: TStream); virtual; abstract;
class function GetComClass: TComClass; override; final;
end;
TFilePreviewHandler = class abstract(TPreviewHandler)
public
{$REGION 'Render the preview from the file path'}
/// <summary>Render the preview from the file path</summary>
/// <remarks>Here you should render the data from the file path in whatever
/// fashion you want.</remarks>
{$ENDREGION}
procedure DoPreview(const FilePath: String); virtual; abstract;
class function GetComClass: TComClass; override; final;
end;
implementation
uses
{$IFDEF USE_CODESITE}
CodeSiteLogging,
{$ENDIF}
Windows, ActiveX, ComServ, ShlObj, PropSys, Types, SysUtils, Graphics, ExtCtrls;
type
TPreviewHandlerClass = class of TPreviewHandler;
TComPreviewHandler = class(TComObject, IPreviewHandler, IPreviewHandlerVisuals, IObjectWithSite, IOleWindow)
strict private
function IPreviewHandler.DoPreview = IPreviewHandler_DoPreview;
function ContextSensitiveHelp(fEnterMode: LongBool): HRESULT; stdcall;
function GetSite(const riid: TGUID; out site: IInterface): HRESULT; stdcall;
function GetWindow(out wnd: HWND): HRESULT; stdcall;
function IPreviewHandler_DoPreview: HRESULT; stdcall;
function QueryFocus(var phwnd: HWND): HRESULT; stdcall;
function SetBackgroundColor(color: Cardinal): HRESULT; stdcall;
function SetFocus: HRESULT; stdcall;
function SetFont(const plf: tagLOGFONTW): HRESULT; stdcall;
function SetRect(var prc: TRect): HRESULT; stdcall;
function SetSite(const pUnkSite: IInterface): HRESULT; stdcall;
function SetTextColor(color: Cardinal): HRESULT; stdcall;
function SetWindow(hwnd: HWND; var prc: TRect): HRESULT; stdcall;
function TranslateAccelerator(var pmsg: tagMSG): HRESULT; stdcall;
function Unload: HRESULT; stdcall;
private
FBackgroundColor: Cardinal;
FBounds: TRect;
FContainer: TWinControl;
FLogFont: tagLOGFONTW;
FParentWindow: HWND;
FPreviewHandler: TPreviewHandler;
FPreviewHandlerClass: TPreviewHandlerClass;
FPreviewHandlerFrame: IPreviewHandlerFrame;
FSite: IInterface;
FTextColor: Cardinal;
protected
procedure CheckContainer;
procedure CheckPreviewHandler;
procedure InternalUnload; virtual; abstract;
procedure InternalDoPreview; virtual; abstract;
property Container: TWinControl read FContainer;
property PreviewHandler: TPreviewHandler read FPreviewHandler;
public
destructor Destroy; override;
property PreviewHandlerClass: TPreviewHandlerClass read FPreviewHandlerClass write FPreviewHandlerClass;
end;
TComStreamPreviewHandler = class(TComPreviewHandler, IInitializeWithStream)
strict private
function IInitializeWithStream.Initialize = IInitializeWithStream_Initialize;
function IInitializeWithStream_Initialize(const pstream: IStream; grfMode: Cardinal): HRESULT; stdcall;
private
FIStream: IStream;
FMode: Cardinal;
function GetPreviewHandler: TStreamPreviewHandler;
protected
procedure InternalUnload; override;
procedure InternalDoPreview; override;
property PreviewHandler: TStreamPreviewHandler read GetPreviewHandler;
end;
TComFilePreviewHandler = class(TComPreviewHandler, IInitializeWithFile)
strict private
function IInitializeWithFile.Initialize = IInitializeWithFile_Initialize;
function IInitializeWithFile_Initialize(pszFilePath: LPCWSTR; grfMode: DWORD): HRESULT; stdcall;
private
FFilePath: string;
FMode: DWORD;
function GetPreviewHandler: TFilePreviewHandler;
protected
procedure InternalDoPreview; override;
procedure InternalUnload; override;
property PreviewHandler: TFilePreviewHandler read GetPreviewHandler;
end;
TComPreviewHandlerFactory = class(TComObjectFactory)
private
FFileExtension: string;
FPreviewHandlerClass: TPreviewHandlerClass;
class procedure DeleteRegValue(const Key, ValueName: string; RootKey: DWord);
class function IsRunningOnWOW64: Boolean;
protected
property FileExtension: string read FFileExtension;
public
constructor Create(APreviewHandlerClass: TPreviewHandlerClass; const AClassID: TGUID; const AName, ADescription, AFileExtension: string);
function CreateComObject(const Controller: IUnknown): TComObject; override;
procedure UpdateRegistry(Register: Boolean); override;
property PreviewHandlerClass: TPreviewHandlerClass read FPreviewHandlerClass;
end;
TWinControlHelper = class helper for TWinControl
public
procedure SetFocusTabFirst;
procedure SetFocusTabLast;
procedure SetBackgroundColor(AColor: Cardinal);
procedure SetBoundsRect(const ARect: TRect);
procedure SetTextColor(AColor: Cardinal);
procedure SetTextFont(const Source: tagLOGFONTW);
end;
TIStreamAdapter = class(TStream)
private
FTarget: IStream;
protected
function GetSize: Int64; override;
procedure SetSize(NewSize: Longint); override;
procedure SetSize(const NewSize: Int64); override;
public
constructor Create(ATarget: IStream);
function Read(var Buffer; Count: Longint): Longint; override;
function Seek(const Offset: Int64; Origin: TSeekOrigin): Int64; overload; override;
function Write(const Buffer; Count: Longint): Longint; override;
property Target: IStream read FTarget;
end;
procedure TWinControlHelper.SetFocusTabFirst;
begin
SelectNext(nil, true, true);
end;
procedure TWinControlHelper.SetFocusTabLast;
begin
SelectNext(nil, false, true);
end;
procedure TWinControlHelper.SetBackgroundColor(AColor: Cardinal);
begin
Color := AColor;
end;
procedure TWinControlHelper.SetBoundsRect(const ARect: TRect);
begin
SetBounds(ARect.Left, ARect.Top, ARect.Right - ARect.Left, ARect.Bottom - ARect.Top);
end;
procedure TWinControlHelper.SetTextColor(AColor: Cardinal);
begin
Font.Color := AColor;
end;
procedure TWinControlHelper.SetTextFont(const Source: tagLOGFONTW);
var
fontStyle: TFontStyles;
begin
Font.Height := Source.lfHeight;
fontStyle := Font.Style;
if Source.lfWeight >= FW_BOLD then
Include(fontStyle, fsBold);
if Source.lfItalic = 1 then
Include(fontStyle, fsItalic);
if Source.lfUnderline = 1 then
Include(fontStyle, fsUnderline);
if Source.lfStrikeOut = 1 then
Include(fontStyle, fsStrikeOut);
Font.Style := fontStyle;
Font.Charset := TFontCharset(Source.lfCharSet);
Font.Name := Source.lfFaceName;
case Source.lfPitchAndFamily and $F of
VARIABLE_PITCH: Font.Pitch := fpVariable;
FIXED_PITCH: Font.Pitch := fpFixed;
else
Font.Pitch := fpDefault;
end;
Font.Orientation := Source.lfOrientation;
end;
constructor TComPreviewHandlerFactory.Create(APreviewHandlerClass: TPreviewHandlerClass; const AClassID: TGUID; const
AName, ADescription, AFileExtension: string);
begin
inherited Create(ComServ.ComServer, APreviewHandlerClass.GetComClass, AClassID, AName, ADescription, ciMultiInstance, tmApartment);
FPreviewHandlerClass := APreviewHandlerClass;
FFileExtension := AFileExtension;
end;
function TComPreviewHandlerFactory.CreateComObject(const Controller: IUnknown): TComObject;
begin
result := inherited CreateComObject(Controller);
TComPreviewHandler(result).PreviewHandlerClass := PreviewHandlerClass;
end;
class procedure TComPreviewHandlerFactory.DeleteRegValue(const Key, ValueName: string; RootKey: DWord);
var
RegKey: HKEY;
begin
if RegOpenKeyEx(RootKey, PChar(Key), 0, KEY_ALL_ACCESS, regKey) = ERROR_SUCCESS then begin
try
RegDeleteValue(regKey, PChar(ValueName));
finally
RegCloseKey(regKey)
end;
end;
end;
class function TComPreviewHandlerFactory.IsRunningOnWOW64: Boolean;
{ code taken from www.delphidabbler.com "IsWow64" }
type
// Type of IsWow64Process API fn
TIsWow64Process = function(Handle: Windows.THandle; var Res: Windows.BOOL): Windows.BOOL; stdcall;
var
IsWow64Result: Windows.BOOL; // Result from IsWow64Process
IsWow64Process: TIsWow64Process; // IsWow64Process fn reference
begin
{$IF defined(CPUX64)}
// compiled for 64-bit: can't be running on Wow64
result := false;
{$ELSE}
// Try to load required function from kernel32
IsWow64Process := Windows.GetProcAddress(Windows.GetModuleHandle('kernel32'), 'IsWow64Process');
if Assigned(IsWow64Process) then begin
// Function is implemented: call it
if not IsWow64Process(Windows.GetCurrentProcess, IsWow64Result) then
raise SysUtils.Exception.Create('IsWindows64: bad process handle');
// Return result of function
Result := IsWow64Result;
end
else
// Function not implemented: can't be running on Wow64
Result := False;
{$IFEND}
end;
procedure TComPreviewHandlerFactory.UpdateRegistry(Register: Boolean);
var
plainFileName: string;
sAppID, sClassID, ProgID, ServerKeyName, RegPrefix: string;
RootKey: HKEY;
RootKey2: HKEY;
begin
if Instancing = ciInternal then
Exit;
ComServer.GetRegRootAndPrefix(RootKey, RegPrefix);
if ComServer.PerUserRegistration then
RootKey2 := HKEY_CURRENT_USER
else
RootKey2 := HKEY_LOCAL_MACHINE;
sClassID := GUIDToString(ClassID);
ProgID := GetProgID;
ServerKeyName := RegPrefix + 'CLSID\' + sClassID + '\' + ComServer.ServerKey;
if IsRunningOnWOW64 then
sAppID := '{534A1E02-D58F-44f0-B58B-36CBED287C7C}' // for Win32 shell extension running on Win64
else
sAppID := '{6d2b5079-2f0b-48dd-ab7f-97cec514d30b}';
if Register then begin
inherited;
plainFileName := ExtractFileName(ComServer.ServerFileName);
CreateRegKey(RegPrefix + 'CLSID\' + sClassID, 'AppID', sAppID, RootKey);
if ProgID <> '' then begin
CreateRegKey(ServerKeyName, 'ProgID', ProgID, RootKey);
CreateRegKey(ServerKeyName, 'VersionIndependentProgID', ProgID, RootKey);
CreateRegKey(RegPrefix + ProgID + '\shellex\' + SID_IPreviewHandler, '', sClassID, RootKey);
CreateRegKey(RegPrefix + FileExtension, '', ProgID, RootKey);
CreateRegKey('SOFTWARE\Microsoft\Windows\CurrentVersion\PreviewHandlers', sClassID, Description, RootKey2);
end;
end
else begin
if ProgID <> '' then begin
DeleteRegValue('SOFTWARE\Microsoft\Windows\CurrentVersion\PreviewHandlers', sClassID, RootKey2);
DeleteRegKey(RegPrefix + FileExtension, RootKey);
DeleteRegKey(RegPrefix + ProgID + '\shellex', RootKey);
end;
inherited;
end;
end;
destructor TComPreviewHandler.Destroy;
begin
FPreviewHandler.Free;
FContainer.Free;
inherited Destroy;
end;
procedure TComPreviewHandler.CheckContainer;
begin
if FContainer = nil then begin
{ I sprang for a TPanel here, because it makes things so much simpler. }
FContainer := TPanel.Create(nil);
TPanel(FContainer).BevelOuter := bvNone;
FContainer.SetBackgroundColor(FBackgroundColor);
FContainer.SetTextFont(FLogFont);
FContainer.SetTextColor(FTextColor);
FContainer.SetBoundsRect(FBounds);
FContainer.ParentWindow := FParentWindow;
end;
end;
procedure TComPreviewHandler.CheckPreviewHandler;
begin
if FPreviewHandler = nil then begin
CheckContainer;
FPreviewHandler := PreviewHandlerClass.Create(Container);
end;
end;
function TComPreviewHandler.ContextSensitiveHelp(fEnterMode: LongBool): HRESULT;
begin
result := E_NOTIMPL;
end;
function TComPreviewHandler.GetSite(const riid: TGUID; out site: IInterface): HRESULT;
begin
site := nil;
if FSite = nil then
result := E_FAIL
else if Supports(FSite, riid, site) then
result := S_OK
else
result := E_NOINTERFACE;
end;
function TComPreviewHandler.GetWindow(out wnd: HWND): HRESULT;
begin
if Container = nil then begin
result := E_FAIL;
end
else begin
wnd := Container.Handle;
result := S_OK;
end;
end;
function TComPreviewHandler.IPreviewHandler_DoPreview: HRESULT;
begin
try
CheckPreviewHandler;
InternalDoPreview;
except
on E: Exception do begin
{$IFDEF USE_CODESITE}
CodeSite.SendException(E);
{$ENDIF}
end;
end;
result := S_OK;
end;
function TComPreviewHandler.QueryFocus(var phwnd: HWND): HRESULT;
begin
phwnd := GetFocus;
result := S_OK;
end;
function TComPreviewHandler.SetBackgroundColor(color: Cardinal): HRESULT;
begin
FBackgroundColor := color;
if Container <> nil then
Container.SetBackgroundColor(FBackgroundColor);
result := S_OK;
end;
function TComPreviewHandler.SetFocus: HRESULT;
begin
if Container <> nil then begin
if GetKeyState(VK_SHIFT) < 0 then
Container.SetFocusTabLast
else
Container.SetFocusTabFirst;
end;
result := S_OK;
end;
function TComPreviewHandler.SetFont(const plf: tagLOGFONTW): HRESULT;
begin
FLogFont := plf;
if Container <> nil then
Container.SetTextFont(FLogFont);
result := S_OK;
end;
function TComPreviewHandler.SetRect(var prc: TRect): HRESULT;
begin
FBounds := prc;
if Container <> nil then
Container.SetBoundsRect(FBounds);
result := S_OK;
end;
function TComPreviewHandler.SetSite(const pUnkSite: IInterface): HRESULT;
begin
FSite := PUnkSite;
FPreviewHandlerFrame := FSite as IPreviewHandlerFrame;
result := S_OK;
end;
function TComPreviewHandler.SetTextColor(color: Cardinal): HRESULT;
begin
FTextColor := color;
if Container <> nil then
Container.SetTextColor(FTextColor);
result := S_OK;
end;
function TComPreviewHandler.SetWindow(hwnd: HWND; var prc: TRect): HRESULT;
begin
FParentWindow := hwnd;
FBounds := prc;
if Container <> nil then begin
Container.ParentWindow := FParentWindow;
Container.SetBoundsRect(FBounds);
end;
result := S_OK;
end;
function TComPreviewHandler.TranslateAccelerator(var pmsg: tagMSG): HRESULT;
begin
if FPreviewHandlerFrame = nil then
result := S_FALSE
else
result := FPreviewHandlerFrame.TranslateAccelerator(pmsg);
end;
function TComPreviewHandler.Unload: HRESULT;
begin
if PreviewHandler <> nil then
PreviewHandler.Unload;
InternalUnload;
result := S_OK;
end;
constructor TPreviewHandler.Create(AParent: TWinControl);
begin
inherited Create;
end;
class procedure TPreviewHandler.Register(const AClassID: TGUID; const AName, ADescription, AFileExtension: string);
begin
TComPreviewHandlerFactory.Create(Self, AClassID, AName, ADescription, AFileExtension);
end;
procedure TPreviewHandler.Unload;
begin
end;
constructor TIStreamAdapter.Create(ATarget: IStream);
begin
inherited Create;
FTarget := ATarget;
end;
function TIStreamAdapter.GetSize: Int64;
var
statStg: TStatStg;
begin
if Target.Stat(statStg, STATFLAG_NONAME) = S_OK then
result := statStg.cbSize
else
result := -1;
end;
function TIStreamAdapter.Read(var Buffer; Count: Longint): Longint;
begin
Target.Read(#Buffer, Count, #result);
end;
function TIStreamAdapter.Seek(const Offset: Int64; Origin: TSeekOrigin): Int64;
begin
Target.Seek(Offset, Ord(Origin), result);
end;
procedure TIStreamAdapter.SetSize(const NewSize: Int64);
begin
raise ENotImplemented.Create('SetSize not implemented');
// Target.SetSize(NewSize);
end;
procedure TIStreamAdapter.SetSize(NewSize: Longint);
begin
SetSize(Int64(NewSize));
end;
function TIStreamAdapter.Write(const Buffer; Count: Longint): Longint;
begin
raise ENotImplemented.Create('Write not implemented');
// Target.Write(#Buffer, Count, #result);
end;
function TComStreamPreviewHandler.GetPreviewHandler: TStreamPreviewHandler;
begin
Result := inherited PreviewHandler as TStreamPreviewHandler;
end;
function TComStreamPreviewHandler.IInitializeWithStream_Initialize(const pstream: IStream; grfMode: Cardinal): HRESULT;
begin
FIStream := pStream;
FMode := grfMode;
result := S_OK;
end;
procedure TComStreamPreviewHandler.InternalUnload;
begin
FIStream := nil;
end;
procedure TComStreamPreviewHandler.InternalDoPreview;
var
stream: TIStreamAdapter;
begin
stream := TIStreamAdapter.Create(FIStream);
try
PreviewHandler.DoPreview(stream);
finally
stream.Free;
end;
end;
function TComFilePreviewHandler.GetPreviewHandler: TFilePreviewHandler;
begin
Result := inherited PreviewHandler as TFilePreviewHandler;
end;
function TComFilePreviewHandler.IInitializeWithFile_Initialize(pszFilePath: LPCWSTR; grfMode: DWORD): HRESULT;
begin
FFilePath := pszFilePath;
FMode := grfMode;
result := S_OK;
end;
procedure TComFilePreviewHandler.InternalDoPreview;
begin
PreviewHandler.DoPreview(FFilePath);
end;
procedure TComFilePreviewHandler.InternalUnload;
begin
FFilePath := '';
end;
class function TFilePreviewHandler.GetComClass: TComClass;
begin
result := TComFilePreviewHandler;
end;
class function TStreamPreviewHandler.GetComClass: TComClass;
begin
result := TComStreamPreviewHandler;
end;
initialization
{$IFDEF USE_CODESITE}
CodeSiteManager.ConnectUsingTcp;
{$ENDIF}
end.
A sample preview handler based on this unit is shown here:
unit MyPreviewHandler;
interface
uses
PreviewHandler, Classes, Controls, StdCtrls;
const
{$REGION 'Unique ClassID of your PreviewHandler'}
/// <summary>Unique ClassID of your PreviewHandler</summary>
/// <remarks>Don't forget to create a new one. Best use Ctrl-G.</remarks>
{$ENDREGION}
CLASS_MyPreviewHandler: TGUID = '{64644512-C345-469F-B5FB-EB351E20129D}';
type
{$REGION 'Sample PreviewHandler'}
/// <summary>Sample PreviewHandler</summary>
/// <remarks>A sample PreviewHandler. You only have to derive from
/// TFilePreviewHandler or TStreamPreviewHandler and override some methods.</remarks>
{$ENDREGION}
TMyPreviewHandler = class(TFilePreviewHandler)
private
FTextLabel: TLabel;
protected
public
constructor Create(AParent: TWinControl); override;
procedure Unload; override;
procedure DoPreview(const FilePath: string); override;
property TextLabel: TLabel read FTextLabel;
end;
implementation
uses
SysUtils;
constructor TMyPreviewHandler.Create(AParent: TWinControl);
begin
inherited;
FTextLabel := TLabel.Create(AParent);
FTextLabel.Parent := AParent;
FTextLabel.AutoSize := false;
FTextLabel.Align := alClient;
FTextLabel.Alignment := taCenter;
FTextLabel.Layout := tlCenter;
FTextLabel.WordWrap := true;
end;
procedure TMyPreviewHandler.DoPreview(const FilePath: string);
begin
TextLabel.Caption := GetPackageDescription(PWideChar(FilePath));
end;
procedure TMyPreviewHandler.Unload;
begin
TextLabel.Caption := '';
inherited;
end;
initialization
{ Register your PreviewHandler with the ClassID, name, descripton and file extension }
TMyPreviewHandler.Register(CLASS_MyPreviewHandler, 'bplfile', 'BPL Binary Preview Handler', '.bpl');
end.
library MyPreviewHandlerLib;
uses
ComServ,
PreviewHandler in 'PreviewHandler.pas' {PreviewHandler: CoClass},
MyPreviewHandler in 'MyPreviewHandler.pas';
exports
DllGetClassObject,
DllCanUnloadNow,
DllRegisterServer,
DllUnregisterServer,
DllInstall;
{$R *.RES}
begin
end.
You may be interested in this article in my blog describing some more details on that framework.
I have never seen such a thing, but since the whole thing is build in COM, you would start by importing the type library, and implementing the required interfaces, including IPreviewHandlerFrame. [Sorry, not very helpful. But this is a pretty obscure area, so I'm not surprised that Delphi hasn't got a prebuilt component set for this.]
I can't find any references to using IPreviewHandlerFrame in Delphi, but did manage to come up with a C# example here - maybe it'll give you a starting point.
I think you have to write a COM-Server yourself, which provides the described IPreviwHandler-Interfacees. (There is no type library to import...) I am very interested in such a code as well and I am searching for quite a while now. I am not very experienced with COM-Server-writing... If you find something, let me know please! As I will share my code also, if I get some...
Andreas
I have custom form which is descendant from TForm. I used ToolApi to register custom module and add it to repository. So far so good. But when I click on File->New I can see my category with icon for my custom form but it is disabled. Icon is grayed and I cannot select it to create my custom form from menu and add it to project.
Do you have any suggestions and tips what is wrong and what should I try?
Click here to transfer my source code...
Thanks in advance.
Edit:
There is also listing of code for which I think it is important:
unit CustomFormFrame_Design;
interface
{$Include jvcl.inc}
uses Windows, Classes, ToolsAPI;
type
TPoCustomFormWizard = class(TNotifierObject, IOTAWizard, IOTARepositoryWizard,
IOTAFormWizard, IOTACreator, IOTAModuleCreator,
IOTARepositoryWizard60
{$IFDEF COMPILER8_UP}, IOTARepositoryWizard80 {$ENDIF COMPILER8_UP}
{$IFDEF COMPILER10_UP}, IOTAProjectWizard100 {$ENDIF COMPILER10_UP})
private
FUnitIdent: string;
FClassName: string;
FFileName: string;
protected
// IOTAWizard methods
function GetIDString: string;
function GetName: string;
function GetState: TWizardState;
procedure Execute;
// IOTARepositoryWizard / IOTAFormWizard methods
function GetAuthor: string;
function GetComment: string;
function GetPage: string;
function GetGlyph: Cardinal;
// IOTACreator methods
function GetCreatorType: string;
function GetExisting: Boolean;
function GetFileSystem: string;
function GetOwner: IOTAModule;
function GetUnnamed: Boolean;
// IOTAModuleCreator methods
function GetAncestorName: string;
function GetImplFileName: string;
function GetIntfFileName: string;
function GetFormName: string;
function GetMainForm: Boolean;
function GetShowForm: Boolean;
function GetShowSource: Boolean;
function NewFormFile(const FormIdent, AncestorIdent: string): IOTAFile;
function NewImplSource(const ModuleIdent, FormIdent,
AncestorIdent: string): IOTAFile;
function NewIntfSource(const ModuleIdent, FormIdent,
AncestorIdent: string): IOTAFile;
procedure FormCreated(const FormEditor: IOTAFormEditor);
{ IOTARepositoryWizard60 }
function GetDesigner: string;
{$IFDEF COMPILER8_UP}
{ IOTARepositoryWizard80 }
function GetGalleryCategory: IOTAGalleryCategory; virtual;
function GetPersonality: string; virtual;
{$ENDIF COMPILER8_UP}
{$IFDEF COMPILER10_UP}
{ IOTAProjectWizard100 }
function IsVisible(Project: IOTAProject): Boolean;
{$ENDIF COMPILER10_UP}
{$IFDEF COMPILER8_UP}
property Personality: string read GetPersonality;
{$ENDIF}
end;
procedure Register;
implementation
uses Forms, PoCustomForm, SysUtils, DesignIntf, DesignEditors;
{$R *.res}
type
TBaseFile = class(TInterfacedObject)
private
FModuleName: string;
FFormName: string;
FAncestorName: string;
public
constructor Create(const ModuleName, FormName, AncestorName: string);
end;
TUnitFile = class(TBaseFile, IOTAFile)
protected
function GetSource: string;
function GetAge: TDateTime;
end;
TFormFile = class(TBaseFile, IOTAFile)
protected
function GetSource: string;
function GetAge: TDateTime;
end;
procedure Register;
begin
RegisterCustomModule(TPoCustomForm, TCustomModule);
RegisterPackageWizard(TPoCustomFormWizard.Create);
end;
{ TBaseFile }
constructor TBaseFile.Create(const ModuleName, FormName, AncestorName: string);
begin
inherited Create;
FModuleName := ModuleName;
FFormName := FormName;
FAncestorName := AncestorName;
end;
{ TUnitFile }
function TUnitFile.GetSource: string;
var
Text: string;
ResInstance: THandle;
HRes: HRSRC;
begin
ResInstance := FindResourceHInstance(HInstance);
HRes := FindResource(ResInstance, 'CODEGEN', RT_RCDATA);
Text := PChar(LockResource(LoadResource(ResInstance, HRes)));
SetLength(Text, SizeOfResource(ResInstance, HRes));
Result := Format(Text, [FModuleName, FFormName, FAncestorName]);
end;
function TUnitFile.GetAge: TDateTime;
begin
Result := -1;
end;
{ TFormFile }
function TFormFile.GetSource: string;
const FormText = 'object %0:s: T%0:s'#13#10'end';
begin
Result := Format(FormText, [FFormName]);
end;
function TFormFile.GetAge: TDateTime;
begin
Result := -1;
end;
{ TAppBarWizard }
{ TAppBarWizard.IOTAWizard }
function TPoCustomFormWizard.GetIDString: string;
begin
Result := 'XFORM.PoCustomForm';
end;
function TPoCustomFormWizard.GetName: string;
begin
Result := 'XFORM PoCustom Form Wizard';
end;
function TPoCustomFormWizard.GetState: TWizardState;
begin
Result := [wsEnabled];
end;
procedure TPoCustomFormWizard.Execute;
begin
(BorlandIDEServices as IOTAModuleServices).GetNewModuleAndClassName(
'PoCustomForm', FUnitIdent, FClassName, FFileName);
(BorlandIDEServices as IOTAModuleServices).CreateModule(Self);
end;
{ TPoCustomFormWizard.IOTARepositoryWizard / TPoCustomFormWizard.IOTAFormWizard }
function TPoCustomFormWizard.GetGlyph: Cardinal;
begin
Result := 0; // use standard icon
end;
function TPoCustomFormWizard.GetPage: string;
begin
Result := 'XFORM';
end;
function TPoCustomFormWizard.GetAuthor: string;
begin
Result := 'XFORM';
end;
function TPoCustomFormWizard.GetComment: string;
begin
Result := 'Creates a new PoCustom form.'
end;
{ TPoCustomFormWizard.IOTACreator }
function TPoCustomFormWizard.GetCreatorType: string;
begin
Result := '';
end;
function TPoCustomFormWizard.GetDesigner: string;
begin
Result := dVCL;
end;
{$IFDEF COMPILER8_UP}
function TPoCustomFormWizard.GetGalleryCategory: IOTAGalleryCategory;
begin
Result := (BorlandIDEServices as IOTAGalleryCategoryManager).FindCategory('Borland.Delphi.New.Expert');
end;
function TPoCustomFormWizard.GetPersonality: string;
begin
Result := sDelphiPersonality;
end;
{$ENDIF COMPILER8_UP}
{$IFDEF COMPILER10_UP}
function TPoCustomFormWizard.IsVisible(Project: IOTAProject): Boolean;
begin
Result := True;
end;
{$ENDIF COMPILER10_UP}
function TPoCustomFormWizard.GetExisting: Boolean;
begin
Result := False;
end;
function TPoCustomFormWizard.GetFileSystem: string;
begin
Result := '';
end;
function TPoCustomFormWizard.GetOwner: IOTAModule;
var
I: Integer;
ModServ: IOTAModuleServices;
Module: IOTAModule;
ProjGrp: IOTAProjectGroup;
begin
Result := nil;
ModServ := BorlandIDEServices as IOTAModuleServices;
for I := 0 to ModServ.ModuleCount - 1 do
begin
Module := ModSErv.Modules[I];
// find current project group
if CompareText(ExtractFileExt(Module.FileName), '.bpg') = 0 then
if Module.QueryInterface(IOTAProjectGroup, ProjGrp) = S_OK then
begin
// return active project of group
Result := ProjGrp.GetActiveProject;
Exit;
end;
end;
end;
function TPoCustomFormWizard.GetUnnamed: Boolean;
begin
Result := True;
end;
{ TPoCustomFormWizard.IOTAModuleCreator }
function TPoCustomFormWizard.GetAncestorName: string;
begin
Result := 'TPoCustomForm';
end;
function TPoCustomFormWizard.GetImplFileName: string;
var
CurrDir: array[0..MAX_PATH] of Char;
begin
// Note: full path name required!
GetCurrentDirectory(SizeOf(CurrDir), CurrDir);
Result := Format('%s\%s.pas', [CurrDir, FUnitIdent, '.pas']);
end;
function TPoCustomFormWizard.GetIntfFileName: string;
begin
Result := '';
end;
function TPoCustomFormWizard.GetFormName: string;
begin
Result := FClassName;
end;
function TPoCustomFormWizard.GetMainForm: Boolean;
begin
Result := False;
end;
function TPoCustomFormWizard.GetShowForm: Boolean;
begin
Result := True;
end;
function TPoCustomFormWizard.GetShowSource: Boolean;
begin
Result := True;
end;
function TPoCustomFormWizard.NewFormFile(const FormIdent,
AncestorIdent: string): IOTAFile;
begin
Result := TFormFile.Create('', FormIdent, AncestorIdent);
end;
function TPoCustomFormWizard.NewImplSource(const ModuleIdent, FormIdent,
AncestorIdent: string): IOTAFile;
begin
Result := TUnitFile.Create(ModuleIdent, FormIdent, AncestorIdent);
end;
function TPoCustomFormWizard.NewIntfSource(const ModuleIdent, FormIdent,
AncestorIdent: string): IOTAFile;
begin
Result := nil;
end;
procedure TPoCustomFormWizard.FormCreated(const FormEditor: IOTAFormEditor);
begin
// do nothing
end;
end.
A complete Repository Wizard (with custom form) is demonstrated in Bruno Fierens' whitepaper, which you can get from here: http://forms.embarcadero.com/forms/AMUSCA1104BrunoFierensOTAPIWhitepaper through Embarcadero.
The reason I'm giving you the link as opposed to just the answer is that I've noticed more than one issue with your code, you will benefit from reading through the whitepaper! It won't take you long, the demo applications come with it, and it will not only solve this one problem, but most issues you may face when playing with the OTAPI.