/components/rx/placement.pp

http://github.com/graemeg/lazarus · Puppet · 1100 lines · 1005 code · 95 blank · 0 comment · 81 complexity · b2b0c0571108b7b65b253844ac0b9713 MD5 · raw file

  1. {*******************************************************}
  2. { }
  3. { Delphi VCL Extensions (RX) }
  4. { }
  5. { Copyright (c) 1995, 1996 AO ROSNO }
  6. { Copyright (c) 1997 Master-Bank }
  7. { }
  8. {*******************************************************}
  9. {$mode objfpc}
  10. {$h+}
  11. unit Placement;
  12. interface
  13. uses Controls, Classes, LazUTF8, Forms, IniFiles, Dialogs, RTTIUtils;
  14. type
  15. TPlacementOption = (fpState, fpPosition, fpActiveControl);
  16. TPlacementOptions = set of TPlacementOption;
  17. TPlacementOperation = (poSave, poRestore);
  18. TIniLink = Class;
  19. TFormPlacement = Class;
  20. TStoredValue = Class;
  21. TStoredValues = Class;
  22. { TStoredValue }
  23. {$ifdef storevariant}
  24. TStoredType = Variant;
  25. {$else}
  26. TStoredType = AnsiString;
  27. {$endif}
  28. TStoredValueEvent = procedure(Sender: TStoredValue; var Value: TStoredType) of object;
  29. TStoredValue = class(TCollectionItem)
  30. private
  31. FName: string;
  32. FValue: TStoredType;
  33. FKeyString: string;
  34. FOnSave: TStoredValueEvent;
  35. FOnRestore: TStoredValueEvent;
  36. function IsValueStored: Boolean;
  37. function GetStoredValues: TStoredValues;
  38. protected
  39. function GetDisplayName: string; override;
  40. procedure SetDisplayName(const Value: string); override;
  41. public
  42. constructor Create(ACollection: TCollection); override;
  43. procedure Assign(Source: TPersistent); override;
  44. procedure Clear;
  45. procedure Save; virtual;
  46. procedure Restore; virtual;
  47. property StoredValues: TStoredValues read GetStoredValues;
  48. published
  49. property Name: string read FName write SetDisplayName;
  50. property Value: TStoredType read FValue write FValue stored IsValueStored;
  51. property KeyString: string read FKeyString write FKeyString;
  52. property OnSave: TStoredValueEvent read FOnSave write FOnSave;
  53. property OnRestore: TStoredValueEvent read FOnRestore write FOnRestore;
  54. end;
  55. { TStoredValues }
  56. TStoredValues = class(TOwnedCollection)
  57. private
  58. FStorage: TFormPlacement;
  59. function GetValue(const AName: string): TStoredValue;
  60. procedure SetValue(const AName: string; StoredValue: TStoredValue);
  61. function GetStoredValue(const AName: string): TStoredType;
  62. procedure SetStoredValue(const AName: string; Value: TStoredType);
  63. function GetItem(Index: Integer): TStoredValue;
  64. procedure SetItem(Index: Integer; StoredValue: TStoredValue);
  65. public
  66. constructor Create(AOwner: TPersistent);
  67. function IndexOf(const AName: string): Integer;
  68. procedure SaveValues; virtual;
  69. procedure RestoreValues; virtual;
  70. property Storage: TFormPlacement read FStorage write FStorage;
  71. property Items[Index: Integer]: TStoredValue read GetItem write SetItem; default;
  72. property Values[const Name: string]: TStoredValue read GetValue write SetValue;
  73. property StoredValue[const Name: string]: TStoredType read GetStoredValue write SetStoredValue;
  74. end;
  75. { TFormPlacement }
  76. TFormPlacement = class(TComponent)
  77. private
  78. FActive: Boolean;
  79. FIniFileName: String;
  80. FIniSection: String;
  81. FIniFile: TCustomIniFile;
  82. FLinks: TList;
  83. FOptions: TPlacementOptions;
  84. FVersion: Integer;
  85. FSaved: Boolean;
  86. FRestored: Boolean;
  87. FDestroying: Boolean;
  88. //FDefMaximize: Boolean;
  89. FSaveFormShow: TNotifyEvent;
  90. FSaveFormDestroy: TNotifyEvent;
  91. FSaveFormCloseQuery: TCloseQueryEvent;
  92. FOnSavePlacement: TNotifyEvent;
  93. FOnRestorePlacement: TNotifyEvent;
  94. procedure SetEvents;
  95. procedure RestoreEvents;
  96. function GetIniSection: string;
  97. procedure SetIniSection(const Value: string);
  98. function GetIniFileName: string;
  99. procedure SetIniFileName(const Value: string);
  100. procedure AddLink(ALink: TIniLink);
  101. procedure NotifyLinks(Operation: TPlacementOperation);
  102. procedure RemoveLink(ALink: TIniLink);
  103. procedure FormShow(Sender: TObject);
  104. procedure FormCloseQuery(Sender: TObject; var CanClose: Boolean);
  105. procedure FormDestroy(Sender: TObject);
  106. function GetForm: TForm;
  107. protected
  108. procedure IniNeeded(ReadOnly: Boolean);Virtual;
  109. procedure IniFree;Virtual;
  110. procedure Loaded; override;
  111. procedure Save; dynamic;
  112. procedure Restore; dynamic;
  113. procedure SavePlacement; virtual;
  114. procedure RestorePlacement; virtual;
  115. function DoReadString(const Section, Ident, Default: string): string; virtual;
  116. procedure DoWriteString(const Section, Ident, Value: string); virtual;
  117. property Form: TForm read GetForm;
  118. public
  119. constructor Create(AOwner: TComponent); override;
  120. destructor Destroy; override;
  121. procedure SaveFormPlacement;
  122. procedure RestoreFormPlacement;
  123. function ReadString(const Ident, Default: string): string;
  124. procedure WriteString(const Ident, Value: string);
  125. function ReadInteger(const Ident: string; Default: Longint): Longint;
  126. procedure WriteInteger(const Ident: string; Value: Longint);
  127. procedure EraseSections;
  128. property IniFile: TCustomIniFile read FIniFile;
  129. published
  130. property Active: Boolean read FActive write FActive default True;
  131. property IniFileName: string read GetIniFileName write SetIniFileName;
  132. property IniSection: string read GetIniSection write SetIniSection;
  133. property Options: TPlacementOptions read FOptions write FOptions default [fpState, fpPosition];
  134. property Version: Integer read FVersion write FVersion default 0;
  135. property OnSavePlacement: TNotifyEvent read FOnSavePlacement write FOnSavePlacement;
  136. property OnRestorePlacement: TNotifyEvent read FOnRestorePlacement write FOnRestorePlacement;
  137. end;
  138. { TFormStorage }
  139. TFormStorage = class(TFormPlacement)
  140. private
  141. FStoredProps: TStrings;
  142. FStoredValues: TStoredValues;
  143. procedure SetStoredProps(Value: TStrings);
  144. procedure SetStoredValues(Value: TStoredValues);
  145. function GetStoredValue(const AName: string): TstoredType;
  146. procedure SetStoredValue(const AName: string; Value: TStoredType);
  147. protected
  148. procedure Loaded; override;
  149. procedure Notification(AComponent: TComponent; Operation: TOperation); override;
  150. procedure SavePlacement; override;
  151. procedure RestorePlacement; override;
  152. procedure SaveProperties; virtual;
  153. procedure RestoreProperties; virtual;
  154. procedure WriteState(Writer: TWriter); override;
  155. public
  156. constructor Create(AOwner: TComponent); override;
  157. destructor Destroy; override;
  158. procedure SetNotification;
  159. property StoredValue[const AName: string]: TStoredType read GetStoredValue write SetStoredValue;
  160. published
  161. property StoredProps: TStrings read FStoredProps write SetStoredProps;
  162. property StoredValues: TStoredValues read FStoredValues write SetStoredValues;
  163. end;
  164. { TIniLink }
  165. TIniLink = class(TPersistent)
  166. private
  167. FStorage: TFormPlacement;
  168. FOnSave: TNotifyEvent;
  169. FOnLoad: TNotifyEvent;
  170. function GetIniObject: TCustomIniFile;
  171. function GetRootSection: string;
  172. procedure SetStorage(Value: TFormPlacement);
  173. protected
  174. procedure SaveToIni; virtual;
  175. procedure LoadFromIni; virtual;
  176. public
  177. destructor Destroy; override;
  178. property IniObject: TCustomInifile read GetIniObject;
  179. property Storage: TFormPlacement read FStorage write SetStorage;
  180. property RootSection: string read GetRootSection;
  181. property OnSave: TNotifyEvent read FOnSave write FOnSave;
  182. property OnLoad: TNotifyEvent read FOnLoad write FOnLoad;
  183. end;
  184. implementation
  185. uses SysUtils, AppUtils, RTLConsts;
  186. const
  187. { The following strings should not be localized }
  188. siActiveCtrl = 'ActiveControl';
  189. siVisible = 'Visible';
  190. siVersion = 'FormVersion';
  191. function XorEncode(const Key, Source: string): string;
  192. var
  193. I: Integer;
  194. C: Byte;
  195. begin
  196. Result := '';
  197. for I := 1 to Length(Source) do begin
  198. if Length(Key) > 0 then
  199. C := Byte(Key[1 + ((I - 1) mod Length(Key))]) xor Byte(Source[I])
  200. else
  201. C := Byte(Source[I]);
  202. Result := Result + AnsiLowerCase(IntToHex(C, 2));
  203. end;
  204. end;
  205. function XorDecode(const Key, Source: string): string;
  206. var
  207. I: Integer;
  208. C: Char;
  209. begin
  210. Result := '';
  211. for I := 0 to Length(Source) div 2 - 1 do begin
  212. C := Chr(StrToIntDef('$' + Copy(Source, (I * 2) + 1, 2), Ord(' ')));
  213. if Length(Key) > 0 then
  214. C := Chr(Byte(Key[1 + (I mod Length(Key))]) xor Byte(C));
  215. Result := Result + C;
  216. end;
  217. end;
  218. Function GetDefaultIniName : String;
  219. begin
  220. {$ifdef unix}
  221. Result:=IncludeTrailingPathDelimiter(GetEnvironmentVariableUTF8('HOME'))
  222. +'.'+ExtractFileName(Application.ExeName)
  223. {$else}
  224. Result:=ChangeFileExt(Application.ExeName,'.ini');
  225. {$endif}
  226. end;
  227. function FindPart(const HelpWilds, InputStr: string): Integer;
  228. var
  229. I, J: Integer;
  230. Diff: Integer;
  231. begin
  232. I := Pos('?', HelpWilds);
  233. if I = 0 then begin
  234. { if no '?' in HelpWilds }
  235. Result := Pos(HelpWilds, InputStr);
  236. Exit;
  237. end;
  238. { '?' in HelpWilds }
  239. Diff := Length(InputStr) - Length(HelpWilds);
  240. if Diff < 0 then begin
  241. Result := 0;
  242. Exit;
  243. end;
  244. { now move HelpWilds over InputStr }
  245. for I := 0 to Diff do begin
  246. for J := 1 to Length(HelpWilds) do begin
  247. if (InputStr[I + J] = HelpWilds[J]) or
  248. (HelpWilds[J] = '?') then
  249. begin
  250. if J = Length(HelpWilds) then begin
  251. Result := I + 1;
  252. Exit;
  253. end;
  254. end
  255. else Break;
  256. end;
  257. end;
  258. Result := 0;
  259. end;
  260. function IsWild(InputStr, Wilds: string; IgnoreCase: Boolean): Boolean;
  261. function SearchNext(var Wilds: string): Integer;
  262. { looking for next *, returns position and string until position }
  263. begin
  264. Result := Pos('*', Wilds);
  265. if Result > 0 then Wilds := Copy(Wilds, 1, Result - 1);
  266. end;
  267. var
  268. CWild, CInputWord: Integer; { counter for positions }
  269. I, LenHelpWilds: Integer;
  270. MaxInputWord, MaxWilds: Integer; { Length of InputStr and Wilds }
  271. HelpWilds: string;
  272. begin
  273. if Wilds = InputStr then begin
  274. Result := True;
  275. Exit;
  276. end;
  277. repeat { delete '**', because '**' = '*' }
  278. I := Pos('**', Wilds);
  279. if I > 0 then
  280. Wilds := Copy(Wilds, 1, I - 1) + '*' + Copy(Wilds, I + 2, MaxInt);
  281. until I = 0;
  282. if Wilds = '*' then begin { for fast end, if Wilds only '*' }
  283. Result := True;
  284. Exit;
  285. end;
  286. MaxInputWord := Length(InputStr);
  287. MaxWilds := Length(Wilds);
  288. if IgnoreCase then begin { upcase all letters }
  289. InputStr := AnsiUpperCase(InputStr);
  290. Wilds := AnsiUpperCase(Wilds);
  291. end;
  292. if (MaxWilds = 0) or (MaxInputWord = 0) then begin
  293. Result := False;
  294. Exit;
  295. end;
  296. CInputWord := 1;
  297. CWild := 1;
  298. Result := True;
  299. repeat
  300. if InputStr[CInputWord] = Wilds[CWild] then begin { equal letters }
  301. { goto next letter }
  302. Inc(CWild);
  303. Inc(CInputWord);
  304. Continue;
  305. end;
  306. if Wilds[CWild] = '?' then begin { equal to '?' }
  307. { goto next letter }
  308. Inc(CWild);
  309. Inc(CInputWord);
  310. Continue;
  311. end;
  312. if Wilds[CWild] = '*' then begin { handling of '*' }
  313. HelpWilds := Copy(Wilds, CWild + 1, MaxWilds);
  314. I := SearchNext(HelpWilds);
  315. LenHelpWilds := Length(HelpWilds);
  316. if I = 0 then begin
  317. { no '*' in the rest, compare the ends }
  318. if HelpWilds = '' then Exit; { '*' is the last letter }
  319. { check the rest for equal Length and no '?' }
  320. for I := 0 to LenHelpWilds - 1 do begin
  321. if (HelpWilds[LenHelpWilds - I] <> InputStr[MaxInputWord - I]) and
  322. (HelpWilds[LenHelpWilds - I]<> '?') then
  323. begin
  324. Result := False;
  325. Exit;
  326. end;
  327. end;
  328. Exit;
  329. end;
  330. { handle all to the next '*' }
  331. Inc(CWild, 1 + LenHelpWilds);
  332. I := FindPart(HelpWilds, Copy(InputStr, CInputWord, MaxInt));
  333. if I= 0 then begin
  334. Result := False;
  335. Exit;
  336. end;
  337. CInputWord := I + LenHelpWilds;
  338. Continue;
  339. end;
  340. Result := False;
  341. Exit;
  342. until (CInputWord > MaxInputWord) or (CWild > MaxWilds);
  343. { no completed evaluation }
  344. if CInputWord <= MaxInputWord then Result := False;
  345. if (CWild <= MaxWilds) and (Wilds[MaxWilds] <> '*') then Result := False;
  346. end;
  347. { TFormPlacement }
  348. constructor TFormPlacement.Create(AOwner: TComponent);
  349. begin
  350. inherited Create(AOwner);
  351. FActive := True;
  352. if (AOwner is TForm) then
  353. FOptions := [fpState, fpPosition]
  354. else
  355. FOptions := [];
  356. FLinks := TList.Create;
  357. end;
  358. destructor TFormPlacement.Destroy;
  359. begin
  360. IniFree;
  361. while FLinks.Count > 0 do
  362. RemoveLink(TiniLink(FLinks.Last));
  363. FreeAndNil(FLinks);
  364. if not (csDesigning in ComponentState) then
  365. RestoreEvents;
  366. inherited Destroy;
  367. end;
  368. procedure TFormPlacement.Loaded;
  369. var
  370. IsLoading: Boolean;
  371. begin
  372. IsLoading := csLoading in ComponentState;
  373. inherited Loaded;
  374. if not (csDesigning in ComponentState) then
  375. begin
  376. if IsLoading then
  377. SetEvents;
  378. end;
  379. end;
  380. procedure TFormPlacement.AddLink(ALink: TIniLink);
  381. begin
  382. FLinks.Add(ALink);
  383. ALink.FStorage := Self;
  384. end;
  385. procedure TFormPlacement.NotifyLinks(Operation: TPlacementOperation);
  386. var
  387. I: Integer;
  388. begin
  389. for I := 0 to FLinks.Count - 1 do
  390. with TIniLink(FLinks[I]) do
  391. case Operation of
  392. poSave: SaveToIni;
  393. poRestore: LoadFromIni;
  394. end;
  395. end;
  396. procedure TFormPlacement.RemoveLink(ALink: TIniLink);
  397. begin
  398. ALink.FStorage := nil;
  399. FLinks.Remove(ALink);
  400. end;
  401. function TFormPlacement.GetForm: TForm;
  402. begin
  403. if (Owner is TCustomForm) then
  404. Result := TForm(Owner as TCustomForm)
  405. else
  406. Result := nil;
  407. end;
  408. procedure TFormPlacement.SetEvents;
  409. begin
  410. if (Owner is TCustomForm) then
  411. begin
  412. with TForm(Form) do
  413. begin
  414. FSaveFormShow := OnShow;
  415. OnShow := @FormShow;
  416. FSaveFormCloseQuery := OnCloseQuery;
  417. OnCloseQuery := @FormCloseQuery;
  418. FSaveFormDestroy := OnDestroy;
  419. OnDestroy := @FormDestroy;
  420. end;
  421. end;
  422. end;
  423. procedure TFormPlacement.RestoreEvents;
  424. begin
  425. if (Owner <> nil) and (Owner is TCustomForm) then
  426. with TForm(Form) do
  427. begin
  428. OnShow := FSaveFormShow;
  429. OnCloseQuery := FSaveFormCloseQuery;
  430. OnDestroy := FSaveFormDestroy;
  431. end;
  432. end;
  433. procedure TFormPlacement.FormShow(Sender: TObject);
  434. begin
  435. if Active then
  436. try
  437. RestoreFormPlacement;
  438. except
  439. Application.HandleException(Self);
  440. end;
  441. if Assigned(FSaveFormShow) then FSaveFormShow(Sender);
  442. end;
  443. procedure TFormPlacement.FormCloseQuery(Sender: TObject; var CanClose: Boolean);
  444. begin
  445. if Assigned(FSaveFormCloseQuery) then
  446. FSaveFormCloseQuery(Sender, CanClose);
  447. if CanClose and Active and (Owner is TCustomForm) and (Form.Handle <> 0) then
  448. try
  449. SaveFormPlacement;
  450. except
  451. Application.HandleException(Self);
  452. end;
  453. end;
  454. procedure TFormPlacement.FormDestroy(Sender: TObject);
  455. begin
  456. if Active and not FSaved then
  457. begin
  458. FDestroying := True;
  459. try
  460. SaveFormPlacement;
  461. except
  462. Application.HandleException(Self);
  463. end;
  464. FDestroying := False;
  465. end;
  466. if Assigned(FSaveFormDestroy) then
  467. FSaveFormDestroy(Sender);
  468. end;
  469. function TFormPlacement.GetIniFileName: string;
  470. begin
  471. Result := FIniFileName;
  472. if (Result = '') and not (csDesigning in ComponentState) then
  473. Result := GetDefaultIniName;
  474. end;
  475. procedure TFormPlacement.SetIniFileName(const Value: string);
  476. begin
  477. FIniFileName:=Value;
  478. end;
  479. function TFormPlacement.GetIniSection: string;
  480. begin
  481. Result := FIniSection;
  482. if (Result = '') and not (csDesigning in ComponentState) then
  483. Result := GetDefaultSection(Owner);
  484. end;
  485. procedure TFormPlacement.SetIniSection(const Value: string);
  486. begin
  487. FIniSection:=Value;
  488. end;
  489. procedure TFormPlacement.Save;
  490. begin
  491. if Assigned(FOnSavePlacement) then
  492. FOnSavePlacement(Self);
  493. end;
  494. procedure TFormPlacement.Restore;
  495. begin
  496. if Assigned(FOnRestorePlacement) then FOnRestorePlacement(Self);
  497. end;
  498. procedure TFormPlacement.SavePlacement;
  499. begin
  500. if (Owner is TCustomForm) then
  501. begin
  502. if (Options * [fpState, fpPosition] <> []) then
  503. begin
  504. WriteFormPlacement(Form, IniFile, IniSection);
  505. IniFile.WriteBool(IniSection, siVisible, FDestroying);
  506. end;
  507. if (fpActiveControl in Options) and (Form.ActiveControl <> nil) then
  508. IniFile.WriteString(IniSection, siActiveCtrl, Form.ActiveControl.Name);
  509. end;
  510. NotifyLinks(poSave);
  511. end;
  512. procedure TFormPlacement.RestorePlacement;
  513. begin
  514. if Owner is TCustomForm then
  515. ReadFormPlacement(Form, IniFile, IniSection, fpState in Options, fpPosition in Options);
  516. NotifyLinks(poRestore);
  517. end;
  518. procedure TFormPlacement.IniNeeded(ReadOnly: Boolean);
  519. begin
  520. if ReadOnly then ;
  521. if IniFile = nil then
  522. FIniFile := TIniFile.Create(UTF8ToSys(IniFileName));
  523. end;
  524. procedure TFormPlacement.IniFree;
  525. begin
  526. if IniFile <> nil then
  527. FreeAndNil(FIniFile);
  528. end;
  529. function TFormPlacement.DoReadString(const Section, Ident,
  530. Default: string): string;
  531. begin
  532. if IniFile <> nil then
  533. Result := IniFile.ReadString(Section, Ident, Default)
  534. else
  535. begin
  536. IniNeeded(True);
  537. try
  538. Result := Inifile.ReadString(Section, Ident, Default);
  539. finally
  540. IniFree;
  541. end;
  542. end;
  543. end;
  544. function TFormPlacement.ReadString(const Ident, Default: string): string;
  545. begin
  546. Result := DoReadString(IniSection, Ident, Default);
  547. end;
  548. procedure TFormPlacement.DoWriteString(const Section, Ident, Value: string);
  549. begin
  550. if IniFile<>nil then
  551. IniFile.WriteString(Section, Ident, Value)
  552. else begin
  553. IniNeeded(False);
  554. try
  555. IniFile.WriteString(Section, Ident, Value);
  556. finally
  557. IniFree;
  558. end;
  559. end;
  560. end;
  561. procedure TFormPlacement.WriteString(const Ident, Value: string);
  562. begin
  563. DoWriteString(IniSection, Ident, Value);
  564. end;
  565. function TFormPlacement.ReadInteger(const Ident: string; Default: Longint): Longint;
  566. begin
  567. if (IniFile<>nil) then
  568. Result := IniFile.ReadInteger(IniSection, Ident, Default)
  569. else
  570. begin
  571. IniNeeded(True);
  572. try
  573. Result := Inifile.ReadInteger(IniSection, Ident, Default);
  574. finally
  575. IniFree;
  576. end;
  577. end;
  578. end;
  579. procedure TFormPlacement.WriteInteger(const Ident: string; Value: Longint);
  580. begin
  581. if IniFile<>nil then
  582. IniFile.WriteInteger(IniSection, Ident, Value)
  583. else begin
  584. IniNeeded(False);
  585. try
  586. Inifile.WriteInteger(IniSection, Ident, Value);
  587. finally
  588. IniFree;
  589. end;
  590. end;
  591. end;
  592. procedure TFormPlacement.EraseSections;
  593. var
  594. Lines: TStrings;
  595. I: Integer;
  596. begin
  597. if IniFile= nil then begin
  598. IniNeeded(False);
  599. try
  600. Lines := TStringList.Create;
  601. try
  602. Inifile.ReadSections(Lines);
  603. for I := 0 to Lines.Count - 1 do begin
  604. if (Lines[I] = IniSection) or
  605. (IsWild(Lines[I], IniSection + '.*', False) or
  606. IsWild(Lines[I], IniSection + '\*', False)) then
  607. Inifile.EraseSection(Lines[I]);
  608. end;
  609. finally
  610. Lines.Free;
  611. end;
  612. finally
  613. IniFree;
  614. end;
  615. end;
  616. end;
  617. procedure TFormPlacement.SaveFormPlacement;
  618. begin
  619. if FRestored or not Active then begin
  620. IniNeeded(False);
  621. try
  622. WriteInteger(siVersion, FVersion);
  623. SavePlacement;
  624. Save;
  625. FSaved := True;
  626. finally
  627. IniFree;
  628. end;
  629. end;
  630. end;
  631. procedure TFormPlacement.RestoreFormPlacement;
  632. var
  633. cActive: TComponent;
  634. begin
  635. FSaved := False;
  636. IniNeeded(True);
  637. try
  638. if ReadInteger(siVersion, 0) >= FVersion then begin
  639. RestorePlacement;
  640. FRestored := True;
  641. Restore;
  642. if (fpActiveControl in Options) and (Owner is TCustomForm) then
  643. begin
  644. cActive := Form.FindComponent(Inifile.ReadString(IniSection, siActiveCtrl, ''));
  645. if (cActive <> nil) and (cActive is TWinControl) and
  646. TWinControl(cActive).CanFocus then
  647. Form.ActiveControl := TWinControl(cActive);
  648. end;
  649. end;
  650. FRestored := True;
  651. finally
  652. IniFree;
  653. end;
  654. end;
  655. { TFormStorage }
  656. constructor TFormStorage.Create(AOwner: TComponent);
  657. begin
  658. inherited Create(AOwner);
  659. FStoredProps:=TStringList.Create;
  660. FStoredValues:=TStoredValues.Create(Self);
  661. FStoredValues.Storage := Self;
  662. end;
  663. destructor TFormStorage.Destroy;
  664. begin
  665. FreeAndNil(FStoredValues);
  666. FreeAndNil(FStoredProps);
  667. inherited Destroy;
  668. end;
  669. procedure TFormStorage.SetNotification;
  670. var
  671. I: Integer;
  672. Component: TComponent;
  673. begin
  674. for I := FStoredProps.Count - 1 downto 0 do begin
  675. Component := TComponent(FStoredProps.Objects[I]);
  676. if Component <> nil then Component.FreeNotification(Self);
  677. end;
  678. end;
  679. procedure TFormStorage.SetStoredProps(Value: TStrings);
  680. begin
  681. FStoredProps.Assign(Value);
  682. SetNotification;
  683. end;
  684. procedure TFormStorage.SetStoredValues(Value: TStoredValues);
  685. begin
  686. FStoredValues.Assign(Value);
  687. end;
  688. function TFormStorage.GetStoredValue(const AName: string): TStoredType;
  689. begin
  690. Result := StoredValues.StoredValue[AName];
  691. end;
  692. procedure TFormStorage.SetStoredValue(const AName: string; Value: TStoredType);
  693. begin
  694. StoredValues.StoredValue[AName] := Value;
  695. end;
  696. procedure TFormStorage.Loaded;
  697. begin
  698. inherited Loaded;
  699. UpdateStoredList(Owner, FStoredProps, True);
  700. end;
  701. procedure TFormStorage.WriteState(Writer: TWriter);
  702. begin
  703. UpdateStoredList(Owner, FStoredProps, False);
  704. inherited WriteState(Writer);
  705. end;
  706. procedure TFormStorage.Notification(AComponent: TComponent; Operation: TOperation);
  707. var
  708. I: Integer;
  709. Component: TComponent;
  710. begin
  711. inherited Notification(AComponent, Operation);
  712. if not (csDestroying in ComponentState) and (Operation = opRemove) and
  713. (FStoredProps <> nil) then
  714. for I := FStoredProps.Count - 1 downto 0 do begin
  715. Component := TComponent(FStoredProps.Objects[I]);
  716. if Component = AComponent then FStoredProps.Delete(I);
  717. end;
  718. end;
  719. procedure TFormStorage.SaveProperties;
  720. begin
  721. with TPropsStorage.Create do
  722. try
  723. Section := IniSection;
  724. OnWriteString := @DoWriteString;
  725. OnEraseSection := @IniFile.EraseSection;
  726. StoreObjectsProps(Owner, FStoredProps);
  727. finally
  728. Free;
  729. end;
  730. end;
  731. procedure TFormStorage.RestoreProperties;
  732. begin
  733. with TPropsStorage.Create do
  734. try
  735. Section := IniSection;
  736. OnReadString := @DoReadString;
  737. try
  738. LoadObjectsProps(Owner, FStoredProps);
  739. except
  740. { ignore any exceptions }
  741. end;
  742. finally
  743. Free;
  744. end;
  745. end;
  746. procedure TFormStorage.SavePlacement;
  747. begin
  748. inherited SavePlacement;
  749. SaveProperties;
  750. {$IFDEF RX_D3}
  751. StoredValues.SaveValues;
  752. {$ENDIF}
  753. end;
  754. procedure TFormStorage.RestorePlacement;
  755. begin
  756. inherited RestorePlacement;
  757. FRestored := True;
  758. RestoreProperties;
  759. {$IFDEF RX_D3}
  760. StoredValues.RestoreValues;
  761. {$ENDIF}
  762. end;
  763. { TIniLink }
  764. destructor TIniLink.Destroy;
  765. begin
  766. FOnSave := nil;
  767. FOnLoad := nil;
  768. SetStorage(nil);
  769. inherited Destroy;
  770. end;
  771. function TIniLink.GetIniObject: TCustomInifile;
  772. begin
  773. if Assigned(FStorage) then
  774. Result := FStorage.IniFile
  775. else Result := nil;
  776. end;
  777. function TIniLink.GetRootSection: string;
  778. begin
  779. if Assigned(FStorage) then
  780. Result := FStorage.FIniSection
  781. else
  782. Result := '';
  783. if Result <> '' then
  784. Result := Result + '\';
  785. end;
  786. procedure TIniLink.SetStorage(Value: TFormPlacement);
  787. begin
  788. if FStorage <> Value then
  789. begin
  790. if FStorage <> nil then
  791. FStorage.RemoveLink(Self);
  792. if Value <> nil then
  793. Value.AddLink(Self);
  794. end;
  795. end;
  796. procedure TIniLink.SaveToIni;
  797. begin
  798. if Assigned(FOnSave) then FOnSave(Self);
  799. end;
  800. procedure TIniLink.LoadFromIni;
  801. begin
  802. if Assigned(FOnLoad) then FOnLoad(Self);
  803. end;
  804. { TStoredValue }
  805. constructor TStoredValue.Create(ACollection: TCollection);
  806. begin
  807. inherited Create(ACollection);
  808. {$ifdef storevariant}
  809. FValue := Unassigned;
  810. {$else}
  811. FValue:='';
  812. {$endif}
  813. end;
  814. procedure TStoredValue.Assign(Source: TPersistent);
  815. begin
  816. if (Source is TStoredValue) and (Source <> nil) then
  817. begin
  818. {$ifdef storevariant}
  819. if VarIsEmpty(TStoredValue(Source).FValue) then
  820. Clear
  821. else
  822. {$endif}
  823. Value := TStoredValue(Source).FValue;
  824. Name := TStoredValue(Source).Name;
  825. KeyString := TStoredValue(Source).KeyString;
  826. end;
  827. end;
  828. function TStoredValue.GetDisplayName: string;
  829. begin
  830. if FName = '' then
  831. Result := inherited GetDisplayName
  832. else
  833. Result := FName;
  834. end;
  835. procedure TStoredValue.SetDisplayName(const Value: string);
  836. begin
  837. if (Value <> '') and (AnsiCompareText(Value, FName) <> 0) and
  838. (Collection is TStoredValues) and (TStoredValues(Collection).IndexOf(Value) >= 0) then
  839. raise Exception.Create(SDuplicateString);
  840. FName := Value;
  841. inherited;
  842. end;
  843. function TStoredValue.GetStoredValues: TStoredValues;
  844. begin
  845. if Collection is TStoredValues then
  846. Result := TStoredValues(Collection)
  847. else
  848. Result := nil;
  849. end;
  850. procedure TStoredValue.Clear;
  851. begin
  852. {$ifdef storevariant}
  853. FValue := Unassigned;
  854. {$else}
  855. FValue := '';
  856. {$endif}
  857. end;
  858. function TStoredValue.IsValueStored: Boolean;
  859. begin
  860. {$ifdef storevariant}
  861. Result := not VarIsEmpty(FValue);
  862. {$else}
  863. Result := (FValue<>'');
  864. {$endif}
  865. end;
  866. procedure TStoredValue.Save;
  867. var
  868. SaveValue: TStoredType;
  869. SaveStrValue: string;
  870. begin
  871. SaveValue := Value;
  872. if Assigned(FOnSave) then
  873. FOnSave(Self, SaveValue);
  874. {$ifdef storevariant}
  875. SaveStrValue := VarToStr(SaveValue);
  876. {$else}
  877. SaveStrValue := SaveValue;
  878. {$endif}
  879. if KeyString <> '' then
  880. SaveStrValue := XorEncode(KeyString, SaveStrValue);
  881. StoredValues.Storage.WriteString(Name, SaveStrValue);
  882. end;
  883. procedure TStoredValue.Restore;
  884. var
  885. RestoreValue: TStoredType;
  886. RestoreStrValue, DefaultStrValue: string;
  887. begin
  888. {$ifdef storevariant}
  889. DefaultStrValue := VarToStr(Value);
  890. {$else}
  891. DefaultStrValue := Value;
  892. {$endif}
  893. if KeyString <> '' then
  894. DefaultStrValue := XorEncode(KeyString, DefaultStrValue);
  895. RestoreStrValue := StoredValues.Storage.ReadString(Name, DefaultStrValue);
  896. if KeyString <> '' then
  897. RestoreStrValue := XorDecode(KeyString, RestoreStrValue);
  898. RestoreValue := RestoreStrValue;
  899. if Assigned(FOnRestore) then
  900. FOnRestore(Self, RestoreValue);
  901. Value := RestoreValue;
  902. end;
  903. { TStoredValues }
  904. constructor TStoredValues.Create(AOwner: TPersistent);
  905. begin
  906. inherited Create(AOwner, TStoredValue);
  907. end;
  908. function TStoredValues.IndexOf(const AName: string): Integer;
  909. begin
  910. for Result := 0 to Count - 1 do
  911. if AnsiCompareText(Items[Result].Name, AName) = 0 then Exit;
  912. Result := -1;
  913. end;
  914. function TStoredValues.GetItem(Index: Integer): TStoredValue;
  915. begin
  916. Result := TStoredValue(inherited Items[Index]);
  917. end;
  918. procedure TStoredValues.SetItem(Index: Integer; StoredValue: TStoredValue);
  919. begin
  920. inherited SetItem(Index, TCollectionItem(StoredValue));
  921. end;
  922. function TStoredValues.GetStoredValue(const AName: string): TStoredType;
  923. var
  924. AStoredValue: TStoredValue;
  925. begin
  926. AStoredValue := GetValue(AName);
  927. if AStoredValue = nil then
  928. {$ifdef storevariant}
  929. Result := Null
  930. {$else}
  931. Result := ''
  932. {$endif}
  933. else
  934. Result := AStoredValue.Value;
  935. end;
  936. procedure TStoredValues.SetStoredValue(const AName: string; Value: TStoredType);
  937. var
  938. AStoredValue: TStoredValue;
  939. begin
  940. AStoredValue := GetValue(AName);
  941. if AStoredValue = nil then begin
  942. AStoredValue := TStoredValue(Add);
  943. AStoredValue.Name := AName;
  944. AStoredValue.Value := Value;
  945. end
  946. else AStoredValue.Value := Value;
  947. end;
  948. function TStoredValues.GetValue(const AName: string): TStoredValue;
  949. var
  950. I: Integer;
  951. begin
  952. I := IndexOf(AName);
  953. if I < 0 then
  954. Result := nil
  955. else
  956. Result := Items[I];
  957. end;
  958. procedure TStoredValues.SetValue(const AName: string; StoredValue: TStoredValue);
  959. var
  960. I: Integer;
  961. begin
  962. I := IndexOf(AName);
  963. if I >= 0 then
  964. Items[I].Assign(StoredValue);
  965. end;
  966. procedure TStoredValues.SaveValues;
  967. var
  968. I: Integer;
  969. begin
  970. for I := 0 to Count - 1 do
  971. Items[I].Save;
  972. end;
  973. procedure TStoredValues.RestoreValues;
  974. var
  975. I: Integer;
  976. begin
  977. for I := 0 to Count - 1 do
  978. Items[I].Restore;
  979. end;
  980. end.