Determine if string not contain number - delphi

I need a little help with a function. What I need to do is determine, if a string contains a number or not. If yes, I need only a number from the string, if not I need a whole word from it.
For example:
If my string is 'xyz 60', I need '60' from it, but if the string is 'xyz', I need the whole string:
function TForm1.FindNumberInString(InString: string): TNumberInString;
var
i, j: Integer;
ST: String;
begin
Result.TNumber := '';
Result.TIsNumber := False;
for i := 1 to Length(InString) do
begin
if (InString[i] in ['0'..'9']) then
begin
Result.TNumber := Result.TNumber + InString[i];
Result.TIsNumber := True;
end else
Result.TNumber := InString;
end;
end;
// TNumberInString is a packed record
TNumberInString = Packed Record
TNumber: string;
TIsNumber: boolean;
end;
Anyone can help what will be the problem? The Result is always 'xyz60', not '60'. I tried "if not (InString[i] in...), but it did not work, too.

Try something more like this instead:
function TForm1.FindNumberInString(InString: string): TNumberInString;
var
i, j: Integer;
begin
Result.TNumber := InString;
Result.TIsNumber := False;
for i := 1 to Length(InString) do
begin
if InString[i] in ['0'..'9'] then
begin
Result.TNumber := InString[i];
Result.TIsNumber := True;
For j := i+1 to Length(InString) do
begin
if not (InString[i] in ['0'..'9']) then
Break;
Result.TNumber := Result.TNumber + InString[j];
end;
Exit;
end;
end;
end;

I would use a Regular Expressions, and extend your record with a constructor
uses
RegularExpressions;
{$R *.dfm}
type
TNumberInString = Packed Record
TNumber: string;
TIsNumber: Boolean;
constructor Create(const Value: String);
end;
{ TNumberInString }
constructor TNumberInString.Create(const Value: String);
var
Match: TMatch;
begin
Match := TRegEx.Create('\d+').Match(Value);
TIsNumber := Match.Success;
if TIsNumber then
TNumber := Match.Value
else
TNumber := Value;
end;
Then only thing left is to call it:
procedure TForm30.FormCreate(Sender: TObject);
begin
Memo1.Lines.Clear;
Memo1.Lines.Add(TNumberInString.Create('XYZ').TNumber);
Memo1.Lines.Add(TNumberInString.Create('XYZ60').TNumber);
Memo1.Lines.Add(TNumberInString.Create('XYZ 60').TNumber);
end;
And show the result:

Related

Read and Write registry entry of type REG_MULTI_SZ using Delphi

Delphi offers the library System.Win.Registry to manipulate the windows registry.
Unfortunately it doesn't contain read/write procedures for the registry datatype REG_MULTI_SZ (=list of strings).
The following code returns an ERegistryException with "invalid datatype" - it seems only to work with datatype REG_SZ:
Registry := TRegistry.Create;
Registry.RootKey := HKEY_LOCAL_MACHINE;
Registry.OpenKey(cKey, false);
sValue := Registry.ReadString('MyRegEntry');
Meanwhile I am able to read the REG_MULTI_SZ value with
Registry.ReadBinaryData('MyRegEntry', pBuf, sizeof(pBuf));
but if I write it back using WriteBinaryData() it will be written to the registry as datatype REG_BINARY instead of REG_MULTI_SZ. So that's not working properly.
How can I manipulate registry data of datatype REG_MULTI_SZ using Delphi?
I have written two functions (a class helper) to extend the functionality of TRegistry:
unit Common.RegistryHelper;
interface
uses
System.Classes, System.Win.Registry, Winapi.Windows, System.Math;
type
TRegistryHelper = class helper for TRegistry
public
function ReadMultiSz(const name: string; var Strings: TStrings): boolean;
function WriteMultiSz(const name: string; const value: TStrings): boolean;
end;
implementation
function TRegistryHelper.ReadMultiSz(const name: string; var Strings: TStrings): boolean;
var
iSizeInByte: integer;
Buffer: array of WChar;
iWCharsInBuffer: integer;
z: integer;
sString: string;
begin
iSizeInByte := GetDataSize(name);
if iSizeInByte > 0 then begin
SetLength(Buffer, Floor(iSizeInByte / sizeof(WChar)));
iWCharsInBuffer := Floor(ReadBinaryData(name, Buffer[0],
iSizeInByte) / sizeof(WChar));
sString := '';
for z := 0 to iWCharsInBuffer do begin
if Buffer[z] <> #0 then begin
sString := sString + Buffer[z];
end else begin
if sString <> '' then begin
Strings.Append(sString);
sString := '';
end;
end;
end;
result := true;
end else begin
result := false;
end;
end;
function TRegistryHelper.WriteMultiSz(const name: string; const value: TStrings): boolean;
var
sContent: string;
x: integer;
begin
sContent := '';
for x := 0 to pred(value.Count) do begin
sContent := sContent + value.Strings[x] + #0;
end;
sContent := sContent + #0;
result := RegSetValueEx(CurrentKey, pchar(name), 0, REG_MULTI_SZ,
pointer(sContent), Length(sContent)*sizeof(Char)) = 0;
end;
end.
Using the functions above you can simply write in your program the following code to add a value to a REG_MULTI_SZ entry:
procedure AddValueToRegistry();
const
cKey = '\SYSTEM\ControlSet001\services\TcSysSrv';
var
Registry: TRegistry;
MyList: TStrings;
begin
Registry := TRegistry.Create;
Registry.RootKey := HKEY_LOCAL_MACHINE;
Registry.OpenKey(cKey, false);
try
MyList := TStringList.Create();
Registry.ReadMultiSz('MyRegEntry', MyList);
MyList.Add('NewEntry');
Registry.WriteMultiSz('MyRegEntry', MyList);
finally
MyList.Free;
end;
Registry.Free;
end;

How capture the active url based in a substring without repetition?

I want capture the url of active window based in a substring and add to Memo only if sActiveURL is different of sOldURL.
The trouble in my code is that always is added to Memo the same url ignoring the verification if sActiveURL <> sOldURL.
How fix this?
Main:
type
TForm1 = class(TForm)
tmr1: TTimer;
mmo1: TMemo;
procedure tmr1Timer(Sender: TObject);
private
{ Private declarations }
sActiveURL,sOldURL : string;
public
{ Public declarations }
end;
var
Form1: TForm1;
Flag: Boolean;
implementation
uses
UIAutomationClient_TLB, Activex, StrUtils;
{$R *.dfm}
function GetURL(hTargetWnd: HWND): string;
function Enumerar(pParent: IUIAutomationElement; Scope: TreeScope; pCondition: IUIAutomationCondition): String;
var
found : IUIAutomationElementArray;
ALen : Integer;
i : Integer;
iElement : IUIAutomationElement;
retorno: integer;
value : WideString;
iInter: IInterface;
ValPattern : IUIAutomationValuePattern;
begin
Result := '';
Flag := false;
if pParent = nil then
Exit;
pParent.FindAll(Scope, pCondition, found);
found.Get_Length(ALen);
for i := 1 to ALen - 1 do
begin
found.GetElement(i, iElement);
iElement.Get_CurrentControlType(retorno);
if (
(retorno = UIA_EditControlTypeId) or
(retorno = UIA_GroupControlTypeId)
) then
begin
iElement.GetCurrentPattern(UIA_ValuePatternId, iInter);
if Assigned(iInter) then
begin
if iInter.QueryInterface(IID_IUIAutomationValuePattern, ValPattern) = S_OK then
begin
ValPattern.Get_CurrentValue(value);
Result := trim(value);
Flag := true;
Break;
end;
end;
end;
if not Flag then
begin
Result := Enumerar(iElement, Scope, pCondition);
end;
end;
end;
var
UIAuto : IUIAutomation;
Ret : Integer;
RootElement : IUIAutomationElement;
Scope : TreeScope;
varProp : OleVariant;
pCondition : IUIAutomationCondition;
begin
Result := '';
try
UIAuto := CoCUIAutomation.Create;
if Succeeded(UIAuto.ElementFromHandle(hTargetWnd, RootElement)) then
begin
TVariantArg(varProp).vt := VT_BOOL;
TVariantArg(varProp).vbool := True;
UIAuto.CreatePropertyCondition(UIA_IsControlElementPropertyId,
varProp,
pCondition);
Scope := TreeScope_Element or TreeScope_Children;
Result := Enumerar(RootElement, Scope, pCondition);
end;
except
Result := '';
end;
end;
procedure TForm1.tmr1Timer(Sender: TObject);
begin
sActiveURL := GetURL(GetForegroundWindow);
if sActiveURL <> sOldURL then
begin
if AnsiContainsText(sActiveURL, 'stackoverflow.com') then
begin
sOldURL := sActiveURL;
mmo1.Lines.Add('['+sActiveURL+']<'+DateToStr(Date)+'>');
end;
end;
end;
UIAutomationClient_TLB.pas
EDITION:
On debug i discovered that none value is attrib to sOldURL variable.
procedure TForm1.tmr1Timer(Sender: TObject);
var
sActiveURL,sOldURL : string;
begin
sActiveURL := GetURL(GetForegroundWindow);
mmo1.Lines.Add('[sOldURL = '+sOldURL+' ]');
mmo1.Lines.Add('[sActiveURL = '+sActiveURL+' ]');
mmo1.Lines.Add('');
if sActiveURL <> sOldURL then
begin
if AnsiContainsText(sActiveURL, 'stackoverflow.com') then
begin
sOldURL := sActiveURL;
mmo1.Lines.Add(sActiveURL);
mmo1.Lines.Add('');
mmo1.Lines.Add('');
end;
end;
end;
The reason is as I shortly described in comments and is visible when the focused window is not your browser, for example your applications wiindow with the mmo1: TMemo:
GetForegroundWindow() returns the window that has focus.
Your GetURL(GetForegroundWindow) searches for an edit control (UIA_EditControlTypeId), of the focused window, and finds your memo control and returns the content of the memo.
Further, if you change focus to your browser, its URL will be correctly recorded in the memo, and if you return focus to your application, the condition if AnsiContainsText(sActiveURL, 'stackoverflow.com') will be true.
You then write to the memo, adding what you think is a real URL, and then this will be repeated for every timer event.
You need to only check the real browser window (skip all other) for its current URL. Try this, if you are using IE, otherwise you must modify FindWindow():
procedure TForm24.tmr1Timer(Sender: TObject);
var //
hIEWnd: HWND; //
begin
hIEWnd := FindWindow('IEFrame', nil); //
sActiveURL := GetURL(hIEWnd); //
// sActiveURL := GetURL(GetForegroundWindow);
if sActiveURL <> sOldURL then
begin
if AnsiContainsText(sActiveURL, 'stackoverflow.com') then
begin
sOldURL := sActiveURL;
mmo1.Lines.Add('[' + sActiveURL + ']<' + DateToStr(Date) + '>');
end;
end;
end;
Modified lines are marked with //

How to sort stringlist with comments

I have stringlist with comments (like Ini file section content):
;comment c
c=str1
;comment b
b=str2
;comment a
a=str3
Any ideas how to sort this list by names to:
;comment a
a=str3
;comment b
b=str2
;comment c
c=str1
Comment for pair should be linked with pair during sorting
One option would be to parse the TStringList content into a second list that separates and groups the name, value, and comment strings together, then sort that list on the names as needed, then repopulate the TStringList with the sorted groups. For example:
uses
...
System.Classes,
System.SysUtils,
System.Generics.Defaults,
System.Generics.Collections,
System.StrUtils,
System.Types;
type
ItemInfo = record
LeadingText,
Name,
Value: string;
end;
ItemInfoComparer = class(TComparer<ItemInfo>)
public
function Compare(const Left, Right: ItemInfo): Integer; override;
end;
function ItemInfoComparer.Compare(const Left, Right: ItemInfo): Integer;
begin
if (Left.Name <> '') and (Right.Name <> '') then
Result := AnsiCompareStr(Left.Name, Right.Name)
else if (Left.Name <> '') then
Result := -1
else
Result := 1;
end;
procedure SortMyList(List: TStringList);
var
Compare: IComparer<ItemInfo>;
Items: TList<ItemInfo>;
Info: ItemInfo;
I: Integer;
InText: Boolean;
S: String;
begin
Compare := ItemInfoComparer.Create;
Items := TList<ItemInfo>.Create(Compare);
try
Items.Capacity := List.Count;
InText := False;
for I := 0 to List.Count-1 do
begin
S := Trim(List[i]);
if (S = '') or (S[1] = ';') then
begin
if InText then
Info.LeadingText := Info.LeadingText + #13 + List[i]
else
begin
Info.LeadingText := List[i];
InText := True;
end;
end else
begin
Info.Name := List.Names[I];
Info.Value := List.ValueFromIndex[I];
Items.Add(Info);
Info := Default(ItemInfo);
InText := False;
end;
end;
if InText then
Items.Add(Info);
Items.Sort;
List.Clear;
for I := 0 to Items.Count-1 do
begin
Info := Items[I];
if Info.LeadingText <> '' then
begin
for S in SplitString(Info.LeadingText, #13) do
List.Add(S);
end;
if Info.Name <> '' then
List.Add(Info.Name + '=' + Info.Value);
end;
finally
Items.Free;
end;
end;
Here is a simple procedure that will sort and also deal with spaces as cargo. I also added code to handle comments at the end of the file.
This will work with older versions of Delphi that do not have generics or advanced types as in Remy's answer (provided as convenience for those using older versions)
function SortKeys(List: TStringList; Index1, Index2: Integer): Integer;
begin
result := CompareText(List.Names[Index1], List.Names[Index2]);
end;
Procedure SortStringListWithComments(AStrings: TStrings);
var
LCargoText: TStringList;
LSortedText : TStringList;
s: string;
i : integer;
begin
LCargoText := nil;
LSortedText := TStringList.Create;
try
for i := 0 to AStrings.count-1 do
begin
s := Trim(AStrings[i]);
if (s='') or (s[1] = ';') then //LCargoText and blank lines attached to sorted strings (Boolean short circuit assumed here)
begin
if LCargoText = nil then
LCargoText := TStringList.Create;
LCargoText.Add(AStrings[i]);
end
else
begin
LSortedText.AddObject(AStrings[i], LCargoText);
LCargoText := nil; //set nil to deal with cases where we have no comments for a following key value pair
end;
end;
LSortedText.CustomSort(SortKeys);
// LSortedText.sort - will cause a1=x to be sorted before a=x
AStrings.clear;
for i := 0 to LSortedText.count-1 do
begin
if LSortedText.objects[i] <> nil then
begin
AStrings.AddStrings(TStringList(LSortedText.Objects[i]));
LSortedText.Objects[i].Free;
end;
AStrings.Add(LSortedText[i]);
end;
if LCargoText <> nil then
begin
AStrings.AddStrings(LCargoText) ; //comments orphaned at the end of the file
LCargoText.Free;
end;
finally
LSortedText.Free;
end;
end;

How do I cast a TObject as a TObjectList<T>?

I have a procedure that needs to insert an array of TObjects into to a list. The list can be of any of the supported types, e.g. TObjectList, TObjectList<T>, TROArray, etc.
The procedure looks like this:
type
TObjectArray = Array of TObject;
...
procedure TMyClass.DoAssignObjectList(const ObjectArray: TObjectArray;
const DstList: TObject);
var
i: Integer;
begin
if DstList is TObjectList then
begin
for i := 0 to pred(TObjectList(DstList).Count) do
TObjectList(DstList).Add(ObjectArray[i]);
end else
if DstList is TObjectList<T> then // Obviously this doesn't work
begin
for i := 0 to pred(TObjectList<T>(DstList).Count) do
TObjectList<T>(DstList).Add(ObjectArray[i]);
end
else
begin
raise Exception.CreateFmt(StrNoDoAssignORMObject, [DstList.ClassName]);
end;
end;
How can I check that an object is a TObjectList<T> and then add the elements of an array to it?
You have to use a bit RTTI to get some more information about the generic type.
The following code uses Spring4D which has some methods for that:
uses
...
Spring.Reflection;
procedure DoAssignObjectList(const ObjectArray: TObjectArray;
const DstList: TObject);
function IsGenericTObjectList(const obj: TObject): Boolean;
var
t: TRttiType;
begin
t := TType.GetType(obj.ClassInfo);
Result := t.IsGenericType and (t.GetGenericTypeDefinition = 'TObjectList<>');
end;
begin
...
if IsGenericTObjectList(DstList) then
begin
for i := 0 to pred(TObjectList<TObject>(DstList).Count) do
TObjectList<TObject>(DstList).Add(ObjectArray[i]);
...
end;
Additionally to that you can also get information about the generic parameter type of the list to check if the objects you are putting into it are matching the requirements (only works on a generic type of course):
function GetGenericTObjectListParameter(const obj: TObject): TClass;
var
t: TRttiType;
begin
t := TType.GetType(obj.ClassInfo);
Result := t.GetGenericArguments[0].AsInstance.MetaclassType;
end;
As I was writing this question I figured out a way to do this using RTTI. It should work with any list that has a procedure Add(AObject: TObject).
procedure TransferArrayItems(const Instance: TObject;
const ObjectArray: TObjectArray);
const
AddMethodName = 'Add';
var
Found: Boolean;
LMethod: TRttiMethod;
LIndex: Integer;
LParams: TArray<TRttiParameter>;
i: Integer;
RTTIContext: TRttiContext;
RttiType: TRttiType;
begin
Found := False;
LMethod := nil;
if length(ObjectArray) > 0 then
begin
RTTIContext := TRttiContext.Create;
RttiType := RTTIContext.GetType(Instance.ClassInfo);
for LMethod in RttiType.GetMethods do
begin
if SameText(LMethod.Name, AddMethodName) then
begin
LParams := LMethod.GetParameters;
if length(LParams) = 1 then
begin
Found := TRUE;
for LIndex := 0 to length(LParams) - 1 do
begin
if LParams[LIndex].ParamType.Handle <> TValue(ObjectArray[0]).TypeInfo
then
begin
Found := False;
Break;
end;
end;
end;
if Found then
Break;
end;
end;
if Found then
begin
for i := Low(ObjectArray) to High(ObjectArray) do
begin
LMethod.Invoke(Instance, [ObjectArray[i]]);
end;
end
else
begin
raise Exception.CreateFmt(StrMethodSNotFound, [AddMethodName]);
end;
end;
end;

How to "scan" the full list of currently-installed VCL components

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.

Resources