Рассылка закрыта
При закрытии подписчики были переданы в рассылку "Сетевой адаптер: осваиваем Интернет" на которую и рекомендуем вам подписаться.
Вы можете найти рассылки сходной тематики в Каталоге рассылок.
Все, что вы не знали, но хотели бы узнать о Delphi №11
Выпуск №11 Раздел: Язык Программирования Delphi Подраздел: RTTI и другие трюки с информацией о классах, модулях и т.п. (часть 2) Уважаемый подписчик, О чем будет следующий раздел - решать вам. Варианты: VCL Системные функции и Winapi Базы данных Работа с файловой системой Репортинг, работа с принтером Работа с сетью, Интернетом, протоколами Работа с графикой, мультимедиа
Ваши предложения высылайте на В этом выпуске: Как сохранить
значние свойства в поток?
interface uses Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs, StdCtrls, Contnrs; type TStreamableObject = class(TPersistent) protected function ReadString(Stream: TStream): String; function ReadLongInt(Stream: TStream): LongInt; function ReadDateTime(Stream: TStream): TDateTime; function ReadCurrency(Stream: TStream): Currency; function ReadClassName(Stream: TStream): ShortString; procedure WriteString(Stream: TStream; const Value: String); procedure WriteLongInt(Stream: TStream; const Value: LongInt); procedure WriteDateTime(Stream: TStream; const Value: TDateTime); procedure WriteCurrency(Stream: TStream; const Value: Currency); procedure WriteClassName(Stream: TStream; const Value: ShortString); public constructor CreateFromStream(Stream: TStream); procedure LoadFromStream(Stream: TStream); virtual; abstract; procedure SaveToStream(Stream: TStream); virtual; abstract; end; TStreamableObjectClass = class of TStreamableObject; TPerson = class(TStreamableObject) private FName: String; FBirthDate: TDateTime; public constructor Create(const AName: string; ABirthDate: TDateTime); procedure LoadFromStream(Stream: TStream); override; procedure SaveToStream(Stream: TStream); override; property Name: String read FName write FName; property BirthDate: TDateTime read FBirthDate write FBirthDate; end; TCompany = class(TStreamableObject) private FName: String; FRevenues: Currency; FEmployeeCount: LongInt; public constructor Create(const AName: string; ARevenues: Currency; AEmployeeCount: LongInt); procedure LoadFromStream(Stream: TStream); override; procedure SaveToStream(Stream: TStream); override; property Name: String read FName write FName; property Revenues: Currency read FRevenues write FRevenues; property EmployeeCount: LongInt read FEmployeeCount write FEmployeeCount; end; TStreamableList = class(TStreamableObject) private FItems: TObjectList; function Get_Count: LongInt; function Get_Objects(Index: LongInt): TStreamableObject; public constructor Create; destructor Destroy; override; function FindClass(const AClassName: String): TStreamableObjectClass; procedure Add(Item: TStreamableObject); procedure Delete(Index: LongInt); procedure Clear; procedure LoadFromStream(Stream: TStream); override; procedure SaveToStream(Stream: TStream); override; property Objects[Index: LongInt]: TStreamableObject read Get_Objects; default; property Count: LongInt read Get_Count; end; TForm1 = class(TForm) SaveButton: TButton; LoadButton: TButton; procedure SaveButtonClick(Sender: TObject); procedure LoadButtonClick(Sender: TObject); procedure FormCreate(Sender: TObject); private { Private declarations } public Path: String; end; var Form1: TForm1; implementation {$R *.DFM} resourcestring DEFAULT_FILENAME = 'test.dat'; procedure TForm1.SaveButtonClick(Sender: TObject); var List: TStreamableList; Stream: TStream; begin List := TStreamableList.Create; try List.Add(TPerson.Create('Rick Rogers', StrToDate('05/20/68'))); List.Add(TCompany.Create('Fenestra', 1000000, 7)); Stream := TFileStream.Create(Path + DEFAULT_FILENAME, fmCreate); try List.SaveToStream(Stream); finally Stream.Free; end; finally List.Free; end; end; { TPerson } constructor TPerson.Create(const AName: string; ABirthDate: TDateTime); begin inherited Create; FName := AName; FBirthDate := ABirthDate; end; procedure TPerson.LoadFromStream(Stream: TStream); begin FName := ReadString(Stream); FBirthDate := ReadDateTime(Stream); end; procedure TPerson.SaveToStream(Stream: TStream); begin WriteString(Stream, FName); WriteDateTime(Stream, FBirthDate); end; { TStreamableList } procedure TStreamableList.Add(Item: TStreamableObject); begin FItems.Add(Item); end; procedure TStreamableList.Clear; begin FItems.Clear; end; constructor TStreamableList.Create; begin FItems := TObjectList.Create; end; procedure TStreamableList.Delete(Index: LongInt); begin FItems.Delete(Index); end; destructor TStreamableList.Destroy; begin FItems.Free; inherited; end; function TStreamableList.FindClass(const AClassName: String): TStreamableObjectClass; begin Result := TStreamableObjectClass(Classes.FindClass(AClassName)); end; function TStreamableList.Get_Count: LongInt; begin Result := FItems.Count; end; function TStreamableList.Get_Objects(Index: LongInt): TStreamableObject; begin Result := FItems[Index] as TStreamableObject; end; procedure TStreamableList.LoadFromStream(Stream: TStream); var StreamCount: LongInt; I: Integer; S: String; ClassRef: TStreamableObjectClass; begin StreamCount := ReadLongInt(Stream); for I := 0 to StreamCount - 1 do begin S := ReadClassName(Stream); ClassRef := FindClass(S); Add(ClassRef.CreateFromStream(Stream)); end; end; procedure TStreamableList.SaveToStream(Stream: TStream); var I: Integer; begin WriteLongInt(Stream, Count); for I := 0 to Count - 1 do begin WriteClassName(Stream, Objects[I].ClassName); Objects[I].SaveToStream(Stream); end; end; { TStreamableObject } constructor TStreamableObject.CreateFromStream(Stream: TStream); begin inherited Create; LoadFromStream(Stream); end; function TStreamableObject.ReadClassName(Stream: TStream): ShortString; begin Result := ReadString(Stream); end; function TStreamableObject.ReadCurrency(Stream: TStream): Currency; begin Stream.Read(Result, SizeOf(Currency)); end; function TStreamableObject.ReadDateTime(Stream: TStream): TDateTime; begin Stream.Read(Result, SizeOf(TDateTime)); end; function TStreamableObject.ReadLongInt(Stream: TStream): LongInt; begin Stream.Read(Result, SizeOf(LongInt)); end; function TStreamableObject.ReadString(Stream: TStream): String; var L: LongInt; begin L := ReadLongInt(Stream); SetLength(Result, L); Stream.Read(Result[1], L); end; procedure TStreamableObject.WriteClassName(Stream: TStream; const Value: ShortString); begin WriteString(Stream, Value); end; procedure TStreamableObject.WriteCurrency(Stream: TStream; const Value: Currency); begin Stream.Write(Value, SizeOf(Currency)); end; procedure TStreamableObject.WriteDateTime(Stream: TStream; const Value: TDateTime); begin Stream.Write(Value, SizeOf(TDateTime)); end; procedure TStreamableObject.WriteLongInt(Stream: TStream; const Value: LongInt); begin Stream.Write(Value, SizeOf(LongInt)); end; procedure TStreamableObject.WriteString(Stream: TStream; const Value: String); var L: LongInt; begin L := Length(Value); WriteLongInt(Stream, L); Stream.Write(Value[1], L); end; { TCompany } constructor TCompany.Create(const AName: string; ARevenues: Currency; AEmployeeCount: Integer); begin FName := AName; FRevenues := ARevenues; FEmployeeCount := AEmployeeCount; end; procedure TCompany.LoadFromStream(Stream: TStream); begin FName := ReadString(Stream); FRevenues := ReadCurrency(Stream); FEmployeeCount := ReadLongInt(Stream); end; procedure TCompany.SaveToStream(Stream: TStream); begin WriteString(Stream, FName); WriteCurrency(Stream, FRevenues); WriteLongInt(Stream, FEmployeeCount); end; procedure TForm1.LoadButtonClick(Sender: TObject); var List: TStreamableList; Stream: TStream; Instance: TStreamableObject; I: Integer; begin Stream := TFileStream.Create(Path + DEFAULT_FILENAME, fmOpenRead); try List := TStreamableList.Create; try List.LoadFromStream(Stream); for I := 0 to List.Count - 1 do begin Instance := List[I]; if Instance is TPerson then ShowMessage(TPerson(Instance).Name); if Instance is TCompany then ShowMessage(TCompany(Instance).Name); end; finally List.Free; end; finally Stream.Free; end; end; procedure TForm1.FormCreate(Sender: TObject); begin Path := ExtractFilePath(Application.ExeName); end; initialization RegisterClasses([TPerson, TCompany]); end. Tip by Rick Rogers Answer 2: The solution above will work, but it forces you to implement streaming support for each of the TStreamableObject objects. Delphi has already implemented this mechanism in for the TPersistent class and the TComponent class, and you can use this mechanism. The class I include here does the job. It holds classes that inherit from TUmbCollectionItem (which in turn inherits from Delphi TCollectionItem), and handles all the streaming of the items. As the items are written with the Delphi mechanism, all published data is streamed. Notes: This class does not support working within the delphi IDE like TCollection. All objects inheriting from TUmbCollectionItem must be registered using the Classes.RegisterClass function. All objects inheriting from TUmbCollectionItem must implement the assign function. By default, the TUmbCollection owns its items (frees them when the collection is freed), but this functionality can be changed. unit UmbCollection; interface uses Windows, Messages, SysUtils, Classes, contnrs; type TUmbCollectionItemClass = Class of TUmbCollectionItem; TUmbCollectionItem = class(TCollectionItem) private FPosition: Integer; public {when overriding this method, you must call the inherited assign.} procedure Assign(Source: TPersistent); Override; published {the position property is used by the streaming mechanism to place the object in the right position when reading the items. do not use this property.} property Position: Integer read FPosition write FPosition; end; TUmbCollection = class(TObjectList) private procedure SetItems(Index: Integer; Value: TUmbCollectionItem); function GetItems(Index: Integer): TUmbCollectionItem; public function Add(AObject: TUmbCollectionItem): Integer; function Remove(AObject: TUmbCollectionItem): Integer; function IndexOf(AObject: TUmbCollectionItem): Integer; function FindInstanceOf(AClass: TUmbCollectionItemClass; AExact: Boolean = True; AStartAt: Integer = 0): Integer; procedure Insert(Index: Integer; AObject: TUmbCollectionItem); procedure WriteToStream(AStream: TStream); virtual; procedure ReadFromStream(AStream: TStream); virtual; property Items[Index: Integer]: TUmbCollectionItem read GetItems write SetItems; default; published property OwnsObjects; end; implementation { TUmbCollection } function ItemsCompare(Item1, Item2: Pointer): Integer; begin Result := TUmbCollectionItem(Item1).Position - TUmbCollectionItem(Item2).Position; end; function TUmbCollection.Add(AObject: TUmbCollectionItem): Integer; begin Result := inherited Add(AObject); end; function TUmbCollection.FindInstanceOf(AClass: TUmbCollectionItemClass; AExact: Boolean; AStartAt: Integer): Integer; begin Result := inherited FindInstanceOf(AClass, AExact, AStartAt); end; function TUmbCollection.GetItems(Index: Integer): TUmbCollectionItem; begin Result := inherited Items[Index] as TUmbCollectionItem; end; function TUmbCollection.IndexOf(AObject: TUmbCollectionItem): Integer; begin Result := inherited IndexOf(AObject); end; procedure TUmbCollection.Insert(Index: Integer; AObject: TUmbCollectionItem); begin inherited Insert(Index, AObject); end; procedure TUmbCollection.ReadFromStream(AStream: TStream); var Reader: TReader; Collection: TCollection; ItemClassName: string; ItemClass: TUmbCollectionItemClass; Item: TUmbCollectionItem; i: Integer; begin Clear; Reader := TReader.Create(AStream, 1024); try Reader.ReadListBegin; while not Reader.EndOfList do begin ItemClassName := Reader.ReadString; ItemClass := TUmbCollectionItemClass(FindClass(ItemClassName)); Collection := TCollection.Create(ItemClass); try Reader.ReadValue; Reader.ReadCollection(Collection); for i := 0 to Collection.Count - 1 do begin item := ItemClass.Create(nil); item.Assign(Collection.Items[i]); Add(Item); end; finally Collection.Free; end; end; Sort(ItemsCompare); Reader.ReadListEnd; finally Reader.Free; end; end; function TUmbCollection.Remove(AObject: TUmbCollectionItem): Integer; begin Result := inherited Remove(AObject); end; procedure TUmbCollection.SetItems(Index: Integer; Value: TUmbCollectionItem); begin inherited Items[Index] := Value; end; procedure TUmbCollection.WriteToStream(AStream: TStream); var Writer: TWriter; CollectionList: TObjectList; Collection: TCollection; ItemClass: TUmbCollectionItemClass; ObjectWritten: array of Boolean; i, j: Integer; begin Writer := TWriter.Create(AStream, 1024); CollectionList := TObjectList.Create(True); try Writer.WriteListBegin; {init the flag array and the position property of the TCollectionItem objects.} SetLength(ObjectWritten, Count); for i := 0 to Count - 1 do begin ObjectWritten[i] := False; Items[i].Position := i; end; {write the TCollectionItem objects. we write first the name of the objects class, then write all the object of the same class.} for i := 0 to Count - 1 do begin if ObjectWritten[i] then Continue; ItemClass := TUmbCollectionItemClass(Items[i].ClassType); Collection := TCollection.Create(ItemClass); CollectionList.Add(Collection); {write the items class name} Writer.WriteString(Items[i].ClassName); {insert the items to the collection} for j := i to Count - 1 do if ItemClass = Items[j].ClassType then begin ObjectWritten[j] := True; (Collection.Add as ItemClass).Assign(Items[j]); end; {write the collection} Writer.WriteCollection(Collection); end; finally CollectionList.Free; Writer.WriteListEnd; Writer.Free; end; end; { TUmbCollectionItem } procedure TUmbCollectionItem.Assign(Source: TPersistent); begin if Source is TUmbCollectionItem then Position := (Source as TUmbCollectionItem).Position else inherited; end; end.
var PropInfo: PPropInfo; Method: TNotifyEvent; begin Result := False; PropInfo := GetPropInfo(Sender.ClassInfo, Event); if not Assigned(PropInfo) then Exit; if PropInfo.PropType^.Kind <> tkMethod then Exit; Method := TNotifyEvent(GetMethodProp(Sender, PropInfo)); Result := Assigned(Method); end;
var PInfo: PPropInfo; begin {Try to get a pointer to the property information for a property with the name 'Font'. TObject.ClassInfo returns a pointer to the RTTI table, which we need to pass to GetPropInfo} PInfo := GetPropInfo(anObj.ClassInfo, 'font'); Result := nil; if PInfo <> nil then {found a property with this name, check if it has the correct type} if (PInfo^.Proptype^.Kind = tkClass) and GetTypeData(PInfo^.Proptype^)^.ClassType.InheritsFrom(TFont) then Result := TFont(GetOrdProp(anObj, PInfo)); end;
Does anyone know if there is an easy way to load the value of a component's property directly from its resource without creating the component? Something like: if ReadPropertyValue('Form1.Button1', 'width') > 1000 then ShowMessage('You are about to create a big button!'); function TForm1.ReadProp(r: TReader): string; begin result := ''; {Determine the value type of the property, read it with the appropriate method of TReader and convert it to string. Not all value types are implemented here but you get the idea.} case r.NextValue of vaInt8, vaInt16, vaInt32: result := IntToStr(r.ReadInteger); vaExtended: result := FloatToStr(r.ReadFloat); vaString: result := r.ReadString; else r.SkipValue; {Not implemented} end; end; procedure TForm1.ReadRes(PropPath: string; r: TReader); var p: string; begin {Skip the class name} r.ReadStr; {Construct the property path} if PropPath = '' then p := r.ReadStr else p := PropPath + '.' + r.ReadStr; {Read all properties and its values and fill them into the memo} while not r.EndOfList do Memo1.Lines.Add(p + '.' + r.ReadStr + ' = ' + ReadProp(r)); {Skip over the end of the list of the properties of this component} r.CheckValue(vaNull); {Recursively read the properties of all sub-components} while not r.EndOfList do begin ReadRes(p, r); r.CheckValue(vaNull); end; end; procedure TForm1.Button1Click(Sender: TObject); var strm: TResourceStream; Reader: TReader; begin strm := TResourceStream.Create(HInstance, 'TForm1', RT_RCDATA); Reader := TReader.Create(strm, 1024); try Memo1.Clear; Reader.ReadSignature; ReadRes('', Reader); finally Reader.Free; strm.Free; end; end; Only one small problem. r.SkipValue was protected (in D5) but I hacked that out with the following code: type THackReader = class(TReader); { ... } THackReader(r).SkipValue;
{...} MyComponent2.{propertyN} := MyComponent2.{propertyN}; Is there a better and shorter way to do this? I tried this: MyComponent1 := MyComponent2; But it doesn't work. Why not? Can I point to the second component ? Answer 1: MyComponent2 and MyComponent1 are pointers to your components, and this kind of assigment leads to MyComponent1 pointing to MyComponent2. But it will not copy its property values. A better way is to override the assign method of your control, do all property assignment there and call it when you need to copy component attributes. Here's example: procedure TMyComponent.Assign(Source: TPersistent); begin if Source is TMyComponent then begin property1 := TMyComponent(Source).property1; { ... } end else inherited Assign(Source); end; To assign properties you'll need to set this line in the code: MyComponent1.Assign(MyComponent2); Tip by Serge Gubenko procedure EqualClassProperties(AClass1, AClass2: TObject); var PropList: PPropList; ClassTypeInfo: PTypeInfo; ClassTypeData: PTypeData; i: integer; NumProps: Integer; APersistent : TPersistent; begin if AClass1.ClassInfo <> AClass2.ClassInfo then exit; ClassTypeInfo := AClass1.ClassInfo; ClassTypeData := GetTypeData(ClassTypeInfo); if ClassTypeData.PropCount <> 0 then begin GetMem(PropList, SizeOf(PPropInfo) * ClassTypeData.PropCount); try GetPropInfos(AClass1.ClassInfo, PropList); for i := 0 to ClassTypeData.PropCount - 1 do if not (PropList[i]^.PropType^.Kind = tkMethod) then {if Class1,2 is TControl/TWinControl on same form, its names must be unique} if PropList[i]^.Name <> 'Name' then if (PropList[i]^.PropType^.Kind = tkClass) then begin APersistent := TPersistent(GetObjectProp(AClass1, PropList[i]^.Name, TPersistent)); if APersistent <> nil then APersistent.Assign(TPersistent(GetObjectProp(AClass2, PropList[i]^.Name, TPersistent))) end else SetPropValue(AClass1, PropList[i]^.Name, GetPropValue(AClass2, PropList[i]^.Name)); finally FreeMem(PropList, SizeOf(PPropInfo) * ClassTypeData.PropCount); end; end; end; Note that this code skips object properties inherited other than TPersistent.
{...}, TypInfo procedure BrushStylesAsStrings(AList: TStrings); var a: integer; pInfo: PTypeInfo; pEnum: PTypeData; begin AList.Clear; pInfo := PTypeInfo(TypeInfo(TBrushStyle)); pEnum := GetTypeData(pInfo); with pEnum^ do begin for a := MinValue to MaxValue do AList.Add(GetEnumName(pInfo, a)); end; end;
I would like to change the font color on all components on a form at runtime (and the components owned by the components etc). I devised a recursive algorithm using RTTI that accepts a TComponent as a parameter. It works to some extent, but I still have to use 'if' statements to cast the object to a particular descendant, resulting in about 30 lines of code to test for all of the components I use. Also, some objects (TColumnTitle), are not descended from TComponent, even though they have a font property. This may do the trick (with D6 and maybe D5): uses TypInfo; { ... } var i: integer; aFont: TFont; begin for i := 0 to aComponent.ComponentCount - 1 do begin aFont := TFont(GetOrdProp(aComponent.Components[i], 'Font')); if assigned(aFont) then aFont.Color := clWhite; end; end; With D4: { ... } var i: integer; aFont: TFont; pi: PPropInfo; begin for i := 0 to aComponent.ComponentCount - 1 do begin pi := GetPropInfo(aComponent.Components[i].ClassInfo, 'Font'); if assigned(pi) then TFont(GetOrdProp(aComponent.Components[i],pi)).Color := clWhite; end; end;
{ ... } type PYourMethod = ^TYourMethod; TYourMethod = procedure(S: string) of Object; procedure TMainForm.Button1Click(Sender: TObject); begin ExecMethodByName('SomeMethod'); end; procedure TMainForm.ExecMethodByName(AName: string); var PAddr: PYourMethod; M: TMethod; begin PAddr := MethodAddress(AName); if PAddr <> nil then begin M.Code := PAddr; M.Data := Self; TYourMethod(M)('hello'); end; end; procedure TMainForm.SomeMethod(S: string); begin ShowMessage(S); end;
procedure GetEnumNameList(Pti: PTypeInfo; AList: TStrings; X: Integer); {(********************************************************** Will return in AList string version of an enumerated type less the first X characters . eg X = 4 and type eXORBuySell = ( XOR_BUY, XOR_SELL ); GetEnumNameList(TypeInfo(eXORBuySell), ComboBox1.Items, 4); Now ComboBox1.Items[0] = 'BUY' and ComboBox1.Items[1] = 'SELL' ************************************************************)} var I: Integer; begin AList.Clear; with GetTypeData(pti)^ do for I := MinValue to MaxValue do AList.Add(Copy(GetEnumName(pti, I), X + 1, 255)); end;
GetModuleFileName()
Function ObjectsUnit (Obj: TClass): String; Begin Result := GetTypeData (PTypeInfo(Obj.ClassInfo))^.UnitName end; Для создания описанной вами функции "Какой модуль" могут использоваться описанные в TOOLINTF.INT методы GetModuleCount, GetModuleName, GetComponentCount и GetComponentName. Для получения представления о формате палитры компонентов обратитесь к файлу DELPHI.INI.
procedure TForm1.FormCreate(Sender: TObject); begin {This only works for classes registered using RegisterClass} RegisterClasses([TButton, TForm]); end; procedure TForm1.Button1Click(Sender: TObject); var CRef: TPersistentClass; PTI: PTypeInfo; AControl: TControl; begin CRef := GetClass('TButton'); if CRef <> nil then begin AControl := TControl(TControlClass(CRef).Create(Self)); with AControl do begin Parent := Self; Width := 50; Height := 30; end; Inc(Id); end else MessageDlg('No such class', mtWarning, [mbOk], 0); end;
Сайт рассылки Здесь Так же можете посетить несколько сайтов для заработка в Интернете: |
В избранное | ||