Is there some built-in Delphi (XE2)/Windows method to convert month names to numbers 1-12; instead of looping through (TFormatSettings.)LongMonthNames[] myself?
You can use IndexStr from StrUtils, returns -1 if string not found e.g.
Caption := IntToStr(
IndexStr(FormatSettings.LongMonthNames[7], FormatSettings.LongMonthNames) + 1);
EDIT:
To avoid problems with casting and case sensitivity you might use IndexText as shown:
Function GetMonthNumber(Const Month:String):Integer; overload;
begin
Result := IndexText(Month,FormatSettings.LongMonthNames)+1
end;
i can't find a method but i write one. ;-)
function GetMonthNumberofName(AMonth: String): Integer;
var
intLoop: Integer;
begin
Result:= -1;
if (not AMonth.IsEmpty) then
begin
for intLoop := Low(System.SysUtils.FormatSettings.LongMonthNames) to High(System.SysUtils.FormatSettings.LongMonthNames) do
begin
//if System.SysUtils.FormatSettings.LongMonthNames[intLoop]=AMonth then --> see comment about Case insensitive
if SameText(System.SysUtils.FormatSettings.LongMonthNames[intLoop], AMonth) then
begin
Result:= Intloop;
Exit
end;
end;
end;
end;
Ok, I change this function for other FormatSettings.
function GetMonthNumberofName(AMonth: String): Integer; overload;
function GetMonthNumberofName(AMonth: String; AFormatSettings: TFormatSettings): Integer; overload;
function GetMonthNumberofName(AMonth: String): Integer;
begin
Result:= GetMonthNumberofName(AMonth, System.SysUtils.FormatSettings);
end;
function GetMonthNumberofName(AMonth: String; AFormatSettings: TFormatSettings): Integer;
var
intLoop: Integer;
begin
Result:= -1;
if (not AMonth.IsEmpty) then
begin
for intLoop := Low(AFormatSettings.LongMonthNames) to High(AFormatSettings.LongMonthNames) do
begin
if SameText(AFormatSettings.LongMonthNames[intLoop], AMonth) then
begin
Result:= Intloop;
Exit
end;
end;
end;
end;
Call the function with the system formatsetting
GetMonthNumberofName('may');
or with FormatSetting
procedure TForm1.Button4Click(Sender: TObject);
var
iMonth: Integer;
oSettings:TFormatSettings;
begin
// Ned
// oSettings:= TFormatSettings.Create(2067);
// Fr
// oSettings:= TFormatSettings.Create(1036);
// Eng
oSettings:= TFormatSettings.Create(2057);
iMonth:= GetMonthNumberofName(self.Edit1.Text, oSettings);
showmessage(IntToStr(iMonth));
end;
Related
I'm hooking GetWindowThreadProcessId() with sucess using the following code.
Now i want check if dwProcessID parameter corresponds to id of determinated process and in positive case prevent execute original function:
Result := OldGetWindowThreadProcessId(hWnd, dwProcessID);
I tried this, but not worked:
if dwProcessID = 12345 then exit;
Here is my complete code:
library MyLIB;
uses
Windows,
ImageHlp;
{$R *.res}
type
PGetWindowThreadProcessId = function(hWnd: THandle; dwProcessID: DWord)
: DWord; stdcall;
var
OldGetWindowThreadProcessId: PGetWindowThreadProcessId;
function HookGetWindowThreadProcessId(hWnd: THandle; dwProcessID: DWord)
: DWord; stdcall;
begin
try
// Check if is some process
except
MessageBox(0, 'Error', 'HookGetWindowThreadProcessId Error', 0);
end;
Result := OldGetWindowThreadProcessId(hWnd, dwProcessID);
end;
procedure PatchIAT(strMod: PAnsichar; Alt, Neu: Pointer);
var
pImportDir: pImage_Import_Descriptor;
size: CardinaL;
Base: CardinaL;
pThunk: PDWORD;
begin
Base := GetModuleHandle(nil);
pImportDir := ImageDirectoryEntryToData(Pointer(Base), True,
IMAGE_DIRECTORY_ENTRY_IMPORT, size);
while pImportDir^.Name <> 0 Do
begin
If (lstrcmpiA(PAnsichar(pImportDir^.Name + Base), strMod) = 0) then
begin
pThunk := PDWORD(Base + pImportDir^.FirstThunk);
While pThunk^ <> 0 Do
begin
if DWord(Alt) = pThunk^ Then
begin
pThunk^ := CardinaL(Neu);
end;
Inc(pThunk);
end;
end;
Inc(pImportDir);
end;
end;
procedure DllMain(reason: Integer);
begin
case reason of
DLL_PROCESS_ATTACH:
begin
OldGetWindowThreadProcessId := GetProcAddress(GetModuleHandle(user32),
'GetWindowThreadProcessId');
PatchIAT(user32, GetProcAddress(GetModuleHandle(user32),
'GetWindowThreadProcessId'), #HookGetWindowThreadProcessId);
end;
DLL_PROCESS_DETACH:
begin
end;
end;
end;
begin
DllProc := #DllMain;
DllProc(DLL_PROCESS_ATTACH);
end.
Your PGetWindowThreadProcessId type and HookGetWindowThreadProcessId() function are both declaring the dwProcessID parameter incorrectly. It is an output parameter, so it needs to be declared as either var dwProcessID: DWord or as dwProcessID: PDWord.
And then you need to call OldGetWindowThreadProcessId() to retrieve the actual PID before you can then compare it to anything. So your requirement of "in positive case prevent execute original function" is not realistic, because you need to execute the original function in order to determine the dwProcessID value to compare with.
Try this instead:
type
PGetWindowThreadProcessId = function(hWnd: THandle; var dwProcessID: DWord): DWord; stdcall;
...
function HookGetWindowThreadProcessId(hWnd: THandle; var dwProcessID: DWord): DWord; stdcall;
begin
Result := OldGetWindowThreadProcessId(hWnd, dwProcessID);
try
if dwProcessID = ... then
...
except
MessageBox(0, 'Error', 'HookGetWindowThreadProcessId Error', 0);
end;
end;
I have a working debugger visualizer that helps visualize variables of type TIntTime.
TIntTime = type integer;
The visualizer replaces a number of seconds since midnight with a time string HH:MM:SS. This works fine on variables of type TIntTime during a debug session, but not on functions. For example if I place GetiTime in a watch
function GetiTime: TIntTime;
begin
Result:=30000;
end;
the watch will show 30000. The expected replaced value is '08:20:00'. The visualizer does not intercept function return values of type TIntTime and this is the problem.
I am using Delphi 10 Seattle. My visualizer is based on DateTimeVisualizer.pas found in Delphi 10\source\Visualizers. The DateTimeVisualizer suggests that function return values are intercepted by using the type name string 'function: TIntTime' in GetSupportedType. I have tried
'function: TIntTime'
'function:TIntTime'
'function::TIntTime'
without luck. I suspect it is a question of getting this type name string correct, but haven't been able to find information about the formatting on the internet.
If I instead place GetDateTime in a watch it shows '14-02-2018 13:20:30' as expected. If I switch the TDateTime/TDate/TTime visualizer off in options the watch shows 43145.5559... This tells me that it is possible to intercept function return values with a visualizer.
function GetDateTime: TDateTime;
begin
Result:=EncodeDateTime(2018,2,14,13,20,30,0);
end;
In my case it is not an option to use the TDateTime data type. So my question is: how can I get my visualizer to intercept function return values of type TIntTime?
Below is the source for the TIntTime visualizer
unit IntTimeVisualizer;
interface
procedure Register;
implementation
uses
Classes, Forms, SysUtils, ToolsAPI;
resourcestring
sIntTimeVisualizerName = 'TIntTime Visualizer for Delphi';
sIntTimeVisualizerDescription = 'Displays TIntTime instances in a human-readable time format rather than as an integer value';
type
TDebuggerIntTimeVisualizer = class(TInterfacedObject, IOTADebuggerVisualizer,
IOTADebuggerVisualizerValueReplacer, IOTAThreadNotifier, IOTAThreadNotifier160)
private
FCompleted: Boolean;
FDeferredResult: string;
public
{ IOTADebuggerVisualizer }
function GetSupportedTypeCount: Integer;
procedure GetSupportedType(Index: Integer; var TypeName: string;
var AllDescendants: Boolean);
function GetVisualizerIdentifier: string;
function GetVisualizerName: string;
function GetVisualizerDescription: string;
{ IOTADebuggerVisualizerValueReplacer }
function GetReplacementValue(const Expression, TypeName, EvalResult: string): string;
{ IOTAThreadNotifier }
procedure EvaluteComplete(const ExprStr: string; const ResultStr: string;
CanModify: Boolean; ResultAddress: Cardinal; ResultSize: Cardinal;
ReturnCode: Integer);
procedure ModifyComplete(const ExprStr: string; const ResultStr: string;
ReturnCode: Integer);
procedure ThreadNotify(Reason: TOTANotifyReason);
procedure AfterSave;
procedure BeforeSave;
procedure Destroyed;
procedure Modified;
{ IOTAThreadNotifier160 }
procedure EvaluateComplete(const ExprStr: string; const ResultStr: string;
CanModify: Boolean; ResultAddress: TOTAAddress; ResultSize: LongWord;
ReturnCode: Integer);
end;
TIntTimeType = (dttIntTime);
TIntTimeVisualizerType = record
TypeName: string;
TimeType: TIntTimeType;
end;
const
IntTimeVisualizerTypes: array[0..1] of TIntTimeVisualizerType =
(
(TypeName: 'TIntTime'; TimeType: dttIntTime;), //<-- This type is working fine
(TypeName: 'function: TIntTime'; TimeType: dttIntTime;) //<-- This type is not working
);
{ TDebuggerIntTimeVisualizer }
procedure TDebuggerIntTimeVisualizer.AfterSave;
begin
// don't care about this notification
end;
procedure TDebuggerIntTimeVisualizer.BeforeSave;
begin
// don't care about this notification
end;
procedure TDebuggerIntTimeVisualizer.Destroyed;
begin
// don't care about this notification
end;
procedure TDebuggerIntTimeVisualizer.Modified;
begin
// don't care about this notification
end;
procedure TDebuggerIntTimeVisualizer.ModifyComplete(const ExprStr,
ResultStr: string; ReturnCode: Integer);
begin
// don't care about this notification
end;
procedure TDebuggerIntTimeVisualizer.EvaluteComplete(const ExprStr,
ResultStr: string; CanModify: Boolean; ResultAddress, ResultSize: Cardinal;
ReturnCode: Integer);
begin
EvaluateComplete(ExprStr, ResultStr, CanModify, TOTAAddress(ResultAddress),
LongWord(ResultSize), ReturnCode);
end;
procedure TDebuggerIntTimeVisualizer.EvaluateComplete(const ExprStr,
ResultStr: string; CanModify: Boolean; ResultAddress: TOTAAddress; ResultSize: LongWord;
ReturnCode: Integer);
begin
FCompleted := True;
if ReturnCode = 0 then
FDeferredResult := ResultStr;
end;
procedure TDebuggerIntTimeVisualizer.ThreadNotify(Reason: TOTANotifyReason);
begin
// don't care about this notification
end;
function TDebuggerIntTimeVisualizer.GetReplacementValue(
const Expression, TypeName, EvalResult: string): string;
var
TimeType: TIntTimeType;
I: Integer;
function IntTimeToStr(s: Integer): string;
var
hh, mm, ss: integer;
begin
hh:=s div 3600;
mm:=(s div 60)-hh*60;
ss:=s mod 60;
Result:=Format('%.2d:%.2d:%.2d',[hh,mm,ss]);
end;
function FormatResult(const LEvalResult: string; DTType: TIntTimeType; out ResStr: string): Boolean;
var
IntValue: integer;
begin
Result := True;
try
if not TryStrToInt(LEvalResult, IntValue) then
Result:=false
else
case DTType of
dttIntTime: ResStr:=IntTimeToStr(IntValue);
end;
except
Result := False;
end;
end;
begin
TimeType := TIntTimeType(-1);
for I := Low(IntTimeVisualizerTypes) to High(IntTimeVisualizerTypes) do begin
if TypeName = IntTimeVisualizerTypes[I].TypeName then begin
TimeType:=IntTimeVisualizerTypes[I].TimeType;
Break;
end;
end;
if not FormatResult(EvalResult, TimeType, Result) then
Result := EvalResult;
end;
function TDebuggerIntTimeVisualizer.GetSupportedTypeCount: Integer;
begin
Result := Length(IntTimeVisualizerTypes);
end;
procedure TDebuggerIntTimeVisualizer.GetSupportedType(Index: Integer; var TypeName: string;
var AllDescendants: Boolean);
begin
AllDescendants := false;
TypeName := IntTimeVisualizerTypes[Index].TypeName;
end;
function TDebuggerIntTimeVisualizer.GetVisualizerDescription: string;
begin
Result := sIntTimeVisualizerDescription;
end;
function TDebuggerIntTimeVisualizer.GetVisualizerIdentifier: string;
begin
Result := ClassName;
end;
function TDebuggerIntTimeVisualizer.GetVisualizerName: string;
begin
Result := sIntTimeVisualizerName;
end;
var
IntTimeVis: IOTADebuggerVisualizer;
procedure Register;
begin
IntTimeVis:=TDebuggerIntTimeVisualizer.Create;
(BorlandIDEServices as IOTADebuggerServices).RegisterDebugVisualizer(IntTimeVis);
end;
procedure RemoveVisualizer;
var
DebuggerServices: IOTADebuggerServices;
begin
if Supports(BorlandIDEServices, IOTADebuggerServices, DebuggerServices) then begin
DebuggerServices.UnregisterDebugVisualizer(IntTimeVis);
IntTimeVis:=nil;
end;
end;
initialization
finalization
RemoveVisualizer;
end.
To read a index file in a specific format, I cooked the following piece of code without considering byte ordering:
unit uCBI;
interface
uses
SysUtils,
Classes,
Generics.Collections;
type
TIndexList = class
private
FIndexList:TList<Cardinal>;
FOwnedStream:Boolean;
FMemoryStream: TMemoryStream;
function GetCount: Integer;
protected
public
constructor Create(AStream:TMemoryStream; OwnedStream:Boolean=True);
destructor Destroy; override;
function Add(const Value: Cardinal): Integer;
procedure Clear;
procedure SaveToFile(AFileName:TFileName);
procedure LoadFromFile(AFileName:TFileName);
property Count: Integer read GetCount;
end;
implementation
{ TIndexList }
function TIndexList.Add(const Value: Cardinal): Integer;
begin
Result := FIndexList.Add(Value)
end;
procedure TIndexList.Clear;
begin
FIndexList.Clear;
end;
constructor TIndexList.Create(AStream: TMemoryStream; OwnedStream: Boolean);
begin
FMemoryStream := AStream;
FOwnedStream := OwnedStream;
FIndexList := TList<Cardinal>.Create;
end;
destructor TIndexList.Destroy;
begin
if (FOwnedStream and Assigned(FMemoryStream)) then
FMemoryStream.Free;
FIndexList.Free;
//
inherited;
end;
function TIndexList.GetCount: Integer;
begin
Result := FIndexList.Count;
end;
procedure TIndexList.LoadFromFile(AFileName: TFileName);
var
lMemoryStream:TMemoryStream;
lCount:Cardinal;
begin
lMemoryStream := TMemoryStream.Create;
try
lMemoryStream.LoadFromFile(AFileName);
lMemoryStream.ReadBuffer(lCount,SizeOf(Cardinal));
if (lCount = Cardinal((lMemoryStream.Size-1) div SizeOf(Cardinal))) then
begin
FMemoryStream.Clear;
lMemoryStream.Position :=0;
FMemoryStream.CopyFrom(lMemoryStream,lMemoryStream.Size)
end else
raise Exception.CreateFmt('Corrupted CBI file: %s',[ExtractFileName(AFileName)]);
finally
lMemoryStream.Free;
end;
end;
procedure TIndexList.SaveToFile(AFileName: TFileName);
var
lCount:Cardinal;
lItem:Cardinal;
begin
FMemoryStream.Clear;
lCount := FIndexList.Count;
FMemoryStream.WriteBuffer(lCount,SizeOf(Cardinal));
for lItem in FIndexList do
begin
FMemoryStream.WriteBuffer(lItem,SizeOf(Cardinal));
end;
//
FMemoryStream.SaveToFile(AFileName);
end;
end.
It tested it and seems to work well as needed. Great was my suprise when I pursue extensive tests with real sample file. In fact the legacy format was devised with Amiga computer with a different byte ordering.
My Question:
How can I fix it ?
I want to keep the code unchanged and wonder wether a decorated TMemorySream will do so that I can transparently switch between big endian and little endian.
To change 'endianness' of Cardinals you can use the following:
function EndianChange(Value: Cardinal): Cardinal;
var
A1: array [0..3] of Byte absolute Value;
A2: array [0..3] of Byte absolute Result;
I: Integer;
begin
for I:= 0 to 3 do begin
A2[I]:= A1[3 - I];
end;
end;
If you want to keep your code unchanged, you can write your own TMemoryStream descendant and override its Read and Write methods using the above function, like that:
function TMyMemoryStream.Read(var Buffer; Count: Integer): Longint;
var
P: PCardinal;
I, N: Integer;
begin
inherited;
P:= #Buffer;
Assert(Count and 3 = 0);
N:= Count shr 2;
while N > 0 do begin
P^:= EndianChange(P^);
Inc(P);
Dec(N);
end;
end;
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.
I still haven't found a truly satisfactory answer to this question, and am now considering rolling my own. I have ModelMaker and GExperts, and neither seems to load the comprehensive class-hierarchy I am looking for. As well, I don't think the folks at DevExpress will fork over the CDK code which compiles a full class list to inherit from... ;-)
SO...
If ALL I want to do is build a self-referencing table of all registered component classes (or even all classes including non-components, if that's just as easy/possible), what would be the best way to go about doing that?
Note: I don't really need property / method details; JUST a complete list of class names (and parent names) I can store to a table and put in a treeview. Anything beyond that, though, is more than welcome as bonus info. :-)
Update later:
One answer that shows up in my "recent" section on SO, but not here on the question (maybe they erased it?), was this:"u may want to take a look on code of Component Search, it may help you to enumrate all components installed." Is that code available? Is so, where is it hiding? Would be interesting to study.
Unfortunately, the code implementing the RegisterClass mechanism is hidden in Classes implementation section.
If you need this for getting the list of components installed in the IDE, you can write a design package, install it into the IDE and use IOTAPackageServices in ToolsAPI unit. This will give you the list of installed packages and their components.
Note: You'll have to add designide.dcp to your 'requires' clause to be able to use Delphi's internal units like ToolsAPI.
A bit more work but a more generic way would be to enumerate all loaded modules. You can call GetPackageInfo (SysUtils) on a package module to enumerate contained unit names and required packages. However this will not give you a list of classes contained in the package.
You could enumerate the package's list of exported functions (e.g. with TJclPeImage in the JCL) and search for those named like this:
#<unit_name>#<class_name>#
for example: '#System#TObject#'.
By calling GetProcAddress with the function name you get the TClass reference. From there you can walk the hierarchy using ClassParent. This way you can enumerate all classes in all packages loaded in a process running a Delphi executable compiled with runtime packages (Delphi IDE, too).
Another idea is to scan for type information which is on top of the list of exported functions so you can skip enumerating further. The type infos are exported with names starting with prefix '#$xp$'. Here's an example:
unit PackageUtils;
interface
uses
Windows, Classes, SysUtils, Contnrs, TypInfo;
type
TDelphiPackageList = class;
TDelphiPackage = class;
TDelphiProcess = class
private
FPackages: TDelphiPackageList;
function GetPackageCount: Integer;
function GetPackages(Index: Integer): TDelphiPackage;
public
constructor Create; virtual;
destructor Destroy; override;
procedure Clear; virtual;
function FindPackage(Handle: HMODULE): TDelphiPackage;
procedure Reload; virtual;
property PackageCount: Integer read GetPackageCount;
property Packages[Index: Integer]: TDelphiPackage read GetPackages;
end;
TDelphiPackageList = class(TObjectList)
protected
function GetItem(Index: Integer): TDelphiPackage;
procedure SetItem(Index: Integer; APackage: TDelphiPackage);
public
function Add(APackage: TDelphiPackage): Integer;
function Extract(APackage: TDelphiPackage): TDelphiPackage;
function Remove(APackage: TDelphiPackage): Integer;
function IndexOf(APackage: TDelphiPackage): Integer;
procedure Insert(Index: Integer; APackage: TDelphiPackage);
function First: TDelphiPackage;
function Last: TDelphiPackage;
property Items[Index: Integer]: TDelphiPackage read GetItem write SetItem; default;
end;
TDelphiPackage = class
private
FHandle: THandle;
FInfoTable: Pointer;
FTypeInfos: TList;
procedure CheckInfoTable;
procedure CheckTypeInfos;
function GetDescription: string;
function GetFileName: string;
function GetInfoName(NameType: TNameType; Index: Integer): string;
function GetShortName: string;
function GetTypeInfoCount(Kinds: TTypeKinds): Integer;
function GetTypeInfos(Kinds: TTypeKinds; Index: Integer): PTypeInfo;
public
constructor Create(AHandle: HMODULE; AInfoTable: Pointer = nil);
destructor Destroy; override;
property Description: string read GetDescription;
property FileName: string read GetFileName;
property Handle: THandle read FHandle;
property ShortName: string read GetShortName;
property TypeInfoCount[Kinds: TTypeKinds]: Integer read GetTypeInfoCount;
property TypeInfos[Kinds: TTypeKinds; Index: Integer]: PTypeInfo read GetTypeInfos;
end;
implementation
uses
RTLConsts, SysConst,
PSAPI, ImageHlp;
{ Package info structures copied from SysUtils.pas }
type
PPkgName = ^TPkgName;
TPkgName = packed record
HashCode: Byte;
Name: array[0..255] of Char;
end;
PUnitName = ^TUnitName;
TUnitName = packed record
Flags : Byte;
HashCode: Byte;
Name: array[0..255] of Char;
end;
PPackageInfoHeader = ^TPackageInfoHeader;
TPackageInfoHeader = packed record
Flags: Cardinal;
RequiresCount: Integer;
{Requires: array[0..9999] of TPkgName;
ContainsCount: Integer;
Contains: array[0..9999] of TUnitName;}
end;
TEnumModulesCallback = function (Module: HMODULE; Data: Pointer = nil): Boolean;
TEnumModulesProc = function (Callback: TEnumModulesCallback; Data: Pointer = nil): Boolean;
const
STypeInfoPrefix = '#$xp$';
var
EnumModules: TEnumModulesProc = nil;
function PackageInfoTable(Module: HMODULE): PPackageInfoHeader; forward;
function AddPackage(Module: HMODULE; Data: {TDelphiPackageList} Pointer): Boolean;
var
InfoTable: Pointer;
begin
Result := False;
if (Module <> HInstance) then
begin
InfoTable := PackageInfoTable(Module);
if Assigned(InfoTable) then
TDelphiPackageList(Data).Add(TDelphiPackage.Create(Module, InfoTable));
end;
end;
function GetPackageDescription(Module: HMODULE): string;
var
ResInfo: HRSRC;
ResData: HGLOBAL;
begin
Result := '';
ResInfo := FindResource(Module, 'DESCRIPTION', RT_RCDATA);
if ResInfo <> 0 then
begin
ResData := LoadResource(Module, ResInfo);
if ResData <> 0 then
try
Result := PWideChar(LockResource(ResData));
UnlockResource(ResData);
finally
FreeResource(ResData);
end;
end;
end;
function EnumModulesPS(Callback: TEnumModulesCallback; Data: Pointer = nil): Boolean;
var
ProcessHandle: THandle;
SizeNeeded: Cardinal;
P, ModuleHandle: PDWORD;
I: Integer;
begin
Result := False;
ProcessHandle := OpenProcess(PROCESS_QUERY_INFORMATION or PROCESS_VM_READ, False, GetCurrentProcessId);
if ProcessHandle = 0 then
RaiseLastOSError;
try
SizeNeeded := 0;
EnumProcessModules(ProcessHandle, nil, 0, SizeNeeded);
if SizeNeeded = 0 then
Exit;
P := AllocMem(SizeNeeded);
try
if EnumProcessModules(ProcessHandle, P, SizeNeeded, SizeNeeded) then
begin
ModuleHandle := P;
for I := 0 to SizeNeeded div SizeOf(DWORD) - 1 do
begin
if Callback(ModuleHandle^, Data) then
Exit;
Inc(ModuleHandle);
end;
Result := True;
end;
finally
FreeMem(P);
end;
finally
CloseHandle(ProcessHandle);
end;
end;
function EnumModulesTH(Callback: TEnumModulesCallback; Data: Pointer = nil): Boolean;
begin
Result := False;
// todo win9x?
end;
function PackageInfoTable(Module: HMODULE): PPackageInfoHeader;
var
ResInfo: HRSRC;
Data: THandle;
begin
Result := nil;
ResInfo := FindResource(Module, 'PACKAGEINFO', RT_RCDATA);
if ResInfo <> 0 then
begin
Data := LoadResource(Module, ResInfo);
if Data <> 0 then
try
Result := LockResource(Data);
UnlockResource(Data);
finally
FreeResource(Data);
end;
end;
end;
{ TDelphiProcess private }
function TDelphiProcess.GetPackageCount: Integer;
begin
Result := FPackages.Count;
end;
function TDelphiProcess.GetPackages(Index: Integer): TDelphiPackage;
begin
Result := FPackages[Index];
end;
{ TDelphiProcess public }
constructor TDelphiProcess.Create;
begin
inherited Create;
FPackages := TDelphiPackageList.Create;
Reload;
end;
destructor TDelphiProcess.Destroy;
begin
FPackages.Free;
inherited Destroy;
end;
procedure TDelphiProcess.Clear;
begin
FPackages.Clear;
end;
function TDelphiProcess.FindPackage(Handle: HMODULE): TDelphiPackage;
var
I: Integer;
begin
Result := nil;
for I := 0 to FPackages.Count - 1 do
if FPackages[I].Handle = Handle then
begin
Result := FPackages[I];
Break;
end;
end;
procedure TDelphiProcess.Reload;
begin
Clear;
if Assigned(EnumModules) then
EnumModules(AddPackage, FPackages);
end;
{ TDelphiPackageList protected }
function TDelphiPackageList.GetItem(Index: Integer): TDelphiPackage;
begin
Result := TDelphiPackage(inherited GetItem(Index));
end;
procedure TDelphiPackageList.SetItem(Index: Integer; APackage: TDelphiPackage);
begin
inherited SetItem(Index, APackage);
end;
{ TDelphiPackageList public }
function TDelphiPackageList.Add(APackage: TDelphiPackage): Integer;
begin
Result := inherited Add(APackage);
end;
function TDelphiPackageList.Extract(APackage: TDelphiPackage): TDelphiPackage;
begin
Result := TDelphiPackage(inherited Extract(APackage));
end;
function TDelphiPackageList.First: TDelphiPackage;
begin
Result := TDelphiPackage(inherited First);
end;
function TDelphiPackageList.IndexOf(APackage: TDelphiPackage): Integer;
begin
Result := inherited IndexOf(APackage);
end;
procedure TDelphiPackageList.Insert(Index: Integer; APackage: TDelphiPackage);
begin
inherited Insert(Index, APackage);
end;
function TDelphiPackageList.Last: TDelphiPackage;
begin
Result := TDelphiPackage(inherited Last);
end;
function TDelphiPackageList.Remove(APackage: TDelphiPackage): Integer;
begin
Result := inherited Remove(APackage);
end;
{ TDelphiPackage private }
procedure TDelphiPackage.CheckInfoTable;
begin
if not Assigned(FInfoTable) then
FInfoTable := PackageInfoTable(Handle);
if not Assigned(FInfoTable) then
raise EPackageError.CreateFmt(SCannotReadPackageInfo, [ExtractFileName(GetModuleName(Handle))]);
end;
procedure TDelphiPackage.CheckTypeInfos;
var
ExportDir: PImageExportDirectory;
Size: DWORD;
Names: PDWORD;
I: Integer;
begin
if not Assigned(FTypeInfos) then
begin
FTypeInfos := TList.Create;
try
Size := 0;
ExportDir := ImageDirectoryEntryToData(Pointer(Handle), True, IMAGE_DIRECTORY_ENTRY_EXPORT, Size);
if not Assigned(ExportDir) then
Exit;
Names := PDWORD(DWORD(Handle) + DWORD(ExportDir^.AddressOfNames));
for I := 0 to ExportDir^.NumberOfNames - 1 do
begin
if StrLIComp(PChar(DWORD(Handle) + Names^), STypeInfoPrefix, StrLen(STypeInfoPrefix)) <> 0 then
Break;
FTypeInfos.Add(GetProcAddress(Handle, PChar(DWORD(Handle) + Names^)));
Inc(Names);
end;
except
FreeAndNil(FTypeInfos);
raise;
end;
end;
end;
function TDelphiPackage.GetDescription: string;
begin
Result := GetPackageDescription(Handle);
end;
function TDelphiPackage.GetFileName: string;
begin
Result := GetModuleName(FHandle);
end;
function TDelphiPackage.GetInfoName(NameType: TNameType; Index: Integer): string;
var
P: Pointer;
Count: Integer;
I: Integer;
begin
Result := '';
CheckInfoTable;
Count := PPackageInfoHeader(FInfoTable)^.RequiresCount;
P := Pointer(Cardinal(FInfoTable) + SizeOf(TPackageInfoHeader));
case NameType of
ntContainsUnit:
begin
for I := 0 to Count - 1 do
P := Pointer(Cardinal(P) + StrLen(PPkgName(P)^.Name) + 2);
Count := Integer(P^);
P := Pointer(Cardinal(P) + SizeOf(Integer));
if (Index >= 0) and (Index < Count) then
begin
for I := 0 to Count - 1 do
P := Pointer(Cardinal(P) + StrLen(PUnitName(P)^.Name) + 3);
Result := PUnitName(P)^.Name;
end;
end;
ntRequiresPackage:
if (Index >= 0) and (Index < Count) then
begin
for I := 0 to Index - 1 do
P := Pointer(Cardinal(P) + StrLen(PPkgName(P)^.Name) + 2);
Result := PPkgName(P)^.Name;
end;
ntDcpBpiName:
if PPackageInfoHeader(FInfoTable)^.Flags and pfPackageModule <> 0 then
begin
for I := 0 to Count - 1 do
P := Pointer(Cardinal(P) + StrLen(PPkgName(P)^.Name) + 2);
Count := Integer(P^);
P := Pointer(Cardinal(P) + SizeOf(Integer));
for I := 0 to Count - 1 do
P := Pointer(Cardinal(P) + StrLen(PUnitName(P)^.Name) + 3);
Result := PPkgName(P)^.Name;
end;
end;
end;
function TDelphiPackage.GetShortName: string;
begin
Result := GetInfoName(ntDcpBpiName, 0);
end;
function TDelphiPackage.GetTypeInfoCount(Kinds: TTypeKinds): Integer;
var
I: Integer;
begin
CheckTypeInfos;
Result := 0;
for I := 0 to FTypeInfos.Count - 1 do
if (Kinds = []) or (PTypeInfo(FTypeInfos[I])^.Kind in Kinds) then
Inc(Result);
end;
function TDelphiPackage.GetTypeInfos(Kinds: TTypeKinds; Index: Integer): PTypeInfo;
var
I, J: Integer;
begin
CheckTypeInfos;
Result := nil;
J := -1;
for I := 0 to FTypeInfos.Count - 1 do
if (Kinds = []) or (PTypeInfo(FTypeInfos[I])^.Kind in Kinds) then
begin
Inc(J);
if J = Index then
begin
Result := FTypeInfos[I];
Break;
end;
end;
end;
{ TDelphiPackage public }
constructor TDelphiPackage.Create(AHandle: HMODULE; AInfoTable: Pointer = nil);
begin
inherited Create;
FHandle := AHandle;
FInfoTable := AInfoTable;
FTypeInfos := nil;
end;
destructor TDelphiPackage.Destroy;
begin
FTypeInfos.Free;
inherited Destroy;
end;
initialization
case Win32Platform of
VER_PLATFORM_WIN32_WINDOWS:
EnumModules := EnumModulesTH;
VER_PLATFORM_WIN32_NT:
EnumModules := EnumModulesPS;
else
EnumModules := nil;
end;
finalization
end.
Unit of the test design package installed in the IDE:
unit Test;
interface
uses
SysUtils, Classes,
ToolsAPI;
type
TTestWizard = class(TNotifierObject, IOTAWizard, IOTAMenuWizard)
private
{ IOTAWizard }
procedure Execute;
function GetIDString: string;
function GetName: string;
function GetState: TWizardState;
{ IOTAMenuWizard }
function GetMenuText: string;
end;
implementation
uses
TypInfo,
PackageUtils;
function AncestryStr(AClass: TClass): string;
begin
Result := '';
if not Assigned(AClass) then
Exit;
Result := AncestryStr(AClass.ClassParent);
if Result <> '' then
Result := Result + '\';
Result := Result + AClass.ClassName;
end;
procedure ShowMessage(const S: string);
begin
with BorlandIDEServices as IOTAMessageServices do
AddTitleMessage(S);
end;
{ TTestWizard }
procedure TTestWizard.Execute;
var
Process: TDelphiProcess;
I, J: Integer;
Package: TDelphiPackage;
PInfo: PTypeInfo;
PData: PTypeData;
begin
Process := TDelphiProcess.Create;
for I := 0 to Process.PackageCount - 1 do
begin
Package := Process.Packages[I];
for J := 0 to Package.TypeInfoCount[[tkClass]] - 1 do
begin
PInfo := Package.TypeInfos[[tkClass], J];
PData := GetTypeData(PInfo);
ShowMessage(Format('%s: %s.%s (%s)', [Package.ShortName, PData^.UnitName, PInfo^.Name, AncestryStr(PData^.ClassType)]));
end;
end;
end;
function TTestWizard.GetIDString: string;
begin
Result := 'TOndrej.TestWizard';
end;
function TTestWizard.GetName: string;
begin
Result := 'Test';
end;
function TTestWizard.GetState: TWizardState;
begin
Result := [wsEnabled];
end;
function TTestWizard.GetMenuText: string;
begin
Result := 'Test';
end;
var
Index: Integer = -1;
initialization
with BorlandIDEServices as IOTAWizardServices do
Index := AddWizard(TTestWizard.Create);
finalization
if Index <> -1 then
with BorlandIDEServices as IOTAWizardServices do
RemoveWizard(Index);
end.
You have to add designide to your requires clause. When you install this design package a new menu item Test should appear under Delphi's Help menu. Clicking it should display all loaded classes in the Messages window.
Have you tried Delphi's own class browser?
The browser gets loaded with shortcut CTRL-SHIFT-B. I believe you can access its options by right clicking in the browser. Here you have the option to show only the classes in your project or all known classes.
I haven't checked but I expect every descendant from TComponent, including installed components to be visible below the TComponent node. Use CTRL-F to search for a particular class.
Edit: according to this Delphi Wiki page, CTRL+SHIFT+B is only available in Delphi5. I don't have Delphi 2007 to check for this but if you can not find a class browser in your version, I'd suspect there isn't any.