Casa
Top.Mail.Ru Yandeks.Metrika
Fórum: "Agarrar";
Arquivo atual: 2003.05.01;
Download: [xml.tar.bz2];

Para baixo

Estou jogando tipos ... alguém poderia adicionar um pouco Encontre agências semelhantes


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;*)

Começar
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;
Começar
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;
Começar
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
tentar
UpdateObject;
exceto
on e:Exception do if assigned(fOUEP) then fOUEP(self,urChange,e);
end;
end;
End;


procedure TAutoHistoryCombo._Enter(Sender:TObject);
var c:Boolean;
Começar
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
tentar
UpdateObject;
exceto
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
tentar
UpdateText;
exceto
on e:Exception do if assigned(fTUEP) then fTUEP(self,urEnter,e);
end;
end;

End;
procedure TAutoHistoryCombo._Exit(Sender:TObject);
var c:Boolean;
Começar
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
tentar
UpdateObject;
exceto
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
tentar
UpdateText;
exceto
on e:Exception do if assigned(fTUEP) then fTUEP(self,urExit,e);
end;
end;
End;

procedure TAutoHistoryCombo._KeyDown(Sender: TObject; var Key: Word;
Deslocamento: TShiftState);
var c:Boolean;
Começar
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
tentar
UpdateObject;
exceto
on e:Exception do if assigned(fOUEP) then fOUEP(self,urReturn,e);
end;
fim mais

if (urReturn in fTUR)and(Key=VK_RETURN)
then Begin
c:=true;
if assigned(ftextup) then ftextup(self,urReturn,c);
if c then
tentar
UpdateText;
exceto
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
tentar
UpdateObject;
exceto
on e:Exception do if assigned(fOUEP) then fOUEP(self,urEscape,e);
end;
fim mais

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

End;




final.



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 filial inteira

Fórum: "Agarrar";
Arquivo atual: 2003.05.01;
Download: [xml.tar.bz2];

em cima





Memória: 0.61 MB
Hora: 0.028 c
1-519
() utLaw
2003-04-20 23:15
2003.05.01
Alterando a cor do texto da célula em um StringGrid


14-699
smb
2003-04-13 21:57
2003.05.01
Pergunta do campo da psicologia


9-369
Anat
2002-08-24 18:06
2003.05.01
Eles precisam de missões?


1-576
Ptr
2003-04-18 13:25
2003.05.01
Manipulador OnKeyDown.


14-765
acsoft
2003-04-13 19:28
2003.05.01
Quem entende o NMSMTP





afrikaans albanês Arabic armênio azerbaijano basco belarusian Bulgarian catalão Chinês simplificado) Chinês tradicional) croata checo dinamarquês Dutch Inglês estoniano filipino Finnish French
Galego georgiano German grego crioulo haitiano hebraico hindi húngaro islandês Indonesian irlandês Italian Japanese Korean letão lituano macedónio Malay maltês Norwegian
persa polonês Portuguese Romeno Russa sérvio Slovak esloveno Espanhol swahili sueco tailandês turco ucraniano urdu vietnamita galês ídiche bengali bósnio
cebuano esperanto gujarati hausa hmong igbo javanês kannada khmer lao latino maori marata mongol Nepali punjabi somali tâmil telugu yoruba
zulu
Английский francês Alemão Italiano Португальский russo Espanhol