MEtodların isimleri anlaşılır olduğu için pek fazla açıklama yok.
Burada TSMART_RECORD nesnesine dikkatinizi çekmek isterim.
Bu nesneyi database, record, rtti üçlemesi ile ilgili cansıkıcı işlemlerden kurtulmak için yazmıştım ve ihtiyaç duydukça geliştiriyorum.
örneğin bu nesneden Personel bilgilerini tutan bir sınıf üretirsek
Kod: Tümünü seç
type
personel = class(TSMART_OBJECT)
public
ID : Integer;
ADI : String;
SOYADI : String;
TELEFON : String;
End;
Procedure Foo
var
ds: TDataset;
o : personel;
i : Integer;
Begin
o := Personel.create;
try
for i 0 to o.FieldCount -1 do
Showmessage(Format('%s %d %s',[o.FieldName[i],Integer(o.FieldType[i]), o.FieldTypeName[i]]);
personel.fromdataset(ds);
dataset.append;
personel.todataset(ds);
finally
end;
End;
veyahut xml verisine dönüştürebilir veya xmlden okuma yapabilirsiniz
Not : Aşağıdaki class veya metodlar 3. parti bileşenler kullanmaktadır eğer bu bileşenler yok ise o metodları ya da sınıfları unitten ve uses dan çıkarmalısınız.
FibPlus bileşen setini kullanmıyorsanız dbcommonmethods isimli sınıfı unitten çıkarmalı ve pFIBDataSet, pFIBQuery, fib kelimelerini ussdan çıkarmalısınız
overbyte bileşen setini kullanmıyorsanız NetUtilsEx sınıfını ve OverbyteIcsWndControl, OverbyteIcsHttpProt useslarını çıkarmalısınız.
encrypt ve decycrpt metodlarının içeriğini güvenlik gereği boşalttım.
Metodlardan çok işe yarayanlar da var gereksiz olanlar da artık hangisi işinize yararsa.
Kod: Tümünü seç
unit ClassUtilsEx;
(*
String, Math, Form, database vs... ile ilgili çeşitli metodlar barındırır
*)
//{$DEFINE DEBUG_MODE}
interface
uses
StdCtrls,DB,pFIBDatabase,Forms,Windows, Messages, SysUtils, Variants, Classes,
Controls,DateUtils,IniFiles,StrUtils,Graphics,Dialogs,Consts,Math,pFIBDataSet,
pFIBQuery,fib,XMLIntf, XMLDoc,xmldom,Rtti,Grids,DBGrids,TypInfo,WinINet,
OverbyteIcsWndControl, OverbyteIcsHttpProt,Registry,Generics.Collections;
type
StringArray = array of String;
TVarDynArray = array of Variant;
TVersionCompareResult = (vcrEqual = 0 , vcrCurrentNewer = 1, vcrCurrentOlder = 2);
TVersion = record
Major,
Minor,
Release,
Build : Integer;
Function CompareWith( aCompareWith : TVersion): TVersionCompareResult;
Function FromStr(s:String;Seperator : String = '.'): Boolean;
end;
TSMART_RECORD = class
protected
fRootNodeName : AnsiString;
strict private
fOnAfterLoad : TNotifyEvent;
function GetDefaultValue( ft : TfieldType):Variant;
function GetFieldName( Index : Integer):AnsiString;
function GetFieldValue(Index : Integer): Variant;
procedure SetFieldValue(Index : Integer; v: Variant);
function GetVarType(index : Integer): TTypeKind;
function GetVarTypeAsStr(index : Integer): String;
Procedure DoAfterLoad;
public
constructor create;virtual;
destructor destroy;virtual;
procedure GetValue(ds : Tdataset; FieldName : AnsiString);
procedure GetValuesFromDataset(ds : TDataSet);
procedure ToDataset( ds : TDataSet);
function ToXML : IXMLDocument;overload;
function ToXML( withHeader : Boolean): AnsiString;overload;
procedure FromXML( XML : AnsiString);overload;
procedure FromXML( XML : IXMLDocument);overload;
Function FieldCount : Integer;
function FieldExists( const aFieldName : string) : Boolean;
property FieldName[index : Integer] :AnsiString read GetFieldName;
property FieldValue[index : Integer] : Variant read GetFieldValue write SetFieldValue;
property FieldType[index : Integer] : TTypeKind read GetVarType;
property FieldTypeName[index : Integer] : String read GetVarTypeAsStr;
{
bu metod iki şeyi kontrol eder
1. bu isimde bir kayıt var mı : true
2. var olan bu kayıt bir event member ya da frootnode mi
}
function IsValidField(aFieldName : string): Boolean;
Procedure SetDefault;virtual; abstract;
published
property OnAfterLoad : TNotifyEvent read fOnAfterLoad write fOnAfterLoad;
end;
ECustomizedException = class(Exception);
MathEx = class
class Function SumOfIntArray(p : array of Integer): Integer;
class function AvgOfIntArray(p : array of Integer): Integer;
{Kesir kısmını her zaman üste yuvarlarken Tamsayı kısmını üste yuvarlamıyor
normal yuvarlamaya tabii tutuyor. Bilginize.}
class function roundUp( RoundValue: real; const aDigit : TRoundToRange = 0): real;
Class Function CalcPercentAt( Value , _Percent : Double): Double;overload;
Class Function CalcPercentAt( Value , _Percent : Integer): Integer;overload;
class Function BetWeen(value,a,b : Extended): Boolean;
end;
StrUtilsEx = class
class Function GiveInTags(aValue,tagStart, tagEnd : AnsiString; iFromHere : Integer = 1):AnsiString;
class Procedure DeleteInTags( var aValue : AnsiString; tagStart,tagEnd : AnsiString;
iFromHere : Integer = 1;DeleteTagsToo : Boolean = true);
class Function FormatEx(const _Format: AnsiString; const _Args: array of const):AnsiString;
class function MBoxStrPA(v : Variant): PAnsiChar;
class Function ArrayToMultiLineStr(v: array of Variant) : AnsiString;
class Function BytesToHex( b: TBytes): AnsiString;
class Function HexToBytes( h : AnsiString): TBytes;
class Function StrToHex(const Buffer : AnsiString): AnsiString;
class Function HexToStr(const Buffer : AnsiString):AnsiString;
class function XORStr( const s1 : AnsiString; const s2: AnsiString):AnsiString;
class procedure XORBytes( var Value : TBytes; const xorv: TBytes);
class function FixedNumber(FixCount : Integer; Value : Integer): AnsiString;
class Procedure Add(var s : AnsiString; ValueToBeAdded : Variant);
class Procedure AddLine(var s: AnsiString; ValueToBeAdded : Variant);
class function NumbersOnly( Const s : AnsiString; const ExceptThose: AnsiString = ''): AnsiString;
class function AsDouble( const s: AnsiString): AnsiString;
class Function Encrypt( s : AnsiString; password : AnsiString):AnsiString;
class Function Decrypt( s : AnsiString; password : AnsiString): AnsiString;
class Function StringMultiReplace(Value : AnsiString; OldValues,NewValues:Variant;
Flags:TReplaceFlags):AnsiString;
class function CopyAt( s: AnsiString; index : Integer): AnsiString;
class function ExplodeStr( s : AnsiString; Seperators : array of String; TrimAndSkipEmptyStrs : Boolean = true): StringArray;
class function AnsiUpperCaseTr( s : AnsiString): AnsiString;
class function AnsiLowerCaseTr( s : AnsiString): AnsiString;
class function AnsiSameStrTr( a,b : AnsiString; ignorecharcase : Boolean=False): Boolean;
class function ConvertToEnglishChar( t : AnsiString): AnsiString;
end;
DynArrayEx = class
class procedure AddItem( var ArrayValue : Variant; item : Variant);
class procedure RemoveItem( var ArrayValue : Variant; item : Variant; RemoveAll : Boolean = True);
class Function VarArrayIDX(Value,ArrayValue : Variant):Integer;
class Function InArray(Value,ArrayValue: Variant): Boolean;
class procedure Grow(var arr : TBytes; const Count : Integer= 1);
class Procedure Insert( var arr : TBytes; const ins : TBytes; index : Integer);
class Function Copy( const arr: TBytes; const index : Integer; const Count: Integer): TBytes;
class Procedure Delete(var arr : TBytes; const index,count : Integer);
class Function IsSameByteArray( a,b : TBytes):Boolean;overload;
class Function IsSameByteArray( a,b : array of byte):Boolean;overload;
end;
TProcessItem = record
Handle : HWND;
Title : array[0..255] of char;
ClassName : array[0..255] of char;
Parent : HWND;
end;
SystemEx = class
class Procedure CustomizeException(E : Exception);
class Function GetShiftState : TShiftState;
class Procedure ProccesListesiOlustur( Liste :TDictionary<HWND,TProcessItem>; pHandle : HWND=0; isFirst : Boolean= True);
class function ProccesBul(Liste :TDictionary<HWND,TProcessItem>; ClassAdi : String; Baslik : string=''):TProcessItem;overload;
class function ProccesHandleBul(Liste :TDictionary<HWND,TProcessItem>; ClassAdi : String; Baslik : string=''):HWND;overload;
class Function ProccesBul(ClassAdi : String; Baslik : string=''):TProcessItem;overload;
class Function ProccesHandleBul(ClassAdi : String; Baslik : string=''):HWND;overload;
end;
ObjectDataEx = class
class function GetListBySQL(aDB: TpFIBDatabase; sql : AnsiString;
keyField, valueField : AnsiString):TStrings;
class function GetListByTableName(aDB: TpFIBDatabase; TableName,keyField,
valueField : AnsiString; whereSQL : AnsiString=''):TStrings;
class function GetKey( v : TStrings; index : Integer): Integer;
class function GetIndex( v: TStrings; key : Integer): Integer;
end;
FastMsg = class
class Procedure Error( msg : AnsiString; Caption : AnsiString = 'Hata');
class Procedure ErrorFmt( msg : AnsiString;const _Args: array of const; Caption : AnsiString = 'Hata');
class Function Confirm(msg : AnsiString; Caption : AnsiString = 'Onay'): Boolean;
class Procedure Done( msg : AnsiString; Caption : AnsiString = '');
end;
TProgramEventHandlers = class // create a dummy class
Procedure FormClose(Sender: TObject; var Action: TCloseAction);
procedure ButtonClick(Sender: TObject) ;
end;
FormUtilsEx = class
class Function FormBul(SinifAdi: TComponentClass): TForm;
class Function InputPassWordQuery(const ACaption, APrompt: AnsiString;
var Value: AnsiString): Boolean;
class procedure ShowmessageNonModal( const msg : AnsiString);
class procedure AdjustColumnWidths(DBGrid: TDBGrid);
end;
NetUtilsEx = class
class Function NetConnected : Boolean;
class function Post(url: String; DataOut: TMemoryStream; var errMsg: AnsiString):TStringStream;
class function Get(url: String; var errmsg: AnsiString):TStringStream;
end;
TRegistryValueType = (
rvtCurrency,
// rvtBinaryData,
rvtBool,
rvtDate,
rvtDateTime,
rvtFloat,
rvtInteger,
rvtString,
rvtTime
);
RegEx = class
class Function KeyExists( Root : HKEY; Key : string): Boolean;
class Function ValueExists( Root : HKEY; Key : String; ValueName : string):Boolean;
class Function ReadValue( Root : HKEY; Key : String; ValueName : string;
vType : TRegistryValueType = rvtString) : Variant;
class function ReadValueData( Root : HKEY; Key : String; ValueName : string;
Var buff : TBytes):Integer;
class function WriteValue(Root : HKEY; Key : String; ValueName : string;
Value : Variant; vType : TRegistryValueType): Boolean;
end;
{$REGION 'DB Common Methods'}
TDBDatasetSQLs = record
SelectSQL,
InsertSQL,
UpdateSQL,
DeleteSQL,
ReFreshSQL : AnsiString;
end;
// TValueContainer = TDictionary<String,Variant>;
DBCommonMethods = class
class Function GetEmptyQuery(aDB:TpFIBDatabase): TpFIBQuery;
class Function GetEmptyDataset(aDB:TpFIBDatabase): TpFIBDataSet;
class Function GetQuery(aDB:TpFIBDatabase;aSQL : AnsiString;
KeyValues : Array of Variant;
KeyNames : array of AnsiString
): TpFIBQuery;
class Function GetQueryDataset(aDB:TpFIBDatabase;aSQL : AnsiString;
KeyValues : Array of Variant;
KeyNames : array of AnsiString
): TDataset;
class Function GetDataset(aDB:TpFIBDatabase;TableName : AnsiString; KeyFields : array of AnsiString): TpFibDataset;overload;
class Function GetDataset(aDB:TpFIBDatabase;SQLs:TDBDatasetSQLs): TpFibDataset;overload;
class Procedure SetDatasetFieldValues(ds : TDataset;const FieldNames : array of AnsiString; const FieldValues : Array of Variant;_SetState : TDataSetState=dsCalcFields);
end;
{$ENDREGION}
procedure CastVariantToArray(const Values: Variant; var VarArray:TVarDynArray);
const
HexValues :array[0..15] of char= ('0','1','2','3','4','5','6','7','8','9','A','B','C','D','E','F');
implementation
const
EncyConstant = '@"?%=&75!';
var
ProgEvHandler:TProgramEventHandlers;
{Private}
type
Turkce = type AnsiString(1254);
{TVersion}
function TVersion.CompareWith(aCompareWith: TVersion) : TVersionCompareResult;
begin
if
(Major= aCompareWith.Major) and (
Major= aCompareWith.Major) and
(Major= aCompareWith.Major) and
(Major= aCompareWith.Major)
then
Result := vcrEqual
else
if Major> aCompareWith.Major then
Result := vcrCurrentNewer
else
if Major< aCompareWith.Major then
Result := vcrCurrentOlder
else
if Minor> aCompareWith.Minor then
Result := vcrCurrentNewer
else
if Minor< aCompareWith.Minor then
Result := vcrCurrentOlder
else
if Release> aCompareWith.Release then
Result := vcrCurrentNewer
else
if Release< aCompareWith.Release then
Result := vcrCurrentOlder
else
if Build> aCompareWith.Build then
Result := vcrCurrentNewer
else
if Build< aCompareWith.Build then
Result := vcrCurrentOlder
else
raise Exception.Create('Is not funny ha funnyman!');
end;
Function TVersion.FromStr(s:String;Seperator : String = '.'): Boolean;
var
arr : StringArray;
x: TVersion;
begin
Result := False;
if s<>'' then
Begin
arr := StrUtilsEx.ExplodeStr(s,[Seperator],True);
if LEngth(arr)>0 then // en azından major varsa sorun yok
Begin
x.Major := IfThen(Length(arr)>0, StrToInt(arr[0]),0);
x.Minor := IfThen(Length(arr)>1, StrToInt(arr[1]),0);
x.Release := IfThen(Length(arr)>2, StrToInt(arr[2]),0);
x.Build := IfThen(Length(arr)>3, StrToInt(arr[3]),0);
SetLength(arr,0);
Self := x;
Result := True;
End;
End;
end;
{TSMART_RECORD}
{$REGION 'SMART RECORD'}
constructor TSMART_RECORD.create;
//var
// Ctx: TRttiContext;
// RttiType: TRttiType;
// i : Integer;
begin
fRootNodeName := 'ITEM';
// RttiType := Ctx.GetType(Self.ClassType);
// FFields := RttiType.GetFields;
end;
destructor TSMART_RECORD.destroy;
begin
// SetLength(FFields,0);
end;
procedure TSMART_RECORD.GetValue(ds: TDataSet; FieldName: AnsiString);
var
Ctx: TRttiContext;
RttiType: TRttiType;
f: TArray<TRttiField>;
i : Integer;
mVal : TValue;
begin
RttiType := Ctx.GetType(Self.ClassType);
f := RttiType.GetFields;
for i := Low(f) to High(f) do
if f[i].Name= FieldName then
if ds.FindField(FieldName)<>nil then
Begin
mVal := TValue.FromVariant(ds.FieldByName(f[i].Name).Value);
if mVal.IsEmpty then
mVal := TValue.FromVariant(GetDefaultValue(ds.FieldByName(f[i].Name).DataType));
if mVal.IsEmpty = False then
f[i].SetValue(self, mVal)
else
raise Exception.Create('Unknown value type');
End;
end;
procedure TSMART_RECORD.GetValuesFromDataset(ds: TDataSet);
var
Ctx: TRttiContext;
RttiType: TRttiType;
f: TArray<TRttiField>;
i : Integer;
mVal : TValue;
begin
RttiType := Ctx.GetType(Self.ClassType);
f := RttiType.GetFields;
for i := Low(f) to High(f) do
if ds.FindField(f[i].Name)<>nil then
Begin
mVal := TValue.FromVariant(ds.FieldByName(f[i].Name).Value);
if mVal.IsEmpty then
mVal := TValue.FromVariant(GetDefaultValue(ds.FieldByName(f[i].Name).DataType));
if mVal.IsEmpty = False then
f[i].SetValue(self, mVal)
else
raise Exception.Create('Unknown value type');
End;
DoAfterLoad;
end;
Procedure TSMART_RECORD.ToDataset(ds: TDataSet);
var
i : Integer;
begin
if ds.Active=False then
raise Exception.Create('Dataset is not active')
else
if not(ds.State in [dsEdit,dsInsert]) then
raise Exception.Create('Data set is not insert or edit mode')
else
Begin
for i := 0 to Self.FieldCount - 1 do
if FieldName[i]<> 'fRootNodeName' then
if ds.FindField(FieldName[i])<>nil then
ds.FieldByName(FieldName[i]).Value := FieldValue[i];
End;
end;
Function TSMART_RECORD.GetFieldName;
var
ctx : TRttiContext;
begin
Result := Ctx.GetType(Self.ClassType).GetFields[Index].Name;// FFields[Index].Name;
end;
function TSMART_RECORD.GetFieldValue;
var
ctx : TRttiContext;
val : TValue;
begin
Val := Ctx.GetType(Self.ClassType).GetFields[Index].GetValue(Self);
{$IFDEF DEBUG_MODE}
try
{$ENDIF}
case val.Kind of
tkEnumeration:
begin
if val.TypeInfo = TypeInfo(Boolean) then
Result := val.AsBoolean
else
Result := val.AsOrdinal;
end;
tkUnknown:
Begin
Result := null;
End
else
begin
Result := val.AsVariant;
end;
end;
{$IFDEF DEBUG_MODE}
except
Showmessage(VarToStr(val.Kind));
end;
{$ENDIF}
end;
procedure TSMART_RECORD.SetFieldValue(Index: Integer; v: Variant);
var
ctx : TRttiContext;
mVal : TValue;
begin
mVal := TValue.FromVariant(v);
if mVal.IsEmpty then
mVal := TValue.FromVariant(Unassigned);
if mVal.IsEmpty = False then
Ctx.GetType(Self.ClassType).GetFields[Index].SetValue(Self,mVal)// FFields[Index].SetValue(self, mVal)
else
raise Exception.Create('Unknown value type');
end;
Function TSMART_RECORD.GetVarType;
var
Ctx: TRttiContext;
begin
Result := Ctx.GetType(Self.ClassType).GetFields[Index].FieldType.TypeKind;
end;
Function TSMART_RECORD.GetVarTypeAsStr;
var
Ctx: TRttiContext;
begin
Result := Ctx.GetType(Self.ClassType).GetFields[Index].FieldType.ToString;
end;
procedure TSMART_RECORD.DoAfterLoad;
begin
if Assigned(fOnAfterLoad) then
fOnAfterLoad(Self);
end;
function TSMART_RECORD.GetDefaultValue;
begin
Result := Unassigned;
case ft of
ftUnknown,
ftString,
ftWideString,
ftWideMemo,
ftMemo,
ftFmtMemo,
ftFixedChar:
Result :='';
ftSmallint,
ftInteger,
ftWord,
ftAutoInc,
ftLargeint,
ftByte,
ftOraInterval,
ftLongWord,
ftShortint:
Result :=0;
ftBoolean:
Result := False;
ftFloat,
ftCurrency,
ftBCD,
ftDate,
ftTime,
TFieldType.ftSingle,
ftDateTime,
TFieldType.ftExtended,
ftOraTimeStamp,
ftTimeStamp:
Result := 0;
ftBytes,
ftVarBytes:
Result :=#0 ;
ftOraBlob,
ftBlob,
ftGraphic:
Result := #0 ;
ftArray :
Result :=VarArrayCreate([0],varVariant {varInteger});
ftVariant :
Result := Unassigned;
{
ftParadoxOle,ftDBaseOle,ftTypedBinary,ftCursor,ftADT,ftReference,ftDataSet,
ftOraClob,ftInterface,ftIDispatch,ftGuid,ftFMTBcd,ftFixedWideChar,
ftConnection,ftParams,ftStream,ftTimeStampOffset,ftObject,
}
end;
end;
function TSMART_RECORD.FieldCount;
var
ctx : TRttiContext;
begin
Result :=Length(Ctx.GetType(Self.ClassType).GetFields);// Length(FFields);
end;
function TSMART_RECORD.FieldExists(const aFieldName: string): Boolean;
var
ctx : TRttiContext;
f: TArray<TRttiField>;
i: Integer;
begin
Result := False;
f := Ctx.GetType(Self.ClassType).GetFields;
for i := Low(f) to High(f) do
if f[i].Name = aFieldName then
Begin
Result := True;
Break;
End;
end;
Function TSMART_RECORD.IsValidField(aFieldName: string): Boolean;
begin
Result := FieldExists(aFieldName);
if Result then
Result :=
(aFieldName<> 'fRootNodeName') and (aFieldName<> 'fOnAfterLoad');
end;
function TSMART_RECORD.ToXML:IXMLDocument;
var
t: TXMLDocument;
i: Integer;
iNode: IXMLNode;
begin
t := TXMLDocument.Create(nil);
t.Active := True;
t.Encoding := 'windows-1254';// 'UTF-8';
t.Version := '1.0';
if Trim(fRootNodeName) = '' then
fRootNodeName := 'ITEM';
t.DocumentElement := t.CreateNode(fRootNodeName,ntElement,'');
// t.DocumentElement.Attributes['default'] := 'default';
for i := 0 to FieldCount - 1 do
Begin
{$IFDEF DEBUG_MODE}
ShowMessage(FieldName[i]);
{$ENDIF}
if (IsValidField(FieldName[i])) then
if FieldName[i] <> fRootNodeName then
Begin
iNode := t.DocumentElement.AddChild(FieldName[i],-1);
iNode.NodeValue := FieldValue[i];
end
else
raise Exception.CreateFmt('%s adında bir eleman mevcut',[fRootNodeName]);
End;
t.Active := True;
Result := t;
end;
function TSMART_RECORD.ToXML(withHeader: Boolean): AnsiString;
var
i : IXMLDocument;
begin
i := ToXml;
Result := i.XML.Text;
if Pos('<?xml version="1.0"?>',Result)>0 then
Result := StringReplace(Result,'<?xml version="1.0"?>',
'<?xml version="1.0" encoding="windows-1254"?>',[]);
if withHeader=false then
StrUtilsEx.DeleteInTags(Result,'<?','?>',1,True);
i := nil;
end;
Procedure TSMART_RECORD.FromXML(XML: AnsiString);
var
aXml : IXMLDocument;
begin
aXml := TXMLDocument.Create(nil);
aXml.LoadFromXML(XML);
aXml.Active := True;
try
FromXMl(aXml);
finally
aXml := nil;
end;
end;
PRocedure TSMART_RECORD.FromXML(XML: IXMLDocument);
var
i: Integer;
iNode: IXMLNode;
s: AnsiString;
v : Variant;
ctx : TRttiContext;
begin
for i := 0 to FieldCount - 1 do
Begin
s := FieldName[i];
if s <>'fRootNodeName' then
Begin
iNode := XML.DocumentElement.ChildNodes.FindNode(s);
if Assigned(iNode) then
try
v := FieldValue[i];
v := VarAsType(iNode.Text,VarType(v));
FieldValue[i] :=v;// iNode.NodeValue;
except
end;
End;
End;
DoAfterLoad;
end;
{$ENDREGION}
procedure CastVariantToArray(const Values: Variant; var VarArray:TVarDynArray);
begin
if VarIsArray(Values) then
VarArray:=Values
else
begin
SetLength(VarArray,1);
VarArray[0]:=Values;
end;
end;
{MathEx}
class function MathEx.SumOfIntArray(p: array of Integer):Integer;
var
i : Integer;
begin
Result := 0;
for i := Low(p) to High(p) do
Result := Result + p[i];
end;
class function MathEx.AvgOfIntArray(p: array of Integer):Integer;
var
i : Integer;
begin
Result := MathEx.SumOfIntArray(p);
if (Length(p)>0) and (Result >0) then
Result := Result div Length(p)
else
Result :=0;
end;
class function MathEx.roundUp( RoundValue: real; const aDigit : TRoundToRange = 0): real;
var eValue1: extended;
eValue2: extended;
Digit:TRoundToRange;
begin
if ( aDigit >= 0) then Result:=roundTo(RoundValue,aDigit)
else
begin
Digit:=Abs(aDigit);
eValue1 := trunc( frac( RoundValue) * power(10, Digit))/ power(10, Digit);
eValue2 := frac( RoundValue);
if (eValue2 <= eValue1) then
result := trunc( RoundValue) + eValue1
else
result := trunc( RoundValue) + trunc( frac( RoundValue) * power(10, Digit)+1)/ power(10, Digit);
end;
end;
Class Function MathEx.CalcPercentAt( Value , _Percent : Double): Double;
Begin
if (Value=0) or (_Percent=0) then
Result := 0
else
Result := (_Percent * Value) /100;
End;
Class Function MathEx.CalcPercentAt( Value , _Percent : Integer): Integer;
Begin
if (Value=0) or (_Percent=0) then
Result := 0
else
Result := (_Percent * Value) div 100;
End;
class function MathEx.BetWeen;
begin
Result := ( Value>= Min(a,b)) and (Value<=Max(a,b));
end;
{StrUtilsEx}
class function StrUtilsEx.GiveInTags(aValue,tagStart, tagEnd : AnsiString; iFromHere : Integer = 1):AnsiString;
var
i,iStart,iEnd: Integer;
Begin
i := iFromHere;
Result := '';
i := PosEx(tagStart,aValue,i);
if i>0 then
Begin
iStart := i + Length(tagStart);
i := PosEx(tagEnd,aValue,iStart);
if i>0 then
Begin
iEnd := i;
Result := Copy(aValue,iStart, iEnd-iStart);
End;
End;
End;
class Procedure StrUtilsEx.DeleteInTags;
var
i,iStart,iEnd: Integer;
Begin
i := iFromHere;
iStart := PosEx(tagStart,aValue,i);
if i>0 then
Begin
if DeleteTagsToo = false then
iStart := iStart + Length(tagStart);
i := PosEx(tagEnd,aValue,iStart);
if i>0 then
Begin
iEnd := i;
if DeleteTagsToo = True then
Inc(iEnd,Length(tagEnd));
Delete(aValue,iStart, iEnd-iStart);
End;
End;
end;
class function StrUtilsEx.FormatEx(const _Format: AnsiString; const _Args: array of const):AnsiString;
const
nonEscapeRep = '{<(\\)>}';
dontEscape = '\\';
Begin
Result := Format(_Format,_Args);
Result :=StringReplace(Result,dontEscape,nonEscapeRep,[rfReplaceAll]);
Result :=StringReplace(Result,'\r',#13,[rfReplaceAll]); //return
Result :=StringReplace(Result,'\t',#9,[rfReplaceAll]); //horziontal tab
Result :=StringReplace(Result,'\n',#10,[rfReplaceAll]); //new line
Result :=StringReplace(Result,'\0',#0,[rfReplaceAll]); //null
Result :=StringReplace(Result,'\b',#8,[rfReplaceAll]); //backspace
Result :=StringReplace(Result,'\f',#12,[rfReplaceAll]); //form feed
Result :=StringReplace(Result,'\v',#11,[rfReplaceAll]); //vertical tab
// Result :=StringReplace(Result,'',#,[rfReplaceAll]);
Result :=StringReplace(Result,nonEscapeRep,'\',[rfReplaceAll]);
End;
class function StrUtilsEx.MBoxStrPA(v: Variant):PAnsiChar;
begin
if not VarIsNull(v) then
Result := PAnsiChar(AnsiString((VarToStr(v))))
else
Result :='';
end;
class Function StrUtilsEx.ArrayToMultiLineStr(v: array of Variant):AnsiString;
var
v2 : Variant;
begin
Result := '';
for v2 in v do
Result := Result + #13#10 + VarToStr(v2);
while (Length(Result)>2) and (Pos(#13#10,Result)=1) do
Delete(Result,1,2);
end;
class function StrUtilsEx.BytesToHex;
var
i: Integer;
begin
Result := EmptyStr;
for i := Low(b) to High(b) do
Result := Result + IntToHex(b[i],2);
end;
class function StrUtilsEx.HexToBytes;
var
i: Integer;
begin
SetLength(Result,0);
if Odd(Length(h)) then raise Exception.Create('[HexToStr]:Geçersiz Uzunluk! Uzunluk Çift Sayı olmalı')
else
Begin
I := 1;
while I < LEngth(h) do
begin
DynArrayEx.Grow(Result);
Result[High(Result)] := StrToInt('$'+h[I]+h[I+1]);
I := I + 2;
end;
End;
end;
class Function StrUtilsEx.StrToHex;
begin
Exit(BytesToHex(BytesOf(Buffer)));
end;
class Function StrUtilsEx.HexToStr;
begin
Exit(StringOf(HexToBytes(Buffer)));
end;
class function StrUtilsEx.XORStr;
var
i,i1,i2,iMax : Integer;
begin
if s1='' then
Result :=s2
else
if s2='' then
Result:=s1
else
Begin
iMax := Max(Length(s1),Length(s2));
Result :='';
i :=1;
i1 :=1;
i2 :=1;
while (i<=iMax) do
Begin
Result :=Result + Chr(Ord(s1[i1]) xor Ord(s2[i2]));
Inc(i);
Inc(i1);
Inc(i2);
if i1>Length(s1) then
i1 :=1;
if i2>Length(s2) then
i2 :=1;
End;
End;
end;
class procedure StrUtilsEx.XORBytes;
var
i:Integer;
s : AnsiString;
begin
if (Length(Value)>0) and (Length(xorv)>0) then
for i := Low(Value) to High(Value) do
Value[i] := Value[i] xor xorv[i mod Length(xorv)];
end;
class function StrUtilsEx.FixedNumber;
begin
Result := Format('%.*d',[FixCount,Value]);
end;
class Procedure StrUtilsEx.Add(var s: AnsiString; ValueToBeAdded: Variant);
begin
if not VarIsNull(ValueToBeAdded) then
s := s + VarToStr(ValueToBeAdded);
end;
class Procedure StrUtilsEx.AddLine(var s: AnsiString; ValueToBeAdded: Variant);
begin
if not VarIsNull(ValueToBeAdded) then
s := StrUtilsEx.ArrayToMultiLineStr([s,ValueToBeAdded])
else
s := StrUtilsEx.ArrayToMultiLineStr([s,'']);
end;
class Function StrUtilsEx.NumbersOnly;
var
i : Integer;
begin
Result := EmptyStr;
for i := 1 to LEngth(s) do
if
(s[i] in ['0'..'9']) or
((ExceptThose<>'') and (Pos(s[i],ExceptThose)>0))
then
Result := Result + s[i];
end;
class function StrUtilsEx.AsDouble;
begin
Result := NumbersOnly(s,DecimalSeparator);
end;
class Function StrUtilsEx.Encrypt;
var
b: TBytes;
c : AnsiString;
p : Byte;
i: Integer;
begin
REsult := nil;
end;
class function StrUtilsEx.Decrypt;
var
b: TBytes;
c : AnsiString;
p : Byte;
i: Integer;
begin
Result := nil;
end;
class Function StrUtilsEx.StringMultiReplace(Value : AnsiString; OldValues,NewValues:Variant;
Flags:TReplaceFlags):AnsiString;
var
aOld,aNew : TVarDynArray;
i : Integer;
Begin
Result :=Value;
try
CastVariantToArray(OldValues,aOld);
CastVariantToArray(NewValues,aNew);
except
exit;
end;
for i := Low(aOld) to High(aOld) do
if i<=High(aNew) then
Result := StringReplace(Result,aOld[i],aNew[i],Flags)
else
Result := StringReplace(Result,aOld[i],aNew[Low(aNew)],Flags);
End;
class Function StrUtilsEx.CopyAt(s: AnsiString; index: Integer):AnsiString;
begin
Result := Copy(s,Index,(Length(s)-Index)+1);
end;
class function StrUtilsEx.ExplodeStr;
const
d13 = '{5520A0C5-2659-4A5B-9AA0-E7891C54B98A}';
d10 = '{59177E6D-776D-43AE-8549-F78E2C59C894}';
var
ss : TStrings;
p,x : AnsiString;
i: Integer;
arrs : StringArray;
begin
p :=AnsiReplaceStr(AnsiReplaceStr(s,#13,d13),#10,d10);
for i := Low(Seperators) to High(Seperators) do
p := AnsiReplaceStr(p,Seperators[i],#13#10);
ss := TStringList.Create;
ss.Text := p;
for i := 0 to ss.Count - 1 do
Begin
x := AnsiReplaceStr(AnsiReplaceStr(ss.Strings[i],d13,#13),d10,#10);
if TrimAndSkipEmptyStrs then
Begin
x := Trim(x);
if x<>'' then
begin
SetLength(Result,Length(Result)+1);
Result[High(Result)] := x;
end;
End
else
Begin
SetLength(Result,Length(Result)+1);
Result[High(Result)] := x;
End;
End;
ss.free;
end;
class function StrUtilsEx.AnsiUpperCaseTr(s: AnsiString): AnsiString;
begin
Result :=AnsiUpperCase(
StringMultiReplace(s,
VarArrayOf(['ç','ğ','ı','i','ö','ş','ü']),
VarArrayOf(['Ç','Ğ','I','İ','Ö','Ş','Ü'])
,[rfReplaceAll]));
end;
class function StrUtilsEx.AnsiLowerCaseTr(s: AnsiString): AnsiString;
begin
Result :=AnsiLowerCase( StringMultiReplace(s,
VarArrayOf(['Ç','Ğ','I','İ','Ö','Ş','Ü']),
VarArrayOf(['ç','ğ','ı','i','ö','ş','ü'])
,[rfReplaceAll]));
end;
class function StrUtilsEx.AnsiSameStrTr;
var
x,y : AnsiString;
begin
x := IfThen(ignorecharcase,StrUtilsEx.AnsiUpperCaseTr(a),a);
y := IfThen(ignorecharcase,StrUtilsEx.AnsiUpperCaseTr(b),b);
Result := x = y;
end;
class function StrUtilsEx.ConvertToEnglishChar(t: AnsiString):AnsiString;
begin
Result :=
StringMultiReplace(t,
VarArrayOf(['ğ','Ğ','ü','Ü','ş','Ş','ç','Ç','ı','İ','ö','Ö']),
VarArrayOf(['g','G','u','U','s','S','c','C','i','I','o','O']),[rfReplaceAll]);
end;
{DynArrayEx}
class procedure DynArrayEx.AddItem(var ArrayValue: Variant; item: Variant);
var
tv : TVarDynArray;
begin
// if not VarIsNull(item) then
Begin
CastVariantToArray(ArrayValue,tv);
SetLength(tv,LEngth(tv)+1);
tv[High(tv)] := item;
ArrayValue := Tv;
End;
end;
class procedure DynArrayEx.RemoveItem(var ArrayValue: Variant; item: Variant; RemoveAll: Boolean = True);
var
tv : TVarDynArray;
v: Variant;
i : Integer;
b: Boolean;
begin
// if not VarIsNull(item) then
Begin
CastVariantToArray(ArrayValue,tv);
// SetLength(v,0);
b := false;
for i := Low(tv) to High(tv) do
if tv[i]<> item then
DynArrayEx.AddItem(v,tv[i])
else if (not b) or (RemoveAll=false) then
Begin
DynArrayEx.AddItem(v,tv[i]);
b := True;
End;
ArrayValue := v;
End;
end;
class Function DynArrayEx.VarArrayIDX(Value,ArrayValue : Variant):Integer;
var
i:Integer;
aVarArray : TVarDynArray;
begin
Result :=-1;
try
CastVariantToArray(ArrayValue,aVarArray);
except
exit;
end;
if not VarIsNull(Value) then
for i := Low(aVarArray) to High(aVarArray) do
Begin
if Value = aVarArray[i] then
Begin
Result :=i;
Break;
End;
End;
end;
class Function DynArrayEx.InArray(Value,ArrayValue: Variant): Boolean;
Begin
Result := VarArrayIDX(Value,ArrayValue)>=0;
End;
class procedure DynArrayEx.Grow;
begin
SetLength(arr,Length(arr)+ Count);
end;
class procedure DynArrayEx.Insert(var arr: TBytes; const ins: TBytes; index: Integer);
var
i,k : Integer;
begin
Grow(arr,Length(ins));
for k := 1 to Length(ins) do
for i := High(arr) downto index do
if i>Low(arr) then
arr[i] := arr[i-1];
for i := Low(ins) to High(ins) do
arr[index +i] := ins[i];
end;
class function DynArrayEx.Copy(const arr: TBytes; const index: Integer; const Count: Integer):TBytes;
var
i: Integer;
begin
if Length(arr)>Count then
Begin
Grow(Result,Count);
for i := Low(Result) to High(Result) do
Result[i] := arr[index + i];
End;
end;
class procedure DynArrayEx.Delete(var arr: TBytes; const index: Integer; const count: Integer);
var
i: Integer;
b: TBytes;
begin
SetLength(b,0);
if index>Low(arr) then
for i := Low(arr) to index-1 do
Begin
DynArrayEx.Grow(b);
b[High(b)] := arr[i];
End;
if index + count<=High(arr) then
for i := index + count to High(arr) do
Begin
DynArrayEx.Grow(b);
b[High(b)] := arr[i];
End;
arr := b;
end;
class function DynArrayEx.IsSameByteArray(a: TBytes; b: TBytes): Boolean;
var
i : Integer;
begin
Result := False;
if LEngth(a)<>Length(b) then
Exit(False)
else
for i := Low(a) to High(a) do
if a[i]<>b[i] then
Exit(False);
Result := True;
end;
class function DynArrayEx.IsSameByteArray(a: array of byte; b: array of byte): Boolean;
var
i : Integer;
begin
Result := False;
if LEngth(a)<>Length(b) then
Exit(False)
else
for i := Low(a) to High(a) do
if a[i]<>b[i] then
Exit(False);
Result := True;
end;
{$REGION 'DB Common Methods'}
class Function DBCommonMethods.GetEmptyQuery;
Begin
Result := TpFIBQuery.Create(nil);
Result.Database := aDB;
Result.Transaction := aDB.DefaultTransaction;
End;
class Function DBCommonMethods.GetEmptyDataset;
Begin
Result := TpFIBDataSet.Create(nil);
Result.Database := aDb;
Result.Transaction := aDb.DefaultTransaction;
if adb.DefaultUpdateTransaction<>nil then
Result.UpdateTransaction := aDB.DefaultUpdateTransaction
else
Result.UpdateTransaction := aDB.DefaultTransaction;
End;
class Function DBCommonMethods.GetQuery;
var
i,k : Integer;
Begin
try
Result := self.GetEmptyQuery(aDb);
Result.SQL.Text := aSQL;
if Length(KeyValues)>0 then
if Length(KeyNames)>0 then
Begin
for i := Low(KeyNames) to High(KeyNames) do
if Result.ParamExist(KeyNames[i],k) then
Result.Params[k].Value := KeyValues[i];
End
else
Begin
for i := Low(KeyValues) to High(KeyValues) do
Result.Params[i].Value := KeyValues[i];
End;
Result.ExecQuery;
except
// on e : Exception do
// Begin
// Showmessage ('Hata:'+e.Message +#13#10+ ' Sql:'+Result.SQL.Text);
if Assigned(Result) then
FreeAndNil(Result);
// End;
end;
End;
class Function DBCommonMethods.GetQueryDataset;
var
i,k : Integer;
aFibDataset : TpFIBDataSet;
Begin
try
Result := nil;
aFibDataset := self.GetEmptyDataset(aDb);
aFibDataset.SelectSQL.Text := aSQL;
if Length(KeyValues)>0 then
if Length(KeyNames)>0 then
Begin
for i := Low(KeyNames) to High(KeyNames) do
if aFibDataset.ParamExist(KeyNames[i],k) then
aFibDataset.Params[k].Value := KeyValues[i];
End
else
Begin
for i := Low(KeyValues) to High(KeyValues) do
aFibDataset.Params[i].Value := KeyValues[i];
End;
aFibDataset.Open;
Result := aFibDataset;
except
if Assigned(aFibDataset) then
FreeAndNil(aFibDataset);
end;
End;
class Function DBCommonMethods.GetDataset(aDB:TpFIBDatabase;SQLs:TDBDatasetSQLs)
: TpFibDataset;
Begin
Result := self.GetEmptyDataset(aDb);
Result.SelectSQL.Text := SQLs.SelectSQL;
Result.UpdateSQL.Text := SQLs.SelectSQL;
Result.DeleteSQL.Text := SQLs.SelectSQL;
Result.RefreshSQL.Text := SQLs.RefreshSQL;
End;
class Function DBCommonMethods.GetDataset(aDB:TpFIBDatabase;TableName : AnsiString; KeyFields : array of AnsiString): TpFibDataset;
var
s,a : Tstrings;
i : Integer;
ss : TDBDatasetSQLs;
Begin
s := TstringList.Create;
a := TstringList.Create;
s.Clear;
a.Clear;
adB.GetFieldNames(TableName,s);
a.Clear;
{$REGION 'SelectSQL'}
a.Add('select');
for i := 0 to s.Count - 1 do
a.Add(
IfThen(
i<s.Count-1,
Format('%0:s=:%0:s,',[s.Strings[i]]),
Format('%0:s=:%0:s ',[s.Strings[i]])
)
);
a.Add(Format('from %s',[TableName]));
ss.SelectSQL := a.Text;
{$ENDREGION}
a.Clear;
{$REGION 'InsertSQL'}
a.Add(Format('insert into %s (',[TableName]));
for i := 0 to s.Count - 1 do
a.Add(
IfThen(
i<s.Count-1,
Format('%s,',[s.Strings[i]]),
Format('%s ',[s.Strings[i]])
)
);
a.Add(') values (');
for i := 0 to s.Count - 1 do
a.Add(
IfThen(
i<s.Count-1,
Format(':%s,',[s.Strings[i]]),
Format(':%s ',[s.Strings[i]])
)
);
a.Add(')');
ss.InsertSQL := a.Text;
{$ENDREGION}
a.Clear;
{$REGION 'UpdateSQL'}
a.Add(Format('update %s set',[TableName]));
for i := 0 to s.Count - 1 do
a.Add(
IfThen(
i<s.Count-1,
Format('%0:s=:%0:s,',[s.Strings[i]]),
Format('%0:s=:%0:s ',[s.Strings[i]])
)
);
a.Add('where');
for i := Low(KeyFields) to High(KeyFields) do
a.Add(
IfThen(
i<High(KeyFields),
Format('%0:s=:OLD_%0:s and',[KeyFields[i]]),
Format('%0:s=:OLD_%0:s',[KeyFields[i]])
)
);
ss.UpdateSQL := a.Text;
{$ENDREGION}
a.Clear;
{$REGION 'DeleteSQL'}
a.Add(Format('delete from %s',[TableName]));
a.Add('where');
for i := Low(KeyFields) to High(KeyFields) do
a.Add(
IfThen(
i<High(KeyFields),
Format('%0:s=:OLD_%0:s and',[KeyFields[i]]),
Format('%0:s=:OLD_%0:s',[KeyFields[i]])
)
);
ss.DeleteSQL := a.Text;
{$ENDREGION}
a.Clear;
{$REGION 'ReFreshSQL'}
a.Add('select');
for i := 0 to s.Count - 1 do
a.Add(
IfThen(
i<s.Count-1,
Format('%0:s=:%0:s,',[s.Strings[i]]),
Format('%0:s=:%0:s ',[s.Strings[i]])
)
);
a.Add(Format('from %s',[TableName]));
a.Add('where');
for i := Low(KeyFields) to High(KeyFields) do
a.Add(
IfThen(
i<High(KeyFields),
Format('%0:s=:OLD_%0:s and',[KeyFields[i]]),
Format('%0:s=:OLD_%0:s',[KeyFields[i]])
)
);
ss.ReFreshSQL := a.Text;
{$ENDREGION}
s.Free;
a.Free;
Result := Self.GetDataset(aDB,ss);
End;
class Procedure DBCommonMethods.SetDatasetFieldValues(ds: TDataSet; const FieldNames: array of AnsiString; const FieldValues: array of Variant;_SetState : TDataSetState=dsCalcFields);
var
i : Integer;
begin
if (ds=nil) then
raise Exception.Create('SetDatasetFieldValues->Dataset is not assigned!')
else
Begin
if _SetState in [dsEdit,dsInsert] then
case _SetState of
dsInsert: ds.Insert ;// Append diyince nedense dsBrowse moduna düşüyor tekrar
dsEdit:
if ds.RecordCount>0 then ds.Edit else
ds.Append;
end;
if (ds.State in [dsEdit,dsInsert])=False then
raise Exception.Create('SetDatasetFieldValues->Dataset is not ready!')
else
for i := Low(FieldNames) to High(FieldNames) do
if i<=High(FieldValues) then
if ds.FindField(FieldNames[i])<>nil then
if VarIsNull(FieldValues[i])=True then
Begin
if ds.State=dsEdit then
ds.FieldByName(FieldNames[i]).Value := null;
End
else
ds.FieldByName(FieldNames[i]).Value := FieldValues[i];
End;
end;
{$ENDREGION}
{SystemEx}
class procedure SystemEx.CustomizeException;
var
s: AnsiString;
begin
{
except
// IO error
On E : EInOutError do
ShowMessage('IO error : '+E.Message);
// Dibision by zero
On E : EDivByZero do
ShowMessage('Div by zero error : '+E.Message);
// Catch other errors
else
ShowMessage('Unknown error');
end;
Exception Base class
EAbort Abort without dialog
EAbstractError Abstract method error
AssertionFailed Assert call failed
EBitsError Boolean array error
ECommonCalendarError Calendar calc error
EDateTimeError DateTime calc error
EMonthCalError Month calc error
EConversionError Raised by Convert
EConvertError Object convert error
EDatabaseError Database error
EExternal Hardware/Windows error
EAccessViolation Access violation
EControlC User abort occured
EExternalException Other Internal error
EIntError Integer calc error
EDivByZero Integer Divide by zero
EIntOverflow Integer overflow
ERangeError Out of value range
EMathError Floating point error
EInvalidArgument Bad argument value
EInvalidOp Inappropriate operation
EOverflow Value too large
EUnderflow Value too small
EZeroDivide Floating Divide by zero
EStackOverflow Severe Delphi problem
EHeapException Dynamic memory problem
EInvalidPointer Bad memory pointer
EOutOfMemory Cannot allocate memory
EInOutError IO error
EInvalidCast Object casting error
EInvalidOperation Bad component op
EMenuError Menu item error
EOSError Operating system error
EParserError Parsing error
EPrinter Printer error
EPropertyError Class property error#
EPropReadOnly Invalid property access
EPropWriteOnly Invalid property access
EThread Thread error
EVariantError Variant problem
}
if E is EFIBInterBaseError then
begin
if Pos('unique',e.Message)>0 then
begin
s := 'kayıt';
// if Pos('OSTK_DOKTORLAR_IDX1',e.Message)>0 then
// s:= 'Doktor T.C. Kimlik no';
raise ECustomizedException.CreateFmt('Belirtilen %s ile kayıt zaten var.',[s]);
end
else
if Pos('</CMSG>',e.Message)>0 then
Begin
raise ECustomizedException.CreateFmt('%s',
[StrUtilsEx.GiveInTags(e.Message,'<CMSG>','</CMSG>')]
);
End
else
raise EFIBInterBaseError.CreateFmt('%s',[e.Message]);
end
else
raise TObject(AcquireExceptionObject);
// raise Exception.Create(e.Message); //e;// e.Create(e.Message);// Exception.Create(E.Message);
end;
class function SystemEx.GetShiftState;
var
st : TKeyboardState;
begin
GetKeyboardState(st);
Result := [];
{ TShiftState = set of (ssShift, ssAlt, ssCtrl,
ssLeft, ssRight, ssMiddle, ssDouble, ssTouch, ssPen);}
if (st[vk_Control] And 128) <> 0 then
Include(Result,ssCtrl);
if (st[VK_MENU] And 128) <> 0 then
Include(Result,ssAlt);
if (st[VK_SHIFT] And 128) <> 0 then
Include(Result,ssShift);
end;
Class Procedure SystemEx.ProccesListesiOlustur( Liste :TDictionary<HWND,TProcessItem>; pHandle : HWND=0; isFirst : Boolean= True);
Function GenItem( h : HWND):TProcessItem;
Begin
GetWindowText(h,Result.Title ,255);
GetClassName (h, Result.ClassName,255);
Result.Handle := h;
Result.Parent :=GetParent(h);
if (Result.Parent<=0) and (isFirst=False) then
Result.Parent := pHandle;
if Result.Parent>0 then
if Liste.ContainsKey(Result.Parent)=False then
Liste.AddOrSetValue(Result.Parent, GenItem(Result.Parent));
End;
var
i:TProcessItem;
a,b: HWND;
Begin
if isFirst then
a := FindWindow(nil,nil)
else
a :=GetWindow(pHandle,GW_CHILD);
while a>0 do
begin
i := GenItem(a);
Liste.AddOrSetValue(a,i);
ProccesListesiOlustur(Liste,a,False);
a:=GetWindow(a,GW_HWNDNEXT);
end;
End;
class function SystemEx.ProccesBul(Liste:TDictionary<HWND,TProcessItem>; ClassAdi : String; Baslik : string=''):TProcessItem;
var
i: HWND;
begin
Result.Handle :=0;
Result.Parent :=0;
Result.Title:='';
Result.ClassName :='';
for i in Liste.Keys do
begin
if ClassAdi<>'' then
Begin
if (ClassAdi=Liste[i].ClassName) and (Baslik='') then
Result := Liste[i]
else
if (ClassAdi=Liste[i].ClassName) and (Baslik = Liste[i].Title) then
Result := Liste[i];
End
else
if (Baslik<>'') and (Baslik = Liste[i].Title) then
Result := Liste[i];
if Result.Handle<>0 then
Break;
end;
end;
class function SystemEx.ProccesHandleBul(Liste :TDictionary<HWND,TProcessItem>; ClassAdi : String; Baslik : string=''):HWND;
begin
Result := ProccesBul(Liste,ClassAdi,Baslik).Handle;
end;
class function SystemEx.ProccesBul(ClassAdi: string; Baslik: string = ''):TProcessItem;
var
Liste: TDictionary<Windows.HWND,ClassUtilsEx.TProcessItem>;
begin
try
Liste:= TDictionary<Windows.HWND,ClassUtilsEx.TProcessItem>.Create;
Liste.Clear;
SystemEx.ProccesListesiOlustur(Liste);
Result := SystemEx.ProccesBul(Liste,ClassAdi,Baslik);
finally
Liste.Clear;
Liste.Free;
Liste := nil;
end;
end;
class function SystemEx.ProccesHandleBul(ClassAdi: string; Baslik: string = ''):HWND;
begin
Result := ProccesBul(ClassAdi,Baslik).Handle;
end;
{ObjectdataEx}
class function ObjectDataEx.GetListBySQL;
var
ds : TDataSet;
i :Integer;
begin
Result := TStringList.Create;
ds := DBCommonMethods.GetQueryDataset(adb,sql,[],[]);
if ds<>nil then
Begin
ds.First;
while not ds.Eof do
Begin
Result.AddObject(
ds.FieldByName(valueField).AsString,
TObject(ds.FieldByName(keyField).AsInteger));
ds.Next;
End;
ds.Close;
FreeAndNil(ds);
End;
end;
class function ObjectDataEx.GetListByTableName;
var
sql : AnsiString;
begin
sql := Format('select %s,%s from %s %s',
[keyField,valueField,TableName,whereSql]);
Result := GetListBySQL(adb,sql,keyfield,valuefield);
end;
class function ObjectDataEx.GetKey(v: TStrings; index: Integer):Integer;
var
i : Integer;
begin
Result :=-1;
if v<>nil then
if (index>=0) and (index<=v.Count-1) then
Result := Integer(v.Objects[index]);
end;
class Function ObjectDataEx.GetIndex(v: TStrings; key: Integer):Integer;
var
i: Integer;
begin
Result := -1;
if v<>nil then
for i := 0 to v.Count - 1 do
if Integer(v.Objects[i])=key then
Begin
Result := i;
Break;
End;
end;
{FastMsg}
class procedure FastMsg.Error;
begin
MessageBoxA(Application.Handle,StrUtilsEx.MBoxStrPA(msg),StrUtilsEx.MBoxStrPA(Caption),MB_ICONERROR);
end;
class Procedure FastMsg.ErrorFmt;
begin
FastMsg.Error(StrUtilsEx.FormatEx(msg,_Args), Caption);
end;
class function FastMsg.Confirm;
begin
Result := MessageBoxA(Application.Handle,StrUtilsEx.MBoxStrPA(msg),StrUtilsEx.MBoxStrPA(Caption),MB_YESNO+ MB_ICONQUESTION)=ID_YES;
end;
class PRocedure FastMsg.Done;
begin
MessageBoxA(Application.Handle,StrUtilsEx.MBoxStrPA(msg),StrUtilsEx.MBoxStrPA(Caption),MB_ICONASTERISK);
end;
{ FormUtils}
function GetAveCharSize(Canvas: TCanvas): TPoint;
{$IF DEFINED(CLR)}
var
I: Integer;
Buffer: String;
Size: TSize;
begin
SetLength(Buffer, 52);
for I := 0 to 25 do Buffer[I + 1] := Chr(I + Ord('A'));
for I := 0 to 25 do Buffer[I + 27] := Chr(I + Ord('a'));
GetTextExtentPoint(Canvas.Handle, Buffer, 52, Size);
Result.X := Size.cx div 52;
Result.Y := Size.cy;
end;
{$ELSE}
var
I: Integer;
Buffer: array[0..51] of Char;
begin
for I := 0 to 25 do Buffer[I] := Chr(I + Ord('A'));
for I := 0 to 25 do Buffer[I + 26] := Chr(I + Ord('a'));
GetTextExtentPoint(Canvas.Handle, Buffer, 52, TSize(Result));
Result.X := Result.X div 52;
end;
{$IFEND}
class Function FormUtilsEx.InputPassWordQuery(const ACaption, APrompt: AnsiString;
var Value: AnsiString): Boolean;
var
Form: TForm;
Prompt: TLabel;
Edit: TEdit;
DialogUnits: TPoint;
ButtonTop, ButtonWidth, ButtonHeight: Integer;
begin
Result := False;
Form := TForm.Create(Application);
with Form do
try
Canvas.Font := Font;
DialogUnits := GetAveCharSize(Canvas);
BorderStyle := bsDialog;
Caption := ACaption;
ClientWidth := MulDiv(180, DialogUnits.X, 4);
PopupMode := pmAuto;
Position := poScreenCenter;
Prompt := TLabel.Create(Form);
with Prompt do
begin
Parent := Form;
Caption := APrompt;
Left := MulDiv(8, DialogUnits.X, 4);
Top := MulDiv(8, DialogUnits.Y, 8);
Constraints.MaxWidth := MulDiv(164, DialogUnits.X, 4);
WordWrap := True;
end;
Edit := TEdit.Create(Form);
with Edit do
begin
PasswordChar := '*';
Parent := Form;
Left := Prompt.Left;
Top := Prompt.Top + Prompt.Height + 5;
Width := MulDiv(164, DialogUnits.X, 4);
MaxLength := 255;
Text := Value;
SelectAll;
end;
ButtonTop := Edit.Top + Edit.Height + 15;
ButtonWidth := MulDiv(50, DialogUnits.X, 4);
ButtonHeight := MulDiv(14, DialogUnits.Y, 8);
with TButton.Create(Form) do
begin
Parent := Form;
Caption := SMsgDlgOK;
ModalResult := mrOk;
Default := True;
SetBounds(MulDiv(38, DialogUnits.X, 4), ButtonTop, ButtonWidth,
ButtonHeight);
end;
with TButton.Create(Form) do
begin
Parent := Form;
Caption := SMsgDlgCancel;
ModalResult := mrCancel;
Cancel := True;
SetBounds(MulDiv(92, DialogUnits.X, 4), Edit.Top + Edit.Height + 15,
ButtonWidth, ButtonHeight);
Form.ClientHeight := Top + Height + 13;
end;
if ShowModal = mrOk then
begin
Value := Edit.Text;
Result := True;
end;
finally
Form.Free;
end;
end;
Procedure TProgramEventHandlers.FormClose(Sender: TObject; var Action: TCloseAction);
Begin
Action := caFree;
End;
Procedure TProgramEventHandlers.ButtonClick(Sender : TObject);
Begin
((Sender as TButton).Parent as TForm).Close;
End;
class Procedure FormUtilsEx.ShowmessageNonModal(const msg: AnsiString);
var
aForm : TForm;
i: Integer;
begin
aForm := CreateMessageDialog(Msg, mtCustom, [mbOK], mbOk);
aForm.FormStyle := fsStayOnTop;
aForm.OnClose := ProgEvHandler.FormClose;
for i := 0 to aForm.ComponentCount - 1 do
if aForm.Components[i] is TButton then
(aForm.Components[i] as TButton).OnClick := ProgEvHandler.ButtonClick;
aForm.Show;
end;
class Function FormUtilsEx.FormBul(SinifAdi: TComponentClass): TForm;
var
i: Integer;
Begin
Result := nil;
for i := 0 to Application.ComponentCount - 1 do
Begin
if Application.Components[i] is SinifAdi then
Begin
Result := (Application.Components[i] as TForm);
Break;
End;
End;
if Result=nil then
for I := 0 to Screen.FormCount - 1 do
if Screen.Forms[i].ClassType = SinifAdi then
begin
Result := Screen.Forms[i];
Break;
end;
// if Result = nil then
// Begin
// Result:=Tform(SinifAdi.Create(Application));
// End;
End;
{ This unit was developed by Philippe Randour (philippe_randour@hotmail.com)
in August 2000. It can be freely used in your own development.
Thank you for your interest. }
//unit AdjustGrid;
//
//interface
//
//uses Windows, Forms, DBGrids;
class procedure FormUtilsEx.AdjustColumnWidths(DBGrid: TDBGrid);
var
TotalColumnWidth, ColumnCount, GridClientWidth, Filler, i: Integer;
begin
ColumnCount := DBGrid.Columns.Count;
if ColumnCount = 0 then
Exit;
// compute total width used by grid columns and vertical lines if any
TotalColumnWidth := 0;
for i := 0 to ColumnCount-1 do
TotalColumnWidth := TotalColumnWidth + DBGrid.Columns[i].Width;
if dgColLines in DBGrid.Options then
// include vertical lines in total (one per column)
TotalColumnWidth := TotalColumnWidth + ColumnCount;
// compute grid client width by excluding vertical scroll bar, grid indicator,
// and grid border
GridClientWidth := DBGrid.Width - GetSystemMetrics(SM_CXVSCROLL);
if dgIndicator in DBGrid.Options then begin
GridClientWidth := GridClientWidth - IndicatorWidth;
if dgColLines in DBGrid.Options then
Dec(GridClientWidth);
end;
if DBGrid.BorderStyle = bsSingle then begin
if DBGrid.Ctl3D then // border is sunken (vertical border is 2 pixels wide)
GridClientWidth := GridClientWidth - 4
else // border is one-dimensional (vertical border is one pixel wide)
GridClientWidth := GridClientWidth - 2;
end;
// adjust column widths
if TotalColumnWidth < GridClientWidth then begin
Filler := (GridClientWidth - TotalColumnWidth) div ColumnCount;
for i := 0 to ColumnCount-1 do
DBGrid.Columns[i].Width := DBGrid.Columns[i].Width + Filler;
end
else if TotalColumnWidth > GridClientWidth then begin
Filler := (TotalColumnWidth - GridClientWidth) div ColumnCount;
if (TotalColumnWidth - GridClientWidth) mod ColumnCount <> 0 then
Inc(Filler);
for i := 0 to ColumnCount-1 do
DBGrid.Columns[i].Width := DBGrid.Columns[i].Width - Filler;
end;
end;
class function NetUtilsEx.NetConnected;
var
Flags: DWord;
begin
Result:=InternetGetConnectedState(@Flags,0);
if Result and False then
begin
if (Flags and INTERNET_CONNECTION_MODEM)=INTERNET_CONNECTION_MODEM then
ShowMessage('"Modem" bağlantısı var');
if (Flags and INTERNET_CONNECTION_LAN)=INTERNET_CONNECTION_LAN then
ShowMessage('"Lan" bağlantısı var');
if (Flags and INTERNET_CONNECTION_PROXY)=INTERNET_CONNECTION_PROXY then
ShowMessage('"Proxy" bağlantısı var');
if (Flags and INTERNET_CONNECTION_MODEM_BUSY)=INTERNET_CONNECTION_MODEM_BUSY then
ShowMessage('"Modem Meşgul" ...');
end;
end;
class function NetUtilsEx.Post;
var
DataIn: TStringStream;
Str1: String;
MyClient : THttpCli;
begin
MyClient:=THttpCli.Create(Application);
Result := nil;
try
MyClient.Connection:='Keep-Alive';
MyClient.ContentTypePost:='text/plain';
MyClient.FollowRelocation:=True;
DataIn := TStringStream.Create(Str1);
MyClient.SendStream:=DataOut;
MyClient.RcvdStream:=DataIn;
MyClient.URL:=url;
try
MyClient.Post;
except
DataOut.Free;
errMsg:=Format('%d:%s',[MyClient.StatusCode,MyClient.ReasonPhrase]);
FreeAndNil(MyClient);
Exit;
end;
DataOut.Free;
if MyClient.StatusCode=200 then
begin
if MyClient.ContentLength = 0 then
begin
errMsg:='0-Not response...';
Result:=DataIn;
end
else
begin
Result:=DataIn;
end;
end
else
begin
Result:=nil;
end;
finally
FreeAndNil(MyClient);
end;
end;
class function NetUtilsEx.Get;
var
DataIn: TStringStream;
Str1: String;
MyClient : THttpCli;
begin
MyClient:=THttpCli.Create(Application);
try
MyClient.Connection:='Keep-Alive';
MyClient.ContentTypePost:='text/plain';
MyClient.FollowRelocation:=True;
DataIn := TStringStream.Create(Str1);
//HttpCli1.SendStream:=DataOut;
MyClient.RcvdStream:=DataIn;
MyClient.URL:=url;
try
MyClient.Get;
except
//DataOut.Free;
errMsg:=Format('%d:%s',[MyClient.StatusCode,MyClient.ReasonPhrase]);
Result:=nil;
FreeAndNil(MyClient);
Exit;
end;
//DataOut.Free;
if MyClient.StatusCode=200 then
begin
if MyClient.ContentLength = 0 then
begin
errMsg:='0-Not response...';
Result:=DataIn;
end
else
begin
Result:=DataIn;
end;
end
else
begin
Result:=nil;
end;
finally
FreeAndNil(MyClient);
end;
end;
class function RegEx.KeyExists(Root: HKEY; Key: string): Boolean;
var
r : TRegistry;
begin
Result := False;
r := TRegistry.Create(KEY_READ);
try
r.RootKey := Root;
Result := r.KeyExists(Key);
finally
FreeAndNil(r);
end;
end;
class Function RegEx.ValueExists( Root : HKEY; Key : String; ValueName : string):Boolean;
var
r : TRegistry;
Begin
Result := RegEx.KeyExists(Root,Key);
if Result = True then
Begin
Result := False;
r := TRegistry.Create(KEY_READ);
try
r.RootKey := Root;
if r.OpenKey(Key,False) then
Result := r.ValueExists(ValueName)
else
Result := False;
finally
FreeAndNil(r);
end;
End;
End;
class function RegEx.ReadValue;
var
r : TRegistry;
begin
Result := null;
if RegEx.ValueExists(Root,Key,ValueName) then
Begin
r := TRegistry.Create(KEY_READ);
try
r.RootKey := Root;
if r.OpenKey(Key,False) then
case vType of
rvtCurrency: r.ReadCurrency(ValueName) ;
// rvtBinaryData: r ;
rvtBool: r.ReadBool(ValueName) ;
rvtDate: r.ReadDate(ValueName) ;
rvtDateTime: r.ReadDateTime(ValueName) ;
rvtFloat: r.ReadFloat(ValueName);
rvtInteger: r.ReadInteger(ValueName) ;
rvtString: r.ReadString(ValueName);
rvtTime: r.ReadTime(ValueName) ;
end;
finally
FreeAndNil(r);
end;
End;
end;
class function RegEx.ReadValueData(Root: HKEY; Key: string; ValueName: string; var buff: TBytes):Integer;
var
r : TRegistry;
begin
Result := 0;
if RegEx.ValueExists(Root,Key,ValueName) then
Begin
r := TRegistry.Create(KEY_READ);
try
r.RootKey := Root;
if r.OpenKey(Key,False) then
Result := r.ReadBinaryData(ValueName,buff,SizeOf(buff));
finally
FreeAndNil(r);
end;
End;
end;
class function RegEx.WriteValue;
var
r : TRegistry;
begin
Result := False;
r := TRegistry.Create(KEY_WRITE);
try
r.RootKey := Root;
if r.OpenKey(Key,True) then
Begin
case vType of
rvtCurrency: r.WriteCurrency(ValueName,Value) ;
rvtBool: r.WriteBool(ValueName,Value) ;
rvtDate: r.WriteDate(ValueName,Value) ;
rvtDateTime: r.WriteDateTime(ValueName,Value) ;
rvtFloat: r.WriteFloat(ValueName,Value);
rvtInteger: r.WriteInteger(ValueName,Value) ;
rvtString: r.WriteString(ValueName,VarToStr(Value));
rvtTime: r.WriteTime(ValueName,Value) ;
end;
Result := True;
End;
finally
FreeAndNil(r);
end;
end;
initialization
ProgEvHandler := TProgramEventHandlers.Create;
finalization
if Assigned(ProgEvHandler) then
FreeAndNil(ProgEvHandler);
end.
Procedure Tmain.EnableDisableAltKey;
var
r : TRegistry;
begin
try
r := TRegistry.Create;
r.RootKey := HKEY_LOCAL_MACHINE;
case EnableKey of
False :
Begin
if r.KeyExists(RKEY_KEYMAP_KEY) = false then
r.CreateKey(RKEY_KEYMAP_KEY);
r.OpenKey(RKEY_KEYMAP_KEY,true);
r.WriteBinaryData(RKEY_ALTKEY_VALUENAME,RKEY_KEYMAP_ALTKEY_VALUE,
SizeOf(RKEY_KEYMAP_ALTKEY_VALUE));
End;
True:
Begin
if r.KeyExists(RKEY_KEYMAP_KEY) then
Begin
r.OpenKey(RKEY_KEYMAP_KEY,false);
if r.ValueExists(RKEY_ALTKEY_VALUENAME) then
Begin
r.DeleteValue(RKEY_ALTKEY_VALUENAME);
end;
End;
End;
end;
finally
r.Free;
ArrangeObjects;
end;
end;