home *** CD-ROM | disk | FTP | other *** search
/ Chip 2001 September / Chip_2001-09_cd1.bin / zkuste / delphi / kolekce / d6 / RX275D6.ZIP / Units / RXINI.PAS < prev    next >
Pascal/Delphi Source File  |  2001-06-24  |  12KB  |  393 lines
  1. {*******************************************************}
  2. {                                                       }
  3. {         Delphi VCL Extensions (RX)                    }
  4. {                                                       }
  5. {         Copyright (c) 1995 AO ROSNO                   }
  6. {         Copyright (c) 1997, 1998 Master-Bank          }
  7. {                                                       }
  8. {*******************************************************}
  9.  
  10. unit RXIni;
  11.  
  12. interface
  13.  
  14. {$I RX.INC}
  15.  
  16. uses {$IFDEF WIN32} Windows, Registry, {$ELSE} WinTypes, WinProcs, {$ENDIF}
  17.   Classes, IniFiles, Graphics;
  18.  
  19. type
  20.   TReadObjectEvent = function(Sender: TObject; const Section,
  21.     Item, Value: string): TObject of object;
  22.   TWriteObjectEvent = procedure(Sender: TObject; const Section, Item: string;
  23.     Obj: TObject) of object;
  24.  
  25. { TRxIniFile }
  26.  
  27.   TRxIniFile = class(TIniFile)
  28.   private
  29.     FListItemName: PString;
  30.     FOnReadObject: TReadObjectEvent;
  31.     FOnWriteObject: TWriteObjectEvent;
  32.     function GetItemName: string;
  33.     procedure SetItemName(const Value: string);
  34.     function ReadListParam(const Section: string; Append: Boolean;
  35.       List: TStrings): TStrings;
  36.   protected
  37.     procedure WriteObject(const Section, Item: string; Index: Integer;
  38.       Obj: TObject); dynamic;
  39.     function ReadObject(const Section, Item, Value: string): TObject; dynamic;
  40.   public
  41.     constructor Create(const FileName: string);
  42.     destructor Destroy; override;
  43.     procedure Flush;
  44. {$IFNDEF WIN32}
  45.     procedure DeleteKey(const Section, Ident: String);
  46. {$ENDIF}
  47.     { ini-file read and write methods }
  48.     function ReadClearList(const Section: string; List: TStrings): TStrings;
  49.     function ReadList(const Section: string; List: TStrings): TStrings;
  50.     procedure WriteList(const Section: string; List: TStrings);
  51.     function ReadColor(const Section, Ident: string; Default: TColor): TColor;
  52.     procedure WriteColor(const Section, Ident: string; Value: TColor);
  53.     function ReadFont(const Section, Ident: string; Font: TFont): TFont;
  54.     procedure WriteFont(const Section, Ident: string; Font: TFont);
  55.     function ReadRect(const Section, Ident: string; const Default: TRect): TRect;
  56.     procedure WriteRect(const Section, Ident: string; const Value: TRect);
  57.     function ReadPoint(const Section, Ident: string; const Default: TPoint): TPoint;
  58.     procedure WritePoint(const Section, Ident: string; const Value: TPoint);
  59.     { properties }
  60.     property ListItemName: string read GetItemName write SetItemName;
  61.     property OnReadObject: TReadObjectEvent read FOnReadObject write FOnReadObject;
  62.     property OnWriteObject: TWriteObjectEvent read FOnWriteObject write FOnWriteObject;
  63.   end;
  64.  
  65. function StringToFontStyles(const Styles: string): TFontStyles;
  66. function FontStylesToString(Styles: TFontStyles): string;
  67. function FontToString(Font: TFont): string;
  68. procedure StringToFont(const Str: string; Font: TFont);
  69. function RectToStr(Rect: TRect): string;
  70. function StrToRect(const Str: string; const Def: TRect): TRect;
  71. function PointToStr(P: TPoint): string;
  72. function StrToPoint(const Str: string; const Def: TPoint): TPoint;
  73.  
  74. function DefProfileName: string;
  75. function DefLocalProfileName: string;
  76.  
  77. const
  78.   idnListItem  = 'Item';
  79.  
  80. implementation
  81.  
  82. Uses SysUtils, Forms, rxStrUtils {$IFNDEF WIN32}, Str16 {$ENDIF};
  83.  
  84. const
  85.   idnListCount = 'Count';
  86.   idnDefString = #255#255;
  87.   Lefts  = ['[', '{', '('];
  88.   Rights = [']', '}', ')'];
  89.  
  90. { Utilities routines }
  91.  
  92. function DefLocalProfileName: string;
  93. begin
  94.   Result := ChangeFileExt(Application.ExeName, '.INI');
  95. end;
  96.  
  97. function DefProfileName: string;
  98. begin
  99.   Result := ExtractFileName(DefLocalProfileName);
  100. end;
  101.  
  102. function FontStylesToString(Styles: TFontStyles): string;
  103. begin
  104.   Result := '';
  105.   if fsBold in Styles then Result := Result + 'B';
  106.   if fsItalic in Styles then Result := Result + 'I';
  107.   if fsUnderline in Styles then Result := Result + 'U';
  108.   if fsStrikeOut in Styles then Result := Result + 'S';
  109. end;
  110.  
  111. function StringToFontStyles(const Styles: string): TFontStyles;
  112. begin
  113.   Result := [];
  114.   if Pos('B', UpperCase(Styles)) > 0 then Include(Result, fsBold);
  115.   if Pos('I', UpperCase(Styles)) > 0 then Include(Result, fsItalic);
  116.   if Pos('U', UpperCase(Styles)) > 0 then Include(Result, fsUnderline);
  117.   if Pos('S', UpperCase(Styles)) > 0 then Include(Result, fsStrikeOut);
  118. end;
  119.  
  120. function FontToString(Font: TFont): string;
  121. begin
  122.   with Font do
  123.     Result := Format('%s,%d,%s,%d,%s,%d', [Name, Size,
  124.       FontStylesToString(Style), Ord(Pitch), ColorToString(Color),
  125.       {$IFDEF RX_D3} Charset {$ELSE} 0 {$ENDIF}]);
  126. end;
  127.  
  128. type
  129.   THackFont = class(TFont);
  130.  
  131. procedure StringToFont(const Str: string; Font: TFont);
  132. const
  133.   Delims = [',', ';'];
  134. var
  135.   FontChange: TNotifyEvent;
  136.   Pos: Integer;
  137.   I: Byte;
  138.   S: string;
  139. begin
  140.   FontChange := Font.OnChange;
  141.   Font.OnChange := nil;
  142.   try
  143.     Pos := 1;
  144.     I := 0;
  145.     while Pos <= Length(Str) do begin
  146.       Inc(I);
  147.       S := Trim(ExtractSubstr(Str, Pos, Delims));
  148.       case I of
  149.         1: Font.Name := S;
  150.         2: Font.Size := StrToIntDef(S, Font.Size);
  151.         3: Font.Style := StringToFontStyles(S);
  152.         4: Font.Pitch := TFontPitch(StrToIntDef(S, Ord(Font.Pitch)));
  153.         5: Font.Color := StringToColor(S);
  154. {$IFDEF RX_D3}
  155.         6: Font.Charset := TFontCharset(StrToIntDef(S, Font.Charset));
  156. {$ENDIF}
  157.       end;
  158.     end;
  159.   finally
  160.     Font.OnChange := FontChange;
  161.     THackFont(Font).Changed;
  162.   end;
  163. end;
  164.  
  165. function RectToStr(Rect: TRect): string;
  166. begin
  167.   with Rect do
  168.     Result := Format('[%d,%d,%d,%d]', [Left, Top, Right, Bottom]);
  169. end;
  170.  
  171. function StrToRect(const Str: string; const Def: TRect): TRect;
  172. var
  173.   S: string;
  174.   Temp: string[10];
  175.   I: Integer;
  176. begin
  177.   Result := Def;
  178.   S := Str;
  179.   if (S[1] in Lefts) and (S[Length(S)] in Rights) then begin
  180.     Delete(S, 1, 1); SetLength(S, Length(S) - 1);
  181.   end;
  182.   I := Pos(',', S);
  183.   if I > 0 then begin
  184.     Temp := Trim(Copy(S, 1, I - 1));
  185.     Result.Left := StrToIntDef(Temp, Def.Left);
  186.     Delete(S, 1, I);
  187.     I := Pos(',', S);
  188.     if I > 0 then begin
  189.       Temp := Trim(Copy(S, 1, I - 1));
  190.       Result.Top := StrToIntDef(Temp, Def.Top);
  191.       Delete(S, 1, I);
  192.       I := Pos(',', S);
  193.       if I > 0 then begin
  194.         Temp := Trim(Copy(S, 1, I - 1));
  195.         Result.Right := StrToIntDef(Temp, Def.Right);
  196.         Delete(S, 1, I);
  197.         Temp := Trim(S);
  198.         Result.Bottom := StrToIntDef(Temp, Def.Bottom);
  199.       end;
  200.     end;
  201.   end;
  202. end;
  203.  
  204. function PointToStr(P: TPoint): string;
  205. begin
  206.   with P do Result := Format('[%d,%d]', [X, Y]);
  207. end;
  208.  
  209. function StrToPoint(const Str: string; const Def: TPoint): TPoint;
  210. var
  211.   S: string;
  212.   Temp: string[10];
  213.   I: Integer;
  214. begin
  215.   Result := Def;
  216.   S := Str;
  217.   if (S[1] in Lefts) and (S[Length(Str)] in Rights) then begin
  218.     Delete(S, 1, 1); SetLength(S, Length(S) - 1);
  219.   end;
  220.   I := Pos(',', S);
  221.   if I > 0 then begin
  222.     Temp := Trim(Copy(S, 1, I - 1));
  223.     Result.X := StrToIntDef(Temp, Def.X);
  224.     Delete(S, 1, I);
  225.     Temp := Trim(S);
  226.     Result.Y := StrToIntDef(Temp, Def.Y);
  227.   end;
  228. end;
  229.  
  230. { TRxIniFile }
  231.  
  232. constructor TRxIniFile.Create(const FileName: string);
  233. begin
  234.   inherited Create(FileName);
  235.   FListItemName := NewStr(idnListItem);
  236.   FOnReadObject := nil;
  237.   FOnWriteObject := nil;
  238. end;
  239.  
  240. destructor TRxIniFile.Destroy;
  241. begin
  242.   DisposeStr(FListItemName);
  243.   inherited Destroy;
  244. end;
  245.  
  246. procedure TRxIniFile.Flush;
  247. var
  248. {$IFDEF WIN32}
  249.   CFileName: array[0..MAX_PATH] of WideChar;
  250. {$ELSE}
  251.   CFileName: array[0..127] of Char;
  252. {$ENDIF}
  253. begin
  254. {$IFDEF WIN32}
  255.   if (Win32Platform = VER_PLATFORM_WIN32_NT) then 
  256.     WritePrivateProfileStringW(nil, nil, nil, StringToWideChar(FileName,
  257.       CFileName, MAX_PATH))
  258.   else
  259.     WritePrivateProfileString(nil, nil, nil, PChar(FileName));
  260. {$ELSE}
  261.   WritePrivateProfileString(nil, nil, nil, StrPLCopy(CFileName,
  262.     FileName, SizeOf(CFileName) - 1));
  263. {$ENDIF}
  264. end;
  265.  
  266. {$IFNDEF WIN32}
  267. procedure TRxIniFile.DeleteKey(const Section, Ident: String);
  268. var
  269.   CSection: array[0..127] of Char;
  270.   CIdent: array[0..127] of Char;
  271.   CFileName: array[0..127] of Char;
  272. begin
  273.   WritePrivateProfileString(StrPLCopy(CSection, Section, SizeOf(CSection) - 1),
  274.     StrPLCopy(CIdent, Ident, SizeOf(CIdent) - 1), nil,
  275.     StrPLCopy(CFileName, FileName, SizeOf(CFileName) - 1));
  276. end;
  277. {$ENDIF}
  278.  
  279. function TRxIniFile.GetItemName: string;
  280. begin
  281.   Result := FListItemName^;
  282. end;
  283.  
  284. procedure TRxIniFile.SetItemName(const Value: string);
  285. begin
  286.   AssignStr(FListItemName, Value);
  287. end;
  288.  
  289. procedure TRxIniFile.WriteObject(const Section, Item: string; Index: Integer;
  290.   Obj: TObject);
  291. begin
  292.   if Assigned(FOnWriteObject) then FOnWriteObject(Self, Section, Item, Obj);
  293. end;
  294.  
  295. function TRxIniFile.ReadObject(const Section, Item, Value: string): TObject;
  296. begin
  297.   Result := nil;
  298.   if Assigned(FOnReadObject) then Result := FOnReadObject(Self, Section, Item, Value);
  299. end;
  300.  
  301. procedure TRxIniFile.WriteList(const Section: string; List: TStrings);
  302. var
  303.   I: Integer;
  304. begin
  305.   EraseSection(Section);
  306.   WriteInteger(Section, idnListCount, List.Count);
  307.   for I := 0 to List.Count - 1 do begin
  308.     WriteString(Section, ListItemName + IntToStr(I), List[I]);
  309.     WriteObject(Section, ListItemName + IntToStr(I), I, List.Objects[I]);
  310.   end;
  311. end;
  312.  
  313. function TRxIniFile.ReadListParam(const Section: string; Append: Boolean;
  314.   List: TStrings): TStrings;
  315. var
  316.   I, IniCount: Integer;
  317.   AssString: string;
  318. begin
  319.   Result := List;
  320.   IniCount := ReadInteger(Section, idnListCount, -1);
  321.   if IniCount >= 0 then begin
  322.     if not Append then List.Clear;
  323.     for I := 0 to IniCount - 1 do begin
  324.       AssString := ReadString(Section, ListItemName + IntToStr(I), idnDefString);
  325.       if AssString <> idnDefString then
  326.         List.AddObject(AssString, ReadObject(Section, ListItemName +
  327.           IntToStr(I), AssString));
  328.     end;
  329.   end;
  330. end;
  331.  
  332. function TRxIniFile.ReadClearList(const Section: string; List: TStrings): TStrings;
  333. begin
  334.   Result := ReadListParam(Section, False, List);
  335. end;
  336.  
  337. function TRxIniFile.ReadList(const Section: string; List: TStrings): TStrings;
  338. begin
  339.   Result := ReadListParam(Section, True, List);
  340. end;
  341.  
  342. function TRxIniFile.ReadColor(const Section, Ident: string;
  343.   Default: TColor): TColor;
  344. begin
  345.   try
  346.     Result := StringToColor(ReadString(Section, Ident,
  347.       ColorToString(Default)));
  348.   except
  349.     Result := Default;
  350.   end;
  351. end;
  352.  
  353. procedure TRxIniFile.WriteColor(const Section, Ident: string; Value: TColor);
  354. begin
  355.   WriteString(Section, Ident, ColorToString(Value));
  356. end;
  357.  
  358. function TRxIniFile.ReadRect(const Section, Ident: string; const Default: TRect): TRect;
  359. begin
  360.   Result := StrToRect(ReadString(Section, Ident, RectToStr(Default)), Default);
  361. end;
  362.  
  363. procedure TRxIniFile.WriteRect(const Section, Ident: string; const Value: TRect);
  364. begin
  365.   WriteString(Section, Ident, RectToStr(Value));
  366. end;
  367.  
  368. function TRxIniFile.ReadPoint(const Section, Ident: string; const Default: TPoint): TPoint;
  369. begin
  370.   Result := StrToPoint(ReadString(Section, Ident, PointToStr(Default)), Default);
  371. end;
  372.  
  373. procedure TRxIniFile.WritePoint(const Section, Ident: string; const Value: TPoint);
  374. begin
  375.   WriteString(Section, Ident, PointToStr(Value));
  376. end;
  377.  
  378. function TRxIniFile.ReadFont(const Section, Ident: string; Font: TFont): TFont;
  379. begin
  380.   Result := Font;
  381.   try
  382.     StringToFont(ReadString(Section, Ident, FontToString(Font)), Result);
  383.   except
  384.     { do nothing, ignore any exceptions }
  385.   end;
  386. end;
  387.  
  388. procedure TRxIniFile.WriteFont(const Section, Ident: string; Font: TFont);
  389. begin
  390.   WriteString(Section, Ident, FontToString(Font));
  391. end;
  392.  
  393. end.