qrRRect
UNIT qrRRect;
INTERFACE
USES
Graphics, Classes, Windows, QReport, QuickRpt;
type
TQRRoundRect = class(TQRPrintable)
private
FBrush : TBrush;
FPen : TPen;
FCurve: Integer;
procedure SetBrush(Value : TBrush);
procedure SetPen(Value : TPen);
procedure SetCurve(Value: Integer);
protected
procedure Paint; override;
procedure Print(OfsX, OfsY : integer); override;
procedure StyleChanged(sender : TObject);
procedure DefineProperties(Filer: TFiler); override;
procedure ReadVisible(Reader : TReader); virtual;
procedure WriteDummy(Writer : TWriter); virtual;
public
constructor Create(AOwner : TComponent); override;
destructor Destroy; override;
published
property Brush : TBrush read FBrush write SetBrush;
property Height default 65;
property Pen : TPen read FPen write Setpen;
property Width default 65;
property Curve: Integer READ FCurve WRITE SetCurve;
end;
procedure Register;
implementation
constructor TQRRoundRect.Create(AOwner: TComponent);
begin
inherited Create(AOwner);
Width := 100;
Height := 50;
FCurve := 20;
FPen := TPen.Create;
FBrush := TBrush.Create;
FBrush.OnChange := StyleChanged;
FPen.OnChange := StyleChanged;
end;
procedure TQRRoundRect.DefineProperties(Filer: TFiler);
begin
Filer.DefineProperty('Visible', ReadVisible, WriteDummy, false); { <-- do not resource }
INHERITED DefineProperties(Filer);
end;
procedure TQRRoundRect.ReadVisible(Reader : TReader);
begin
Enabled := Reader.ReadBoolean;
end;
procedure TQRRoundRect.WriteDummy(Writer : TWriter);
begin
end;
procedure TQRRoundRect.StyleChanged(Sender : TObject);
begin
Invalidate;
end;
procedure TQRRoundRect.SetBrush(Value: TBrush);
begin
FBrush.Assign(Value);
end;
procedure TQRRoundRect.SetPen(Value: TPen);
begin
FPen.Assign(Value);
end;
procedure TQRRoundRect.SetCurve(Value: Integer);
begin
IF Value<>FCurve THEN BEGIN
FCurve := Value;
Invalidate;
END;
end;
procedure TQRRoundRect.Paint;
begin
inherited paint;
with Canvas do begin
Pen := FPen;
Brush := FBrush;
RoundRect(0,0,Width,Height,FCurve,FCurve);
end
end;
procedure TQRRoundRect.Print(OfsX,OfsY : Integer);
begin
IF ParentReport.FinalPass and Enabled then begin
QRPrinter.Canvas.Brush := Brush;
QRPrinter.Canvas.Pen := Pen;
WITH QRPrinter DO BEGIN
WITH Canvas DO
RoundRect(XPos(OfsX + Size.Left), YPos(OfsY + Size.Top),
XPos(OfsX+Size.Left + Size.Width), YPos(OfsY + Size.Top + Size.Height),
Round(QRPrinter.XFactor*FCurve*2.54),
Round(QRPrinter.YFactor*FCurve*2.54));
END;
end;
end;
destructor TQRRoundRect.Destroy;
begin
FPen.Free;
FBrush.Free;
inherited Destroy;
end;
procedure Register;
begin
RegisterComponents('QReport', [TQRRoundRect]);
{$ifdef ver100}
RegisterNonActiveX([TQRRoundRect],axrComponentOnly);
{$endif}
end;
end.
Delphi - .....................................
Table2
unit Table2;
interface
uses
Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
Db, DBTables, BDE;
type
TTable2 = class(TTable)
private
{ Déclarations privées }
protected
{ Déclarations protégées }
procedure InitFieldVchks;
public
{ Déclarations publiques }
procedure Open;
published
{ Déclarations publiées }
end;
procedure register;
implementation
procedure TTable2.Open;
begin
Active:=True;
InitFieldVchks;
end;
procedure TTable2.InitFieldVchks;
var
TmpCursor: hdbicur;
VCheck: VCHKDesc;
rslt: dbiResult;
begin
Check(DbiOpenVchkList(DbHandle, PChar(TableName), nil, TmpCursor));
Check(DbiSetToBegin(TmpCursor));
repeat
rslt:= DbiGetNextRecord(TmpCursor, dbiNOLOCK, @VCheck, nil);
if (rslt <> DBIERR_EOF) then
Fields[VCheck.iFldNum-1].EditMask:=StrPas(VCheck.szPict);
until rslt <> DBIERR_NONE;
Check(DbiCloseCursor(TmpCursor));
end;
procedure register;
begin
RegisterComponents('VCL', [TTable2]);
end;
end.
Delphi - .....................................
TableMirror
unit TableMirror;
interface
uses
Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
Db, DBTables;
type
TTableMirror = class(TTable)
private
{ Private declarations }
protected
{ Protected declarations }
TableMirror : TTable;
FDatabaseNameMirror : string;
FDoMirror : boolean;
CurRecord : Variant;
CurFields : string;
LastState : TDataSetState;
LastLocate : boolean;
procedure GetCurPosition;
public
{ Public declarations }
constructor Create(AOwner: TComponent); override;
destructor Destroy; override;
procedure DoAfterOpen; override;
procedure DoAfterClose; override;
procedure DoBeforeDelete; override ;
procedure DoAfterDelete; override ;
procedure DoBeforeEdit; override;
procedure DoBeforePost; override;
procedure DoAfterPost; override;
published
{ Published declarations }
property DatabaseNameMirror : string read FDatabaseNameMirror write FDatabaseNameMirror ;
property DoMirror : boolean read FDoMirror write FDoMirror;
end;
procedure Register;
implementation
procedure Register;
begin
RegisterComponents('Data Access', [TTableMirror]);
end;
constructor TTableMirror.Create(AOwner: TComponent);
begin
inherited Create(AOwner);
TableMirror := nil;
end;
destructor TTableMirror.Destroy;
begin
inherited ;
end;
procedure TTableMirror.GetCurPosition;
var
i : integer;
begin
if TableMirror <> nil then
begin
for i := 0 to FieldCount-1 do
begin
CurRecord[i] := FieldValues[Fields[i].FieldName];
end;
LastLocate := TableMirror.locate(CurFields, CurRecord, []);
end;
end;
procedure TTableMirror.DoAfterOpen;
var
i : integer;
begin
inherited;
if DoMirror and (DatabaseNameMirror <> '') then
begin
TableMirror := TTable.Create(self);
TableMirror.TableName := TableName;
TableMirror.IndexFieldNames := IndexFieldNames;
TableMirror.IndexFiles := IndexFiles;
TableMirror.IndexName := IndexName;
TableMirror.DataBaseName := DataBaseNameMirror;
TableMirror.open;
CurRecord := VarArrayCreate([0, FieldCount-1], varVariant);
CurFields := '';
LastLocate := false;
for i := 0 to TableMirror.FieldCount-1 do
begin
if CurFields <> '' then
CurFields := CurFields + ';' + Fields[i].FieldName
else
CurFields := Fields[i].FieldName;
end;
end;
end;
procedure TTableMirror.DoBeforeDelete;
begin
inherited ;
GetCurPosition;
end;
procedure TTableMirror.DoAfterDelete;
begin
inherited ;
if TableMirror <> nil then
begin
if LastLocate then
TableMirror.delete;
end;
end;
procedure TTableMirror.DoAfterClose;
begin
inherited;
if TableMirror <> nil then
begin
TableMirror.close;
TableMirror.free;
TableMirror := nil;
VarClear(CurRecord);
end;
end;
procedure TTableMirror.DoBeforeEdit;
begin
inherited ;
GetCurPosition;
end;
procedure TTableMirror.DoBeforePost;
var
i : integer;
begin
inherited ;
if TableMirror <> nil then
begin
for i := 0 to FieldCount-1 do
begin
CurRecord[i] := FieldValues[Fields[i].FieldName];
end;
LastState := state;
end;
end;
procedure TTableMirror.DoAfterPost;
var
i : integer;
begin
inherited ;
if TableMirror <> nil then
begin
if LastState = dsInsert then
TableMirror.append
else
begin
if not LastLocate then
exit;
TableMirror.edit;
end;
for i := 0 to FieldCount-1 do
begin
TableMirror.FieldValues[Fields[i].FieldName] := CurRecord[i];
end;
TableMirror.post;
end;
end;
end.
Delphi - .....................................
DbFloat
unit DbFloat;
interface
uses
Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
StdCtrls, Mask, DBCtrls;
type
TSetCountry = (English,Danish,German);
TDBFloatEdit = class(TDBEdit)
private
{ Private declarations }
FDigits : byte;
FMin,FMax : extended;
fdec : char;
fShowError : Boolean;
fertext : String;
fertextMax : string;
fertextMin : string;
fertextMust : String;
fertextminval: string;
fertextmaxval: string;
foldval : extended;
fAllowNull : Boolean;
fMaxLength : Integer;
fLangauge : TSetCountry;
protected
{ Protected declarations }
procedure setvalue(Newvalue : extended);
procedure setmin(Newvalue : extended);
procedure setmax(Newvalue : extended);
procedure setdigits(Newvalue : byte);
function getvalue : extended;
procedure KeyPress(var Key: Char); override;
procedure doexit;override;
procedure doEnter;override;
public
{ Public declarations }
published
{ Published declarations }
property Digits : byte read FDigits write setDigits;
property Value : extended read getvalue write setValue;
property Min : extended read Fmin write setMin;
property Max : extended read Fmax write setmax;
property ShowError : Boolean read fShowError write fShowError;
property ErrorMessageMax :string read fertextMax write fertextMax;
property ErrorMessageMin :string read fertextMin write fertextMin;
property ErrorMessageMinVal :string read fertextMinval write fertextMinval;
property ErrorMessageMaxVal :string read fertextMaxval write fertextMaxval;
property ErrorText : string read fertext write fertext;
property ErrorMust : string read fertextMust write fertextMust;
property MaxLength : Integer read FmaxLength; // Maxlength will not be visible
Property AllowNull : Boolean Read FAllowNull write FAllowNull;
constructor create (aowner : TComponent);override;
end;
procedure Register;
implementation
constructor TDBFloatEdit.create (aowner : TComponent);
begin
inherited create(aowner);
fdec := decimalseparator;
fdigits := 1;
fmin := 0;
fmax := 99999999.9;
fAllowNull := True;
fShowError := True;
fLangauge := Danish;
Case fLangauge of
English : Begin
ErrorMessageminval:='The Min-Value is to large !';
ErrorMessagemaxval:='The Max-Value is to small !' ;
ErrorMessageMax := 'The value must be under ';
ErrorMessageMin := 'The value must be over ';
ErrorMust := 'The field must have a value';
ErrorText := 'Error';
end;
Danish : Begin
errorMessageMinVal:='Minimun værdien skal være ' + #13 + 'mindre end maximum værdien !';
errorMessageMaxVal:='Maximum værdien skal være ' + #13 + 'større end minumum værdien !' ;
ErrorMessageMax := 'Værdien må maximum være ';
ErrorMessageMin := 'Værdien må minimum være ';
ErrorMust := 'Feltet skal udfyldes.';
ErrorText := 'Fejl';
end;
German : Begin
ErrorMessageminval:='Der Min-Wert ist zu groß !';
ErrorMessagemaxval:='Der Max-Wert ist zu klein !' ;
ErrorMessageMax := 'Der Wert muß kleiner sein als ';
ErrorMessageMin := 'Der Wert muß größer sein als ';
ErrorMust := 'Das Feld muß einen Wert besitzen';
ErrorText := 'Fehler';
end;
end;
end;
procedure Register;
begin
RegisterComponents('Data Controls', [TDBFloatEdit]);
end;
procedure TDBFloatEdit.doenter;
begin
foldval:=getvalue;
inherited;
end;
procedure TDBFloatEdit.doexit;
var ts : string;
result:extended;
begin
ts := text;
inherited;
If (ts = '') And (AllowNull) Then
Begin
end
Else
Begin
try
result := strtofloat(ts);
except
if fShowError then
Begin
If ts = '' then MessageDlg(fErTextMust, mtWarning ,[mbOk], 0)
Else
// showmessage(fertext);
end;
setvalue(foldval);
selectall;
setfocus;
exit;
end;
if (result < fmin) or
(result > fmax) then
begin
if fShowError then
Begin
If (result < fmin) Then
MessageDlg(fErTextMin + floattostrf(fmin,fffixed,18,fdigits),mtInformation, [mbOk], 0);
If (result > fmax) Then
MessageDlg(fErTextMax + floattostrf(fMax,fffixed,18,fdigits),mtInformation, [mbOk], 0);
end;
setvalue(foldval);
selectall;
setfocus;
exit;
end;
// Ausgabe formatieren
text := floattostrf(result,fffixed,18,fdigits);
value:=strtofloat(text);
inherited;
end;
end;
procedure TDBFloatEdit.setvalue(Newvalue : extended);
var tmp : string;
begin
if newvalue > fmax then begin
if fShowError then showmessage(fertextMax);
newvalue := fmax;
end;
if newvalue < fmin then begin
if fShowError then showmessage(fertextMin);
newvalue := fmin;
end;
tmp := floattostrf(newvalue,fffixed,18,fdigits);
text:=tmp;
end;
function TDBFloatedit.getvalue : extended;
var ts : string;
begin
ts := text;
If Not AllowNull Then
Begin
if (ts = '-') or (ts = fdec) or (ts = '') then ts := '0';
end
Else
Begin
if (ts = '-') or (ts = fdec) or (ts = '') then ts := '';
end;
IF ts <> '' Then
Begin
try
result := strtofloat(ts);
except
//if fertext <> notext then showmessage(fertext);
result := fmin;
end;
if result < fmin then begin
//if fertext <> notext then showmessage(fertext);
result := fmin;
end;
if result > fmax then begin
//if fertext <> notext then showmessage(fertext);
result := fmax;
end;
end
else
result := 0;
end;
procedure TDBFloatEdit.setdigits;
begin
if fdigits <> newValue then
begin
if newvalue > 18 then newvalue := 18;
fdigits := newvalue;
setvalue(getvalue);
end;
end;
procedure TDBFloatEdit.setmin;
begin
if fmin <> newValue then begin
if fmin > fmax then begin
showmessage(fertextminval);
newvalue := fmax;
end;
fmin := newvalue;
If (newValue = null) and (AllowNull) Then
Begin
end
Else
setvalue(getvalue);
end;
end;
procedure TDBFloatEdit.setmax;
begin
if fmax <> newValue then begin
if fmin > fmax then begin
showmessage(fertextmaxval);
newvalue := fmin;
end;
fmax := newvalue;
If (newValue = null) and (AllowNull) Then
Begin
end
Else
setvalue(getvalue);
end;
end;
procedure TDBFloatedit.keypress;
var ts : string;
// result : extended;
begin
if key = #27 then begin // ESC
setvalue(foldval);
selectall;
// inherited;
exit;
end;
if key < #32 then begin // SPACE
inherited;
exit;
end;
ts := copy(text,1,selstart)+copy(text,selstart+sellength+1,500);
if (key <'0') or (key > '9') then if (key <> fdec) and (key <> '-') then begin
inherited;
key := #0;
exit;
end;
if key = fdec then if pos(fdec,ts) <> 0 then begin
inherited;
key := #0;
exit;
end;
if key = '-' then if pos('-',ts) <> 0 then begin
inherited;
key := #0;
exit;
end;
if key = '-' then if fmin >= 0 then begin // Remove '-' if Min = 0
inherited;
key := #0;
exit;
end;
if key = fdec then if fdigits = 0 then begin // Remove fdec if digits = o
inherited;
key := #0;
exit;
end;
// seltext durch key ersetzen
ts := copy(text,1,selstart)+key+copy(text,selstart+sellength+1,500);
// Überprüfen, ob gültiger wert;
if key > #32 then
if pos(fdec,ts)<> 0 then
begin
if length(ts)-pos(fdec,ts) > fdigits then
begin
inherited;
key := #0;
exit;
end;
end;
if key = '-' then if pos('-',ts) <> 1 then begin // Taking care of '-', mus only be at the first place
inherited;
key := #0;
exit;
end;
if ts ='' then begin // put Fmin into text if ''
inherited;key := #0;
text := floattostrf(fmin,fffixed,18,fdigits);selectall;
exit;
end;
if ts = '-' then begin
inherited;key:=#0;
text := '-0';selstart := 1;sellength:=1;
exit;
end;
if ts = fdec then begin
inherited;key:=#0;
text := '0'+fdec+'0';
selstart :=2;
sellength:=1;
exit;
end;
inherited;
end;
end.
Delphi - .....................................
dualQry
Unit dualQry; { Small dataset derived class }
interface
Uses Classes,DBTables,DB,SysUtils,DBConsts,LibConst,DBIprocs,DBIErrs,DBITypes,DsgnIntf,Dialogs,Forms;
Const MaxParam = 10; { max number of query parameters }
MaxParamLen=255; { max length of a substituted param }
Type
tQueryType = (qtQBE,qtSQL);
Type
TDualQuery=Class(TDBDataSet)
private
FFileName : TFileName;
FAnswerTable:String;
FAnswerType:TTableType;
FQueryType: tQueryType;
FBlankasZero,
FAuxTables,
FRequestLive:Boolean;
eQueryLang : dbiQryLang;
protected
function CreateHandle: HDBICur; override;
public
FQuery: TStrings;
FParams : TStrings;
NumParam:Integer;
Param,Subst:Array[0..MaxParam] of String[MaxParamLen];
procedure SetQuery(QLines: TStrings);
Constructor Create(AOwner:TComponent); override;
destructor Destroy; override;
Procedure AddParam(Const tmpParam,tmpSubst:String; doReplace: boolean);
Procedure DeleteParam(Const tmpParam:String; warn: boolean);
Procedure ClearParams;
procedure SetQueryLang( which : tQueryType);
Function GetAliasPath(Const Alias:String):String;
Function GetDBTablePath(Const TableName:String):String;
Function ReplaceString(s:String):String;
Function LoadFromFile( fname : string):boolean;
Function SaveToFile( fname : string):boolean;
published
property QLines: TStrings read FQuery write SetQuery;
property QParams: TStrings read FParams write FParams;
property AnswerTable: String read FAnswerTable write FAnswerTable;
property RequestLive: Boolean read FRequestLive write FRequestLive;
property BlankasZero: Boolean read FBlankasZero write FBlankAsZero;
property AuxTables: Boolean read FAuxTables write FAuxTables;
property AnswerType:TTableType read FAnswerType write FAnswerType;
property QueryLanguage: tQueryType read fQueryType write setQueryLang;
property Filename : TFileName read fFileName write fFileName;
End;
Procedure Register;
implementation
Constructor TDualQuery.Create(AOwner:TComponent);
Begin
inherited Create(AOwner);
FQuery := TStringList.Create;
FParams := TStringList.create;
NumParam:=0;
FAnswerType:=ttDBase; { by default, DBase answer tables }
QueryLanguage := qtQBE;
end;
destructor TDualQuery.Destroy;
Begin
FQuery.Free;
FParams.free;
inherited Destroy;
End;
Function TDualQuery.LoadFromFile( fname : string): boolean;
begin
if not fileExists(fname) then begin
result := false;
exit;
end;
FQuery.loadFromFile(fname);
filename := '';
result := true;
end;
Function TDualQuery.SaveToFile( fname : string): boolean;
begin
FQuery.saveToFile(fname);
result := true;
end;
Procedure TDualQuery.setQueryLang( which : TQueryType);
begin
if which = qtQBE then eQueryLang := qrylangQBE
else eQueryLang := qrylangSQL;
end;
Procedure TDualQuery.ClearParams;
Begin
QParams.clear;
fParams.clear;
End;
Procedure TDualQuery.DeleteParam(Const tmpParam:String; warn: boolean);
var
qstr,par :string;
xx,ii,k : integer;
Begin
k := fParams.count;
for ii := 0 to k-1 do begin
qstr := fparams[ii];
xx := pos(',',qstr) ;
par := copy(qstr,1,xx-1);
if par = tmpParam then begin
if not warn then begin
fParams.delete(ii);
exit;
end { end do replace }
else begin
messageDlg('Deleting' + tmpParam ,mtInformation,[mbOK],0);
exit;
end; { end don't replace }
end; { end par=tmpParam}
end;{ end ii for loop }
end;
Procedure TDualQuery.AddParam(Const tmpParam,tmpSubst:String;doReplace: boolean);
var
qstr,par :string;
xx,ii,k : integer;
alreadythere : boolean;
Begin
k := fParams.count;
alreadythere := false;
for ii := 0 to k-1 do begin
qstr := fparams[ii];
xx := pos(',',qstr) ;
par := copy(qstr,1,xx-1);
if par = tmpParam then begin
if doReplace then begin
fParams[ii] := tmpParam + ',' + tmpSubst;
end { end do replace }
else begin
messageDlg('Did not replace parameter ' + tmpParam + ' with ' + tmpSubst + '.',mtInformation,[mbOK],0);
end; { end don't replace }
alreadythere := true;
end; { end par=tmpParam}
end;{ end ii for loop }
if not alreadyThere then fparams.add(tmpParam + ',' + tmpSubst);
End;
Function TDualQuery.ReplaceString(s:String):String;
Var
t,ii,k,xx:Integer;
qstr,par,subs : string;
lstr,rstr:string;
Begin
if s = '' then
begin
result := s;
exit;
end;
k := fParams.count;
for t:=0 to k-1 do begin
qstr := fParams[t];
if qstr = '' then continue;
xx := Pos(',',qstr);
par := copy (qstr,1,xx-1) ;
subs := copy(qstr,xx+1,length(qstr)-xx);
Repeat
ii:=Pos(par,s);
if ii>0 then
begin
lstr := Copy(s,1,ii-1);
rstr := Copy(s,ii + length(par),length(s)+length(par) + length(subs));
s := lstr + subs + rstr;
end;
Until ii=0;
end;
result:=s;
End;
function TDualQuery.CreateHandle: HDBICur;
Var p:HDbiCur;
Stmt:hDBIStmt;
{St:Array[0..255] of Char; }
aBatTblDesc:BATTblDesc;
r:Longint;
dbiErr:DBIRESULT;
NewQuery:TStrings;
t,d:Integer;
tmpType:String;
beforestr,afterstr : string;
Begin
if fFileName <> '' then begin
if fileExists(fFileName) then FQuery.loadFromFile(fFileName)
else begin
messageDlg('No such file!', mtError, [mbOK],0);
exit;
end;
end;
NewQuery:=TStringList.Create;
With FQuery do
for t:=0 to Count-1 do
begin
beforestr := strings[t];
NewQuery.Add(ReplaceString(Strings[t]));
afterstr := strings[t];
d := t;
end;
DbiQAlloc( DBHandle, eQueryLang, Stmt );
if FRequestLive then Check(dbiSetProp(hDBIObj(Stmt),stmtLIVENESS,longint(wantLive)))
Else Check(dbiSetProp(hDBIObj(Stmt),stmtLIVENESS,longint(wantDefault)));
if FBlankAsZero then Check(dbiSetProp(hDBIObj(Stmt),stmtBLANKS,1));
if FAuxTables then Check(dbiSetProp(hDBIObj(Stmt),stmtAUXTBLS,1));
check(dbiQExecDirect(DBHandle,eQueryLang,NewQuery.GetText,@p));
Check(dbiQFree(Stmt));
if (FAnswerTable<>'') And Assigned(p) then
Begin
Check(DbiSetToBegin(p));
With aBatTblDesc do
Begin
hDB:=DBHandle;
StrPCopy(szTblName,GetDBTablePath(FAnswerTable));
Case FAnswerType of
ttParadox: tmpType:=szParadox;
ttDbase : tmpType:=szDbase;
ttAscii : tmpType:=szAscii;
end;
StrPCopy(szTblType,tmpType);
szUsername[0]:=#0;
szPassword[0]:=#0;
End;
r:=0;
dbiErr:=dbiDeleteTable(DBHandle,aBatTblDesc.szTblName,aBatTblDesc.szTblType);
if dbiErr<>DBIERR_NOSUCHTABLE then Check(dbiErr);
Check(DbiBatchMove(nil,p,@aBatTblDesc,nil,batchCOPY,0,
nil, nil, nil, 0, nil, nil,
nil, nil, nil, nil, TRUE, TRUE,
r, TRUE));
End;
NewQuery.Free;
result := p;
End;
procedure TDualQuery.SetQuery(QLines: TStrings);
begin
FQuery.Assign(QLines);
end;
Function HasAlias(Const TableName:String):Boolean;
Begin
Result:=Pos(':',TableName)>0;
End;
Function TDualQuery.GetAliasPath(Const Alias:String):String;
Var AliasList:TStringList;
i:Longint;
DBPath:String;
Begin
Result:='';
AliasList:=TStringList.Create;
try
Session.GetAliasNames(AliasList);
i:=AliasList.IndexOf(Alias);
if i<0 then raise EDatabaseError.Create('Alias '+Alias+' doesnt exist')
else
Begin
Session.GetAliasParams(Alias,AliasList);
DBPath := AliasList.Values['PATH'];
if DBPath='' then raise EDatabaseError.Create('Alias path from '+Alias+' invalid')
else Result:=DBPath;
end;
finally
AliasList.Free;
end;
End;
Procedure SplitTableName(Const TableName:String; Var Alias,Name:String);
Var p1,p2:Integer;
Begin
Name:=TableName;
Alias:='';
p1:=Pos(':',TableName);
if p1>0 then
Begin
p2:=Pos(':',Copy(TableName,p1+1,255));
if p2>0 then
Begin
Alias:=Copy(TableName,p1+1,p2-1);
Name:=Copy(TableName,p1+p2+1,255);
End;
End;
End;
Function TDualQuery.GetDBTablePath(Const TableName:String):String;
Var Alias,Name:String;
Begin
if not HasAlias(TableName) then Result:=TableName
else
Begin
SplitTableName(TableName,Alias,Name);
if Alias<>'' then Result:=GetAliasPath(Alias)+''+Name
else Result:=TableName;
End;
End;
Procedure Register;
Begin
RegisterComponents(LoadStr(srDAccess),[TDualQuery]);
End;
end.
Delphi - .....................................
DBPanel
unit DBPanel;
interface
uses
Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
ExtCtrls, DBCtrls, DB;
type
TDBPanel = class(TCustomPanel)
private
{ Private declarations }
FDataLink: TFieldDataLink;
procedure DataChange(Sender: TObject);
function GetDataField: string;
function GetDataSource: TDataSource;
function GetField: TField;
function GetFieldText: string;
procedure SetDataField(const Value: string);
procedure SetDataSource(Value: TDataSource);
procedure CMGetDataLink(var Message: TMessage); message CM_GETDATALINK;
protected
{ Protected declarations }
function GetPanelText: string;
procedure Paint; override;
procedure Loaded; override;
procedure Notification(AComponent: TComponent;
Operation: TOperation); override;
public
{ Public declarations }
constructor Create(AOwner: TComponent); override;
destructor Destroy; override;
function ExecuteAction(Action: TBasicAction): Boolean; override;
function UpdateAction(Action: TBasicAction): Boolean; override;
function UseRightToLeftAlignment: Boolean; override;
property Field: TField read GetField;
property DockManager;
published
{ Published declarations }
property DataField: string read GetDataField write SetDataField;
property DataSource: TDataSource read GetDataSource write SetDataSource;
property Align;
property Alignment;
property Anchors;
property AutoSize;
property BevelInner;
property BevelOuter;
property BevelWidth;
property BiDiMode;
property BorderWidth;
property BorderStyle;
property Caption;
property Color;
property Constraints;
property Ctl3D;
property UseDockManager default True;
property DockSite;
property DragCursor;
property DragKind;
property DragMode;
property Enabled;
property FullRepaint;
property Font;
property Locked;
property ParentBiDiMode;
property ParentColor;
property ParentCtl3D;
property ParentFont;
property ParentShowHint;
property PopupMenu;
property ShowHint;
property TabOrder;
property TabStop;
property Visible;
property OnCanResize;
property OnClick;
property OnConstrainedResize;
property OnDockDrop;
property OnDockOver;
property OnDblClick;
property OnDragDrop;
property OnDragOver;
property OnEndDock;
property OnEndDrag;
property OnEnter;
property OnExit;
property OnGetSiteInfo;
property OnMouseDown;
property OnMouseMove;
property OnMouseUp;
property OnResize;
property OnStartDock;
property OnStartDrag;
property OnUnDock;
end;
procedure Register;
implementation
procedure Register;
begin
RegisterComponents('Tims', [TDBPanel]);
end;
constructor TDBPanel.Create(AOwner: TComponent);
begin
inherited Create(AOwner);
ControlStyle := ControlStyle + [csReplicatable];
FDataLink := TFieldDataLink.Create;
FDataLink.Control := Self;
FDataLink.OnDataChange := DataChange;
end;
destructor TDBPanel.Destroy;
begin
FDataLink.Free;
FDataLink := nil;
inherited Destroy;
end;
procedure TDBPanel.Loaded;
begin
inherited Loaded;
if (csDesigning in ComponentState) then DataChange(Self);
end;
procedure TDBPanel.Notification(AComponent: TComponent;
Operation: TOperation);
begin
inherited Notification(AComponent, Operation);
if (Operation = opRemove) and (FDataLink <> nil) and
(AComponent = DataSource) then DataSource := nil;
end;
function TDBPanel.GetDataSource: TDataSource;
begin
Result := FDataLink.DataSource;
end;
procedure TDBPanel.SetDataSource(Value: TDataSource);
begin
if not (FDataLink.DataSourceFixed and (csLoading in ComponentState)) then
FDataLink.DataSource := Value;
if Value <> nil then Value.FreeNotification(Self);
end;
function TDBPanel.GetDataField: string;
begin
Result := FDataLink.FieldName;
end;
procedure TDBPanel.SetDataField(const Value: string);
begin
FDataLink.FieldName := Value;
end;
function TDBPanel.GetField: TField;
begin
Result := FDataLink.Field;
end;
function TDBPanel.GetFieldText: string;
begin
if FDataLink.Field <> nil then
Result := FDataLink.Field.DisplayText
else
if csDesigning in ComponentState then Result := Name else Result := '';
end;
procedure TDBPanel.DataChange(Sender: TObject);
begin
Caption := GetFieldText;
end;
procedure TDBPanel.CMGetDataLink(var Message: TMessage);
begin
Message.Result := Integer(FDataLink);
end;
function TDBPanel.ExecuteAction(Action: TBasicAction): Boolean;
begin
Result := inherited ExecuteAction(Action) or (FDataLink <> nil) and
FDataLink.ExecuteAction(Action);
end;
function TDBPanel.UpdateAction(Action: TBasicAction): Boolean;
begin
Result := inherited UpdateAction(Action) or (FDataLink <> nil) and
FDataLink.UpdateAction(Action);
end;
function TDBPanel.UseRightToLeftAlignment: Boolean;
begin
Result := DBUseRightToLeftAlignment(Self, Field);
end;
procedure TDBPanel.Paint;
const
Alignments: array[TAlignment] of Longint = (DT_LEFT, DT_RIGHT, DT_CENTER);
var
Rect: TRect;
TopColor, BottomColor: TColor;
FontHeight: Integer;
Flags: Longint;
sCaption : string;
procedure AdjustColors(Bevel: TPanelBevel);
begin
TopColor := clBtnHighlight;
if Bevel = bvLowered then TopColor := clBtnShadow;
BottomColor := clBtnShadow;
if Bevel = bvLowered then BottomColor := clBtnHighlight;
end;
begin
Rect := GetClientRect;
if BevelOuter <> bvNone then
begin
AdjustColors(BevelOuter);
Frame3D(Canvas, Rect, TopColor, BottomColor, BevelWidth);
end;
Frame3D(Canvas, Rect, Color, Color, BorderWidth);
if BevelInner <> bvNone then
begin
AdjustColors(BevelInner);
Frame3D(Canvas, Rect, TopColor, BottomColor, BevelWidth);
end;
with Canvas do
begin
Brush.Color := Color;
FillRect(Rect);
Brush.Style := bsClear;
Font := Self.Font;
FontHeight := TextHeight('W');
with Rect do
begin
Top := ((Bottom + Top) - FontHeight) div 2;
Bottom := Top + FontHeight;
end;
Flags := DT_EXPANDTABS or DT_VCENTER or Alignments[Alignment];
Flags := DrawTextBiDiModeFlags(Flags);
sCaption := GetPanelText;
DrawText(Handle, PChar(sCaption), -1, Rect, Flags);
end;
end;
function TDBPanel.GetPanelText: string;
begin
if csPaintCopy in ControlState then
Result := GetFieldText else
Result := Caption;
end;
end.
_
Delphi - .....................................
