Top.Mail.Ru
Мастера DELPHI, Delphi programming community Титульная страница Поиск, карта сайта Написать письмо 
| Новости | Поиск | FAQ | Статьи | Книги | Новости VCL |
| Форумы ЧАТ | Орешник | KOL и MCK |
Форумы -» Основная («Начинающим»)/ Базы / WinAPI / Компоненты / Сети / Media / Игры / Corba и COM / KOL / FreePascal / .Net / Прочее / RSDN.ORG

« предыдущая ветвь | форум | следующая ветвь »

сохранить шрифт memo в ini файле


Страницы:   1 2

anton773 ©   (2006-09-30 21:14:00) 

здравствуйте как сохранить параметры шрифта memo в ini файле

Loginov Dmitry   (2006-10-02 10:04:00) [1]

> Карелин Артем ©   (02.10.06 09:18)


А вот и нет! Стилю fsBold соответстует установленный младший бит.

Карелин Артем   (2006-10-02 09:18:00) [2]

По-моему приведение шрифта без стиля к байту и обратное преобразование байта 0 в стиль даст [fsBold]. Попраьте меня если что, ибо год уже не пишу на дельфи.

anton773   (2006-10-01 04:13:00) [3]

всем спасибо. разобрался!

Джо   (2006-10-01 03:39:00) [4]

Не корысти ради, а во благо, выкладываю плод бессоницы :о)


uses ..., IniFiles;

type
 TExtendedIniFile = class (TIniFile)
 public
   procedure WriteObject (AObject: TObject; const Section: string);
   procedure ReadObject (AObject: TObject; const Section: string);
 end;

implementation

uses ..., TypInfo;

type
 TPropInfo = record
   Name: string;
   Kind: TTypeKind;
 end;

 TPropInfoArray = array of TPropInfo;

function GetPropertyNames (AClass: TClass): TPropInfoArray;
var
 I,Cnt: Integer;
 Pti: PTypeInfo;
 PPropLst: PPropList;
begin
 Pti := PTypeInfo(AClass.ClassInfo);

 GetMem (PPropLst,High(TPropList));
 try
   Cnt := GetPropList(
     Pti,
     [tkInteger, tkChar, tkEnumeration, tkFloat, tkString,
     tkSet, tkWChar, tkLString, tkWString,tkInt64],
     PPropLst
   );

   SetLength(Result,Cnt);

   for I := 0 to Cnt-1 do
   begin
     Result[I].Name := PPropLst^[I].Name;
     Result[I].Kind := PPropLst^[I].PropType^.Kind;
   end;

 finally
   FreeMem (PPropLst);
 end;

end;

{ TExtendedIniFile }

procedure TExtendedIniFile.ReadObject(AObject: TObject; const Section: string);
var
 I: Integer;
 Props: TPropInfoArray;
 V: Variant;
begin
 Props := GetPropertyNames(AObject.ClassType);
 for I := 0 to High(Props) do
 begin
   case Props[I].Kind of
     tkInteger,tkInt64:
       SetOrdProp(AObject,Props[I].Name,ReadInteger(Section,Props[I].Name,0));

     tkString,tkLString,tkWString,tkChar,tkWChar:
       SetStrProp(AObject,Props[I].Name,ReadString(Section,Props[I].Name,''));

     tkFloat:
       SetFloatProp(AObject,Props[I].Name,ReadFloat(Section,Props[I].Name,0));

     tkEnumeration:
       SetEnumProp(AObject,Props[I].Name,ReadString(Section,Props[I].Name,''));

     tkSet:
       SetSetProp(
         AObject,
         Props[I].Name,
         ReadString (Section,Props[I].Name,'')
       );
   end;
 end;
end;

procedure TExtendedIniFile.WriteObject(AObject: TObject; const Section: string);
var
 I: Integer;
 Props: TPropInfoArray;
 V: Variant;
begin
 Props := GetPropertyNames(AObject.ClassType);

 for I := 0 to High(Props) do
 begin
   V := GetPropValue(AObject,Props[I].Name);

   case Props[I].Kind of
     tkInteger,tkInt64:
       WriteInteger (Section,Props[I].Name,V);

     tkString,tkLString,tkWString,tkChar,tkWChar:
       WriteString (Section,Props[I].Name,V);

     tkFloat:
       WriteFloat (Section,Props[I].Name,V);

     tkEnumeration:
         WriteString (Section,Props[I].Name,
           GetEnumProp(AObject,Props[I].Name));
     tkSet:
       begin
         WriteString(
           Section,
           Props[I].Name,
           GetSetProp(AObject,Props[I].Name,True)
         );
       end;
     else
       begin
         // Этого не должно случиться
         // ибо в GetPropertyNames мы фильтруем
         // только нужные нам типы свойств
         Assert (False,'Unsupported property type');
       end;
   end;

 end;
end;

end.


Пример:


procedure TForm1.Button1Click(Sender: TObject);
var
 Ini: TExtendedIniFile;
begin
 Ini := TExtendedIniFile.Create('d:\form.ini');
 try
   // Сохраняем, что угодно
   Ini.WriteObject(Self,'Form');
   Ini.WriteObject(Font,'Font');

   // Читаем, что угодно
   Ini.ReadObject(Font,'Font');
   Ini.ReadObject(Self,'Form');
 finally
   Ini.Free;
 end;
end;


---
ToDo:
1. Сделать рекурсивные чтение/запись "вложенных" классов, т.е., включить в "фильтр" в функции GetPropertyNames тип tkClass и обрабатывать его в соответствующих методах записи/чтения рекурсивно.
2. Устранить (возможную) утечку памяти в GetPropertyNames — чую, что она там должна быть, но уже лень проверять :0)

Джо   (2006-10-01 02:40:00) [5]

> [29] Юрий Зотов ©   (01.10.06 02:35)
> ObjectBinaryToText
> ObjectTextToBinary
>
> И всех дел.

У TFont нету WriteToStream, равно как и не выйдет TStream.WriteComponent, по очевидным причинам.

Юрий Зотов   (2006-10-01 02:35:00) [6]

ObjectBinaryToText
ObjectTextToBinary

И всех дел.
:o)

RASkov   (2006-10-01 02:15:00) [7]

надоже написать "просто испровляю ошибки" - и тут же с ошибкой;)
Вот правильно:
"я не настаиваю на своём решении, просто исправляю ошибки"
Усё... пора спать.

RASkov   (2006-10-01 02:12:00) [8]

С помощью Джо вот что осталось:

uses ..., IniFiles;
.....
procedure GetFontFromIni(const FlIni: String; Fnt: TFont);
var FIni: TIniFile;
begin
 FIni:= TIniFile.Create(FlIni);
 Fnt.Name:=FIni.ReadString('FONTDATA', 'FName', 'Courier New Cyr');
 Fnt.Color:=TColor(FIni.ReadInteger('FONTDATA', 'FColor', clBlack));
 Fnt.Pitch:=TFontPitch(FIni.ReadInteger('FONTDATA', 'FPitch', 0));
 Fnt.Size:=FIni.ReadInteger('FONTDATA', 'FSize', 8);
 Fnt.Style:=TFontStyles(Byte(FIni.ReadInteger('FONTDATA', 'FStyle', 0)));
 FIni.Free;
end;

procedure SetFontToIni(const FlIni: String; Fnt: TFont);
var FIni: TIniFile;
begin
 FIni:= TIniFile.Create(FlIni);
 FIni.WriteString('FONTDATA', 'FName', Fnt.Name);
 FIni.WriteInteger('FONTDATA', 'FColor', Fnt.Color);
 FIni.WriteInteger('FONTDATA', 'FPitch', ORD(Fnt.Pitch));
 FIni.WriteInteger('FONTDATA', 'FSize', Fnt.Size);
 FIni.WriteInteger('FONTDATA', 'FStyle', Byte(Fnt.Style));
 FIni.Free;
end;

procedure TForm1.FormCreate(Sender: TObject);
begin
 GetFontFromIni(ExtractFileDir(ParamStr(0))+'\memo.ini', Memo1.Font);
end;

procedure TForm1.FormClose(Sender: TObject; var Action: TCloseAction);
begin
 SetFontToIni(ExtractFileDir(ParamStr(0))+'\memo.ini', Memo1.Font);
end;

[19] - было тренировкой:)
ЗЫ я не настаиваю на своём решении, просто испровляю ошибки...
ЗЫЫ > anton773 технология [16] усе равно гибче , тем самым лучше . ИМХО.

RASkov   (2006-10-01 01:59:00) [9]

> [23] Джо ©   (01.10.06 01:44)

Извеняюсь за

> [Error] Unit1.pas(96): Invalid typecast

У меня Integer был :)
Джо, Спасибо.

RASkov   (2006-10-01 01:51:00) [10]

> [24] Джо ©   (01.10.06 01:46)

Согласен на 150%


> [23] Джо ©   (01.10.06 01:44)

[Error] Unit1.pas(96): Invalid typecast

Джо   (2006-10-01 01:46:00) [11]

Но я бы все-равно рекоммендовал [16], как пример гораздо более универсального подхода :)

Джо   (2006-10-01 01:44:00) [12]

> [22] RASkov   (01.10.06 01:41)
> А нельзя ли как-то и от GetFontStyle избавится? ну или тоже
> к одной строчке привести...?

var
 N: Byte;
begin
 Font.Style := TFontStyles(N);
end;

RASkov   (2006-10-01 01:41:00) [13]

В процедуре SetFontToIni
procedure SetFontToIni(const FlIni: String; Fnt: TFont);
...
//исправить на
FIni.WriteInteger('FONTDATA', 'FStyle', Byte(Fnt.Style));
...
end;

ну и выделить всю FontStyleToInt и нажать Del :)
затем переписать константы :)

> [21] RASkov   (01.10.06 01:22)

Да... но только теперь нужно константы переделать и...
(забыл в первый раз:) добавить FONTS (зачеркнутый)

> [20] Джо ©   (01.10.06 01:14)

А нельзя ли как-то и от GetFontStyle избавится? ну или тоже к одной строчке привести...?

RASkov   (2006-10-01 01:22:00) [14]

> [20] Джо ©   (01.10.06 01:14)

Блин, точно

> Что ж за день такой?!

Джо   (2006-10-01 01:14:00) [15]

> [19] RASkov   (01.10.06 01:05)

Простите, но это ужас! :)
Вот, например — зачем нужна функция FontStyleToInt? Всю ее можно свести к однойпростой строке: N := Byte(Font.Style).

RASkov   (2006-10-01 01:05:00) [16]

> anton773


Чуть и я добавлю....

uses ..., IniFiles;
.....
const
  FONTB: set of Byte=[2, 6, 10, 14];
  FONTI: set of Byte=[4, 6, 12, 14];
  FONTU: set of Byte=[8, 10, 12, 14];
......

implementation

{$R *.dfm}

function GetFontStyle(const N: Integer): TFontStyles;
begin
 Result:=[];
 if N in FONTB then Result:=Result+[fsBold];
 if N in FONTI then Result:=Result+[fsItalic];
 if N in FONTU then Result:=Result+[fsUnderline];
end;

function FontStyleToInt(const Fn: TFontStyles): Integer;
begin
 Result:=0;
 if fsBold in Fn then Result:=Result+2;
 if fsItalic in Fn then Result:=Result+4;
 if fsUnderLine in Fn then Result:=Result+8;
end;

procedure GetFontFromIni(const FlIni: String; Fnt: TFont);
var FIni: TIniFile;
begin
 FIni:= TIniFile.Create(FlIni);
 Fnt.Name :=FIni.ReadString('FONTDATA', 'FName', 'Courier New Cyr');
 Fnt.Color:=TColor(FIni.ReadInteger('FONTDATA', 'FColor', clBlack));
 Fnt.Pitch:=TFontPitch(FIni.ReadInteger('FONTDATA', 'FPitch', 0));
 Fnt.Size :=FIni.ReadInteger('FONTDATA', 'FSize', 8);
 Fnt.Style:=GetFontStyle(FIni.ReadInteger('FONTDATA', 'FStyle', 0));
 FIni.Free;
end;

procedure SetFontToIni(const FlIni: String; Fnt: TFont);
var FIni: TIniFile;
begin
 FIni:= TIniFile.Create(FlIni);
 FIni.WriteString ('FONTDATA', 'FName', Fnt.Name);
 FIni.WriteInteger('FONTDATA', 'FColor', Fnt.Color);
 FIni.WriteInteger('FONTDATA', 'FPitch', ORD(Fnt.Pitch));
 FIni.WriteInteger('FONTDATA', 'FSize', Fnt.Size);
 FIni.WriteInteger('FONTDATA', 'FStyle', FontStyleToInt(Fnt.Style));
 FIni.Free;
end;

procedure TForm1.FormCreate(Sender: TObject);
begin
 GetFontFromIni(ExtractFilePath(ParamStr(0))+'memo.ini', Memo1.Font);
end;

procedure TForm1.FormClose(Sender: TObject; var Action: TCloseAction);
begin
 SetFontToIni(ExtractFilePath(ParamStr(0))+'memo.ini', Memo1.Font);
end;

Джо   (2006-09-30 22:55:00) [17]

> Равно как и имплементацию SavePublishedProperties.

Что ж за день такой?! Имел в виду: LoadPublishedProperties.

Джо   (2006-09-30 22:54:00) [18]

> [16]

Подходит, естественно, не только для TFont.

Джо   (2006-09-30 22:52:00) [19]

> [9] anton773 ©   (30.09.06 22:10)
>
> > это имхо перректально, для особенных извращенцев
>
> Согласен. Поэтому я и обратился на форум для более изящных
> решений

Вот изящно :)


uses TypInfo;

type
 TPropInfo = record
   Name: string;
   Kind: TTypeKind;
 end;

 TPropInfoArray = array of TPropInfo;

function GetPropertyNames (AClass: TClass): TPropInfoArray;
var
 I,Cnt: Integer;
 Pti: PTypeInfo;
 PPropLst: PPropList;
begin
 Pti := PTypeInfo(AClass.ClassInfo);

 GetMem (PPropLst,High(TPropList));
 try
   Cnt := GetPropList(
     Pti,
     [tkInteger, tkChar, tkEnumeration, tkFloat,
     tkString, tkSet, tkClass, tkMethod, tkWChar, tkLString, tkWString,
     tkVariant, tkArray, tkRecord, tkInterface, tkInt64, tkDynArray],
     PPropLst
   );

   SetLength(Result,Cnt);

   for I := 0 to Cnt-1 do
   begin
     Result[I].Name := PPropLst^[I].Name;
     Result[I].Kind := PPropLst^[I].PropType^.Kind;
   end;

 finally
   FreeMem (PPropLst);
 end;
end;

procedure SavePublishedProperties (Obj: TObject; FileName, Section: string);
var
 I: Integer;
 Ini: TIniFile;
 Props: TPropInfoArray;
begin
 Props := GetPropertyNames(Obj.ClassType);

 Ini := TIniFile.Create(FileName);
 try
   for I := 0 to High(Props) do
   begin
     case Props[I].Kind of
       tkInteger:
         begin
           Ini.WriteInteger(Section,Props[I].Name,GetOrdProp(Obj,Props[I].Name));
         end;
       tkString,tkLString:
         begin
           Ini.WriteString(Section,Props[I].Name,GetStrProp(Obj,Props[I].Name));
         end;
       else
         begin
           //raise Exception.Create('Unsupported property type');
         end;
     end;
   end;
 finally
   Ini.Free;
 end;
end;



Пример использования:


procedure TForm1.Button1Click(Sender: TObject);
var
 Fnt: TFont;
begin
 Fnt := TFont.Create;
 try
   SavePublishedProperties(Fnt,'d:\font.ini','Font');
 finally
   Fnt.Free;
 end;
end;


Код, возможно, местами некорректен и, во всяком случае, неполон. Запись остальных типов свойств предоставляю в качестве ДЗ. Равно как и имплементацию SavePublishedProperties.
:)

Loginov Dmitry   (2006-09-30 22:44:00) [20]

и не забыть SaveFontToIniFile

:)

Страницы:   1 2

Наверх

Титульная страница Поиск, карта сайта Написать письмо