Кидаю сорцы... не мог бы кто-нибдудь чаго-нибудь добавить

← →
NetBreaker666 © (2003-04-15 15:53) [0]

Если здесь есть кто-нибудь, кому совсем нечего делать, то отшлифуйте это г... и было бы не плохо туда зафигачить TUpDown(как в SpinEdit"e) что"б в случае если редактируется какой-нибудь Integer или Float, то нажатие приводило бо к изменению значения на какое-нибудь Delta (тоже Published property)

unit AutoHistoryCombo; interface uses Windows, SysUtils, Classes, Controls, StdCtrls, SyncObjs, TypInfo, SysConst, variants; type TUpdateReason=(urChange, urEnter, urExit, urReturn, urEscape); TUpdateReasons=set of TUpdateReason; TUpdateProc=procedure(Sender:TObject; Reason:TUpdateReason; var Update:Boolean) of object; TUpdateExceptionProc=procedure(Sender:TObject; Reason:TUpdateReason; e:Exception) of object; type TAutoHistoryCombo = class(TComboBox) private { Private declarations } fSFN:String; fao:TObject; fprop:ShortString; fobjup,ftextup:TUpdateProc; fOnChg, fOnEnt, fOnExt:TNotifyEvent; fTUEP:TUpdateExceptionProc; fOUEP:TUpdateExceptionProc; fOUR,fTUR, fUHR:TUpdateReasons; fKeyDown:TKeyEvent; procedure setHFN(S:String); protected { Protected declarations } property Style; procedure TextChange(Sender:TObject); procedure _Enter(Sender:TObject); procedure _Exit(Sender:TObject); procedure _KeyDown(Sender: TObject; var Key: Word; Shift: TShiftState); public { Public declarations } constructor Create(AOwner:TComponent);override; procedure SaveHistory; destructor Destroy;override; procedure UpdateObject; Procedure UpdateText; published { Published declarations } procedure AddToHistory(S:String=""); property HistoryFileName:String read fSFN write setHFN; property AssignedObject:TObject read fao write fao; property ObjectProperty:ShortString read fprop write fprop; property ObjectUpdateReasons:TUpdateReasons read fOUR write fOUR; property TextUpdateReasons:TUpdateReasons read fTUR write fTUR; property HistroyUpdateReasons:TUpdateReasons read fUHR write fUHR; property OnObjectUpdate:TUpdateProc read fobjup write fobjup; property OnTextUpdate:TUpdateProc read ftextup write ftextup; property OnTextUpdateException:TUpdateExceptionProc read fTUEP write fTUEP; property OnObjectUpdateException:TUpdateExceptionProc read fOUEP write fOUEP; property OnChange:TNotifyEvent read fOnChg write fOnChg; property OnEnter:TNotifyEvent read fOnEnt write fOnEnt; property OnExit:TNotifyEvent read fOnExt write fOnExt; property OnKeyDown:TKeyEvent read fKeyDown write fKeyDown; end; procedure Register; implementation procedure Register; begin RegisterComponents("SeisVis", [TAutoHistoryCombo]); end; constructor TAutoHistoryCombo.Create(AOwner:TComponent); Begin Style:=csDropDown; TComboBox(self).OnEnter:=_Enter; TComboBox(self).OnExit:=_Exit; TComboBox(Self).OnChange:=TextChange; TComboBox(self).OnKeyDown:=_KeyDown; inherited; End; procedure TAutoHistoryCombo.SaveHistory; var CriticalSection:TCriticalSection; Begin CriticalSection:=TCriticalSection.Create; CriticalSection.Enter; try if fSFN<>"" then Items.SaveToFile(fSFN); except on e:Exception do Begin CriticalSection.Release; CriticalSection.Free; raise e; end; end; CriticalSection.Release; CriticalSection.Free; End; destructor TAutoHistoryCombo.Destroy; Begin inherited; End; procedure TAutoHistoryCombo.AddToHistory(S:String=""); Begin if s<>"" then Begin if Items.IndexOf(S)<0 then Begin Items.Add(S); saveHistory; End; End else Begin if Items.IndexOf(text)<0 then Begin Items.Add(Text); saveHistory; End; End; End; procedure TAutoHistoryCombo.setHFN(S:String); var CriticalSection:TCriticalSection; Begin CriticalSection:=TCriticalSection.Create; CriticalSection.Enter; try try Items.LoadFromFile(S); fSFN:=S; except try Items.Clear; Items.SaveToFile(S); finally fSFN:=S; end; end; except on e:Exception do Begin CriticalSection.Release; CriticalSection.Free; raise e; end; end; CriticalSection.Release; CriticalSection.Free; End;

← →
NetBreaker666 © (2003-04-15 15:53) [1]

procedure TAutoHistoryCombo.UpdateObject;
(*var tp:TTypeKind;
err:Integer;
f:Extended;*)

Begin
if (fao=nil)or(fprop="") then exit;
if not IsPublishedProp(fao,fprop) then exit;
SetPropValue(fao,fprop,Text);
(*
tp:=PropType(fao,fprop);
case tp of
tkInteger:setEnumProp(fao,fprop,Text);
tkInt64:setInt64Prop(fao,fprop,StrToInt64(text));
tkFloat:Begin
val(text,f,err);
if err<>0 then EConvertError.CreateResFmt(@SInvalidFloat, [text]);
SetFloatProp(fao,fprop,f);
End;
tkString, tkLString:SetStrProp(fao,fprop,Text);
tkWString:SetWideStrProp(fao,fprop,Text);
tkVariant:SetVariantProp(fao,fprop,Text);
tkEnumeration:SetEnumProp(fao, fprop, Text);
tkChar,tkWChar:SetPropValue(fao,fprop,Text);
else raise Exception.CreateFmt("Unsupported property type "%d"",[Ord(tp)]);
end;
*)
End;

Procedure TAutoHistoryCombo.UpdateText;
var v:Variant;
Begin
if (fao=nil)or(fprop="") then exit;
if not IsPublishedProp(fao,fprop) then exit;
v:=GetPropValue(fao,fprop,false);
Text:=v;
End;

procedure TAutoHistoryCombo.TextChange(Sender:TObject);
var c:Boolean;
Begin
if Assigned(fOnChg) then fOnChg(Sender);
if urChange in fUHR then AddToHistory;
if urChange in fOUR
then Begin
c:=true;
if assigned(fobjup) then fobjup(self,urChange,c);
if c then
try
UpdateObject;
except
on e:Exception do if assigned(fOUEP) then fOUEP(self,urChange,e);
end;
end;
End;

procedure TAutoHistoryCombo._Enter(Sender:TObject);
var c:Boolean;
Begin
if Assigned(fOnEnt) then fOnEnt(Sender);
if urEnter in fUHR then AddToHistory;
if urEnter in fOUR
then Begin
c:=true;
if assigned(fobjup) then fobjup(self,urEnter,c);
if c then
try
UpdateObject;
except
on e:Exception do if assigned(fOUEP) then fOUEP(self,urEnter,e);
end;
exit;
end;

if urEnter in fTUR
then Begin
c:=true;
if assigned(ftextup) then ftextup(self,urEnter,c);
if c then
try
UpdateText;
except
on e:Exception do if assigned(fTUEP) then fTUEP(self,urEnter,e);
end;
end;

End;
procedure TAutoHistoryCombo._Exit(Sender:TObject);
var c:Boolean;
Begin
if Assigned(fOnExt) then fOnExt(Sender);
if urExit in fUHR then AddToHistory;
if urExit in fOUR
then Begin
c:=true;
if assigned(fobjup) then fobjup(self,urExit,c);
if c then
try
UpdateObject;
except
on e:Exception do if assigned(fOUEP) then fOUEP(self,urExit,e);
end;
exit;
end;

if urExit in fTUR
then Begin
c:=true;
if assigned(ftextup) then ftextup(self,urExit,c);
if c then
try
UpdateText;
except
on e:Exception do if assigned(fTUEP) then fTUEP(self,urExit,e);
end;
end;
End;

procedure TAutoHistoryCombo._KeyDown(Sender: TObject; var Key: Word;
Shift: TShiftState);
var c:Boolean;
Begin
if Assigned(fKeyDown) then fKeyDown(Sender,Key,Shift);
if ((urReturn in fUHR)and(Key=VK_RETURN))or((urEscape in fUHR)and(Key=VK_Escape)) then AddToHistory;
if (urReturn in fOUR)and(Key=VK_RETURN)
then Begin
c:=true;
if assigned(fobjup) then fobjup(self,urReturn,c);
if c then
try
UpdateObject;
except
on e:Exception do if assigned(fOUEP) then fOUEP(self,urReturn,e);
end;
end else

if (urReturn in fTUR)and(Key=VK_RETURN)
then Begin
c:=true;
if assigned(ftextup) then ftextup(self,urReturn,c);
if c then
try
UpdateText;
except
on e:Exception do if assigned(fTUEP) then fTUEP(self,urReturn,e);
end;
end;

if (urEscape in fOUR)and(Key=VK_ESCAPE)
then Begin
c:=true;
if assigned(fobjup) then fobjup(self,urEscape,c);
if c then
try
UpdateObject;
except
on e:Exception do if assigned(fOUEP) then fOUEP(self,urEscape,e);
end;
end else

if (urEscape in fTUR)and(Key=VK_ESCAPE)
then Begin
c:=true;
if assigned(ftextup) then ftextup(self,urEscape,c);
if c then
try
UpdateText;
except
on e:Exception do if assigned(fTUEP) then fTUEP(self,urEscape,e);
end;
end;

End;

end.

← →
ZeroDivide © (2003-04-15 16:01) [2]

Ну ты г.. накидал, лопатой не отшлифовать :)

← →
Polevi © (2003-04-15 16:26) [3]

:-)

← →
NetBreaker666 © (2003-04-15 16:59) [4]

> Ну ты г.. накидал, лопатой не отшлифовать :)

Если делать нечего, то и руками можна :)

← →
alxx © (2003-04-15 17:32) [5]

Главное сапоги резиновые повыше натянуть. Авось не потонешь.

← →
REA © (2003-04-15 17:44) [6]

Я бы разделил сохранение и компонент - вдруг я в поток засунуть захочу или в реестр? Или хуже того в базу.

← →
NetBreaker666 © (2003-04-15 18:40) [7]

> Я бы разделил сохранение и компонент - вдруг я в поток засунуть
> захочу или в реестр? Или хуже того в базу.

Ну тык раздели... сделай onSaveHistory и OnLoadHistory... кстати, если в имени файла ничего не указать, то он ничего никуда сохранять не будет.

Я просто делал спеша, чтоб успеть по-быстрее, так что если никто не доделает, до доделаю я... только не скоро :(

← →
Тётя Вася (2003-04-15 19:11) [8]

Ух, какие простыни! Прям как у меня в тазике.
А чё оно делает?

← →
vuk © (2003-04-15 19:24) [9]

Нафига критические секции в SaveHistory и setHFN? Да и использование исключений там какое-то странное...

← →
NetBreaker666 © (2003-04-15 20:17) [10]

> Нафига критические секции в SaveHistory и setHFN? Да и использование
> исключений там какое-то странное...

Fuck!!! Точно, изначально мутексы хотел :) Ошибочка вышла... а мдексы для того, чтоб два запущенных приложения (или две разных формы одного и того же класса) не конфликтовали...

С учетом реализации SaveToFile, конфликтов не будет.

> vuk © (15.04.03 20:25)
> С учетом реализации SaveToFile, конфликтов не будет.

Серьезно? А вот мне так не кажется... я уже наталкивался на такую фигню, сделал даже специальный модуль для безопасной работы с TStringList"ом

А какие могут быть проблемы при сохранении? Там же поток создается с флагом fmCreate...

> А какие могут быть проблемы при сохранении? Там же поток
> создается с флагом fmCreate...

Да хз... ладно, забей, действительно некрасиво смотрится :)

Кидаю сорцы... не мог бы кто-нибдудь чаго-нибудь добавить Найти похожие ветки