Форум: "Потрепаться";
Текущий архив: 2003.05.01;
Скачать: [xml.tar.bz2];

Вниз

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

← →
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!!! Точно, изначально мутексы хотел :) Ошибочка вышла... а мдексы для того, чтоб два запущенных приложения (или две разных формы одного и того же класса) не конфликтовали...

---

← →
vuk   (2003-04-15 20:25) [11]

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

---

← →
NetBreaker666   (2003-04-15 21:10) [12]

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

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

---

← →
vuk   (2003-04-15 21:15) [13]

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

---

← →
NetBreaker666   (2003-04-16 15:01) [14]

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

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

---

Страницы: 1 вся ветка

Форум: "Потрепаться";
Текущий архив: 2003.05.01;
Скачать: [xml.tar.bz2];

Наверх

Память: 0.49 MB
Время: 0.007 c