1113 lines
31 KiB
ObjectPascal
1113 lines
31 KiB
ObjectPascal
{ dbutils unit
|
|
|
|
Copyright (C) 2005-2017 Lagunov Aleksey alexs75@yandex.ru and Lazarus team
|
|
original conception from rx library for Delphi (c)
|
|
|
|
This library is free software; you can redistribute it and/or modify it
|
|
under the terms of the GNU Library General Public License as published by
|
|
the Free Software Foundation; either version 2 of the License, or (at your
|
|
option) any later version with the following modification:
|
|
|
|
As a special exception, the copyright holders of this library give you
|
|
permission to link this library with independent modules to produce an
|
|
executable, regardless of the license terms of these independent modules,and
|
|
to copy and distribute the resulting executable under terms of your choice,
|
|
provided that you also meet, for each linked independent module, the terms
|
|
and conditions of the license of that module. An independent module is a
|
|
module which is not derived from or based on this library. If you modify
|
|
this library, you may extend this exception to your version of the library,
|
|
but you are not obligated to do so. If you do not wish to do so, delete this
|
|
exception statement from your version.
|
|
|
|
This program is distributed in the hope that it will be useful, but WITHOUT
|
|
ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or
|
|
FITNESS FOR A PARTICULAR PURPOSE. See the GNU Library General Public License
|
|
for more details.
|
|
|
|
You should have received a copy of the GNU Library General Public License
|
|
along with this library; if not, write to the Free Software Foundation,
|
|
Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA.
|
|
}
|
|
|
|
unit rxdbutils;
|
|
|
|
{$I rx.inc}
|
|
|
|
interface
|
|
|
|
uses
|
|
LCLType, LCLIntf, Registry, Classes, SysUtils, DB, IniFiles;
|
|
|
|
const
|
|
IntegerDataTypes = [ftSmallint, ftInteger, ftWord, ftLargeint, ftAutoInc];
|
|
|
|
NumericDataTypes = IntegerDataTypes + [ftFloat, ftCurrency, ftBCD];
|
|
|
|
DataTimeTypes = [ftTime, ftDateTime, ftTimeStamp, ftDate];
|
|
|
|
StringTypes = [ftString, {ftMemo,} ftFixedChar, ftWideString, ftFixedWideChar, ftWideMemo];
|
|
|
|
|
|
type
|
|
TRxSearchDirection = (rsdAll, rsdForward, rsdBackward);
|
|
type
|
|
|
|
{ TLocateObject }
|
|
|
|
TLocateObject = class(TObject)
|
|
private
|
|
FDataSet: TDataSet;
|
|
FLookupField: TField;
|
|
FLookupValue: string;
|
|
FLookupExact, FCaseSensitive: Boolean;
|
|
FBookmark: TBookmark;
|
|
FIndexSwitch: Boolean;
|
|
procedure SetDataSet(Value: TDataSet);
|
|
protected
|
|
function MatchesLookup(Field: TField): Boolean;
|
|
procedure CheckFieldType(Field: TField); virtual;
|
|
procedure ActiveChanged; virtual;
|
|
function LocateFilter: Boolean; virtual;
|
|
function LocateKey: Boolean; virtual;
|
|
function LocateFull: Boolean; virtual;
|
|
function UseKey: Boolean; virtual;
|
|
function FilterApplicable: Boolean; virtual;
|
|
property LookupField: TField read FLookupField;
|
|
property LookupValue: string read FLookupValue;
|
|
property LookupExact: Boolean read FLookupExact;
|
|
property CaseSensitive: Boolean read FCaseSensitive;
|
|
property Bookmark: TBookmark read FBookmark write FBookmark;
|
|
public
|
|
function Locate(const KeyField, KeyValue: string; Exact,
|
|
ACaseSensitive: Boolean): Boolean;
|
|
property DataSet: TDataSet read FDataSet write SetDataSet;
|
|
property IndexSwitch: Boolean read FIndexSwitch write FIndexSwitch;
|
|
end;
|
|
|
|
type
|
|
TCreateLocateObject = function: TLocateObject;
|
|
const
|
|
CreateLocateObject: TCreateLocateObject = nil;
|
|
function CreateLocate(DataSet: TDataSet): TLocateObject;
|
|
|
|
{ Utility routines }
|
|
|
|
function IsDataSetEmpty(DataSet: TDataSet): Boolean;
|
|
procedure RefreshQuery(Query: TDataSet);
|
|
function DataSetSortedSearch(DataSet: TDataSet; const Value,
|
|
FieldName: string; CaseInsensitive: Boolean): Boolean;
|
|
function DataSetSectionName(DataSet: TDataSet): string;
|
|
|
|
procedure InternalSaveFields(DataSet: TDataSet; IniFile: TObject;
|
|
const Section: string);
|
|
procedure InternalRestoreFields(DataSet: TDataSet; IniFile: TObject;
|
|
const Section: string; RestoreVisible: Boolean);
|
|
|
|
{procedure InternalSaveFields(DataSet: TDataSet; IniFile: TIniFile;
|
|
const Section: string);
|
|
procedure InternalRestoreFields(DataSet: TDataSet; IniFile: TObject;
|
|
const Section: string; RestoreVisible: Boolean);}
|
|
|
|
function DataSetLocateThrough(DataSet: TDataSet; const KeyFields: string;
|
|
const KeyValues: Variant; Options: TLocateOptions; SearchOrigin:TRxSearchDirection = rsdAll; ASearchFromStart:boolean = false): Boolean;
|
|
|
|
procedure SaveFieldsReg(DataSet: TDataSet; IniFile: TRegIniFile);
|
|
procedure RestoreFieldsReg(DataSet: TDataSet; IniFile: TRegIniFile;
|
|
RestoreVisible: Boolean);
|
|
procedure SaveFields(DataSet: TDataSet; IniFile: TIniFile);
|
|
procedure RestoreFields(DataSet: TDataSet; IniFile: TIniFile;
|
|
RestoreVisible: Boolean);
|
|
procedure AssignRecord(Source, Dest: TDataSet; ByName: Boolean);
|
|
function ConfirmDelete: Boolean;
|
|
procedure ConfirmDataSetCancel(DataSet: TDataSet);
|
|
procedure CheckRequiredField(Field: TField);
|
|
procedure CheckRequiredFields(const Fields: array of TField);
|
|
function ExtractFieldName(const Fields: string; var Pos: Integer): string;
|
|
procedure FillValueForField(const Field: TField; Value:Variant);
|
|
procedure CloneRecord(DataSet: TDataSet; IgnoreFields: array of const);
|
|
function FieldValueToStrings(const DataSet: TDataSet; const FieldName: string; List:TStrings = nil):TStrings;
|
|
|
|
procedure AddSQLExpressionAnd(var MacroStr:string; const MacroWhere:string); overload;
|
|
procedure AddSQLExpressionAnd(var MacroStr:string; const MacroWhere:string; Params:array of const); overload;
|
|
procedure AddSQLExpressionOr(var MacroStr:string; const MacroWhere:string);
|
|
|
|
{ SQL expressions }
|
|
|
|
function DateToSQL(Value: TDateTime): string;
|
|
function FormatSQLDateRange(Date1, Date2: TDateTime;
|
|
const FieldName: string): string;
|
|
function FormatSQLDateRangeEx(Date1, Date2: TDateTime;
|
|
const FieldName: string): string;
|
|
function FormatSQLNumericRange(const FieldName: string;
|
|
LowValue, HighValue, LowEmpty, HighEmpty: Double; Inclusive: Boolean): string;
|
|
function StrMaskSQL(const Value: string): string;
|
|
function FormatSQLCondition(const FieldName, AOperator, Value: string;
|
|
FieldType: TFieldType; Exact: Boolean): string;
|
|
function FormatAnsiSQLCondition(const FieldName, AOperator, Value: string;
|
|
FieldType: TFieldType; Exact: Boolean): string;
|
|
|
|
const
|
|
TrueExpr = '0=0';
|
|
|
|
const
|
|
{ Server Date formats}
|
|
sdfStandard16 = '''"''mm''/''dd''/''yyyy''"'''; {"mm/dd/yyyy"}
|
|
sdfStandard32 = '''''''dd/mm/yyyy'''''''; {'dd/mm/yyyy'}
|
|
sdfOracle = '"TO_DATE(''"dd/mm/yyyy"'', ''DD/MM/YYYY'')"';
|
|
sdfInterbase = '"CAST(''"mm"/"dd"/"yyyy"'' AS DATE)"';
|
|
sdfMSSQL = '"CONVERT(datetime, ''"mm"/"dd"/"yyyy"'', 103)"';
|
|
|
|
const
|
|
ServerDateFmt: string[50] = sdfStandard16;
|
|
|
|
{const
|
|
ftBlobTypes = [Low(TBlobType)..High(TBlobType)];}
|
|
|
|
procedure _DBError(const Msg: string);
|
|
|
|
implementation
|
|
|
|
uses Forms, Controls, Dialogs, RXDConst, rxlclutils, FileUtil,
|
|
RxAppUtils, RxStrUtils, Math, rxdateutil, LazUTF8;
|
|
|
|
{ Utility routines }
|
|
|
|
procedure _DBError(const Msg: string);
|
|
begin
|
|
DatabaseError(Msg);
|
|
end;
|
|
|
|
function ConfirmDelete: Boolean;
|
|
begin
|
|
Screen.Cursor := crDefault;
|
|
Result := MessageDlg(SDeleteRecordQuestion, mtConfirmation,
|
|
[mbYes, mbNo], 0) = mrYes;
|
|
end;
|
|
|
|
procedure ConfirmDataSetCancel(DataSet: TDataSet);
|
|
begin
|
|
if DataSet.State in [dsEdit, dsInsert] then begin
|
|
DataSet.UpdateRecord;
|
|
if DataSet.Modified then begin
|
|
case MessageDlg(SConfirmSave, mtConfirmation, mbYesNoCancel, 0) of
|
|
mrYes: DataSet.Post;
|
|
mrNo: DataSet.Cancel;
|
|
else SysUtils.Abort;
|
|
end;
|
|
end
|
|
else DataSet.Cancel;
|
|
end;
|
|
end;
|
|
|
|
function SetToBookmark(ADataSet: TDataSet; ABookmark: TBookmark): Boolean;
|
|
begin
|
|
Result := False;
|
|
with ADataSet do
|
|
if Active and (ABookmark <> nil) and not (Bof and Eof) and
|
|
BookmarkValid(ABookmark) then
|
|
try
|
|
ADataSet.GotoBookmark(ABookmark);
|
|
Result := True;
|
|
except
|
|
end;
|
|
end;
|
|
|
|
{ Refresh Query procedure }
|
|
|
|
procedure RefreshQuery(Query: TDataSet);
|
|
var
|
|
BookMk: TBookmark;
|
|
begin
|
|
with Query do
|
|
begin
|
|
DisableControls;
|
|
try
|
|
if Active then
|
|
BookMk := GetBookmark
|
|
else
|
|
BookMk := nil;
|
|
try
|
|
Close;
|
|
Open;
|
|
SetToBookmark(Query, BookMk);
|
|
finally
|
|
if BookMk <> nil then
|
|
FreeBookmark(BookMk);
|
|
end;
|
|
finally
|
|
EnableControls;
|
|
end;
|
|
end;
|
|
end;
|
|
|
|
{ TLocateObject }
|
|
|
|
procedure TLocateObject.SetDataSet(Value: TDataSet);
|
|
begin
|
|
ActiveChanged;
|
|
FDataSet := Value;
|
|
end;
|
|
|
|
function TLocateObject.LocateFull: Boolean;
|
|
begin
|
|
Result := False;
|
|
with DataSet do
|
|
begin
|
|
First;
|
|
while not EOF do
|
|
begin
|
|
if MatchesLookup(FLookupField) then
|
|
begin
|
|
Result := True;
|
|
Break;
|
|
end;
|
|
Next;
|
|
end;
|
|
end;
|
|
end;
|
|
|
|
function TLocateObject.LocateKey: Boolean;
|
|
begin
|
|
Result := False;
|
|
end;
|
|
|
|
function TLocateObject.FilterApplicable: Boolean;
|
|
begin
|
|
Result := FLookupField.FieldKind in [fkData, fkInternalCalc];
|
|
end;
|
|
|
|
function TLocateObject.LocateFilter: Boolean;
|
|
var
|
|
SaveCursor: TCursor;
|
|
Options: TLocateOptions;
|
|
Value: Variant;
|
|
begin
|
|
|
|
// SaveCursor := Screen.Cursor;
|
|
// Screen.Cursor := crHourGlass;
|
|
try
|
|
Options := [];
|
|
if not FCaseSensitive then Include(Options, loCaseInsensitive);
|
|
if not FLookupExact then Include(Options, loPartialKey);
|
|
if (FLookupValue = '') then
|
|
Value:=null //VarClear(Value)
|
|
else
|
|
Value := FLookupValue;
|
|
Result := DataSet.Locate(FLookupField.FieldName, Value, Options);
|
|
finally
|
|
// Screen.Cursor := SaveCursor;
|
|
end;
|
|
end;
|
|
|
|
procedure TLocateObject.CheckFieldType(Field: TField);
|
|
begin
|
|
end;
|
|
|
|
function TLocateObject.Locate(const KeyField, KeyValue: string;
|
|
Exact, ACaseSensitive: Boolean): Boolean;
|
|
var
|
|
LookupKey: TField;
|
|
begin
|
|
if DataSet = nil then
|
|
begin
|
|
Result := False;
|
|
Exit;
|
|
end;
|
|
DataSet.CheckBrowseMode;
|
|
LookupKey := DataSet.FieldByName(KeyField);
|
|
DataSet.CursorPosChanged;
|
|
FLookupField := LookupKey;
|
|
FLookupValue := KeyValue;
|
|
FLookupExact := Exact;
|
|
FCaseSensitive := ACaseSensitive;
|
|
if FLookupField.DataType <> ftString then
|
|
begin
|
|
FCaseSensitive := True;
|
|
try
|
|
CheckFieldType(FLookupField);
|
|
except
|
|
Result := False;
|
|
Exit;
|
|
end;
|
|
end;
|
|
FBookmark := DataSet.GetBookmark;
|
|
try
|
|
DataSet.DisableControls;
|
|
try
|
|
Result := MatchesLookup(FLookupField);
|
|
if not Result then
|
|
begin
|
|
if UseKey then
|
|
Result := LocateKey
|
|
else
|
|
begin
|
|
{ if FilterApplicable then Result := LocateFilter
|
|
else} Result := LocateFull;
|
|
end;
|
|
if not Result then SetToBookmark(DataSet, FBookmark);
|
|
end;
|
|
finally
|
|
DataSet.EnableControls;
|
|
end;
|
|
finally
|
|
FLookupValue := EmptyStr;
|
|
FLookupField := nil;
|
|
DataSet.FreeBookmark(FBookmark);
|
|
FBookmark := nil;
|
|
end;
|
|
end;
|
|
|
|
function TLocateObject.UseKey: Boolean;
|
|
begin
|
|
Result := False;
|
|
end;
|
|
|
|
procedure TLocateObject.ActiveChanged;
|
|
begin
|
|
end;
|
|
|
|
function TLocateObject.MatchesLookup(Field: TField): Boolean;
|
|
var
|
|
Temp: string;
|
|
begin
|
|
Temp := Field.AsString;
|
|
if not FLookupExact then
|
|
SetLength(Temp, Min(Length(FLookupValue), Length(Temp)));
|
|
if FCaseSensitive then Result := AnsiCompareStr(Temp, FLookupValue) = 0
|
|
else Result := AnsiCompareText(Temp, FLookupValue) = 0;
|
|
end;
|
|
|
|
function CreateLocate(DataSet: TDataSet): TLocateObject;
|
|
begin
|
|
if Assigned(CreateLocateObject) then Result := CreateLocateObject()
|
|
else Result := TLocateObject.Create;
|
|
if (Result <> nil) and (DataSet <> nil) then
|
|
Result.DataSet := DataSet;
|
|
end;
|
|
|
|
{ DataSet locate routines }
|
|
function DataSetLocateThrough(DataSet: TDataSet; const KeyFields: string;
|
|
const KeyValues: Variant; Options: TLocateOptions; SearchOrigin:TRxSearchDirection = rsdAll;
|
|
ASearchFromStart:boolean = false): Boolean;
|
|
var
|
|
FieldCount: Integer;
|
|
Fields: TList;
|
|
|
|
function CompareField(Field: TField; Value: Variant): Boolean;
|
|
var
|
|
S,S1: string;
|
|
|
|
begin
|
|
if (Field.DataType = ftString) or (loPartialKey in Options) then
|
|
begin
|
|
if loCaseInsensitive in Options then
|
|
begin
|
|
S := UTF8UpperCase(Field.AsString);
|
|
S1:=UTF8UpperCase(Value);
|
|
end
|
|
else
|
|
begin
|
|
S := Field.AsString;
|
|
S1:=Value;
|
|
end;
|
|
{ if (loPartialKey in Options) then
|
|
Delete(S, Length(S1) + 1, MaxInt);
|
|
|
|
if (loCaseInsensitive in Options) then
|
|
Result := UTF8CompareText(S, S1) = 0
|
|
else
|
|
Result := UTF8CompareStr(S, S1) = 0;}
|
|
|
|
if (loPartialKey in Options) then
|
|
begin
|
|
if ASearchFromStart then
|
|
begin
|
|
UTF8Delete(S, UTF8Length(S1) + 1, MaxInt);
|
|
Result := UTF8CompareStr(S, S1) = 0;
|
|
end
|
|
else
|
|
Result := UTF8Pos(S1, S) > 0
|
|
end
|
|
else
|
|
begin
|
|
Result := UTF8CompareStr(S, S1) = 0;
|
|
end;
|
|
end
|
|
// else Result := false //(Field.Value = Value);
|
|
else Result := (Field.Value = Value);
|
|
end;
|
|
|
|
function CompareRecord: Boolean;
|
|
var
|
|
I: Integer;
|
|
begin
|
|
if FieldCount = 1 then
|
|
Result := CompareField(TField(Fields.First), KeyValues)
|
|
else begin
|
|
Result := True;
|
|
for I := 0 to FieldCount - 1 do
|
|
Result := Result and CompareField(TField(Fields[I]), KeyValues[I]);
|
|
end;
|
|
end;
|
|
|
|
var
|
|
Bookmark: TBookmark;
|
|
begin
|
|
Result := False;
|
|
with DataSet do begin
|
|
CheckBrowseMode;
|
|
if BOF and EOF then Exit;
|
|
end;
|
|
Fields := TList.Create;
|
|
try
|
|
DataSet.GetFieldList(Fields, KeyFields);
|
|
FieldCount := Fields.Count;
|
|
|
|
if SearchOrigin = rsdAll then
|
|
begin
|
|
Result := CompareRecord;
|
|
if Result then Exit;
|
|
end;
|
|
|
|
DataSet.DisableControls;
|
|
try
|
|
Bookmark := DataSet.GetBookmark;
|
|
try
|
|
if SearchOrigin in [rsdAll, rsdForward] then
|
|
begin
|
|
if SearchOrigin = rsdAll then
|
|
DataSet.First;
|
|
while not DataSet.EOF do
|
|
begin
|
|
Result := CompareRecord;
|
|
if Result then Break;
|
|
DataSet.Next;
|
|
end;
|
|
end
|
|
else
|
|
if SearchOrigin = rsdBackward then
|
|
begin
|
|
//DataSet.Last;
|
|
while not DataSet.BOF do
|
|
begin
|
|
Result := CompareRecord;
|
|
if Result then Break;
|
|
DataSet.Prior;
|
|
end;
|
|
end;
|
|
|
|
finally
|
|
{$IFDEF NoAutomatedBookmark}
|
|
if not Result and DataSet.BookmarkValid(PChar(Bookmark)) then
|
|
{$ELSE}
|
|
if not Result and DataSet.BookmarkValid(Bookmark) then
|
|
{$ENDIF}
|
|
DataSet.GotoBookmark(Bookmark);
|
|
end;
|
|
finally
|
|
DataSet.FreeBookmark(Bookmark);
|
|
DataSet.EnableControls;
|
|
end;
|
|
except
|
|
{ finally
|
|
Fields.Free;}
|
|
end;
|
|
Fields.Free;
|
|
end;
|
|
|
|
procedure SaveFields(DataSet: TDataSet; IniFile: TIniFile);
|
|
begin
|
|
InternalSaveFields(DataSet, IniFile, DataSetSectionName(DataSet));
|
|
end;
|
|
|
|
procedure RestoreFields(DataSet: TDataSet; IniFile: TIniFile;
|
|
RestoreVisible: Boolean);
|
|
begin
|
|
InternalRestoreFields(DataSet, IniFile, DataSetSectionName(DataSet),
|
|
RestoreVisible);
|
|
end;
|
|
|
|
procedure SaveFieldsReg(DataSet: TDataSet; IniFile: TRegIniFile);
|
|
begin
|
|
InternalSaveFields(DataSet, IniFile, DataSetSectionName(DataSet));
|
|
end;
|
|
|
|
procedure RestoreFieldsReg(DataSet: TDataSet; IniFile: TRegIniFile;
|
|
RestoreVisible: Boolean);
|
|
begin
|
|
InternalRestoreFields(DataSet, IniFile, DataSetSectionName(DataSet),
|
|
RestoreVisible);
|
|
end;
|
|
|
|
{ DataSetSortedSearch. Navigate on sorted DataSet routine. }
|
|
|
|
function DataSetSortedSearch(DataSet: TDataSet; const Value,
|
|
FieldName: string; CaseInsensitive: Boolean): Boolean;
|
|
var
|
|
L, H, I: Longint;
|
|
CurrentPos: Longint;
|
|
CurrentValue: string;
|
|
BookMk: TBookmark;
|
|
Field: TField;
|
|
|
|
function UpStr(const Value: string): string;
|
|
begin
|
|
if CaseInsensitive then Result := AnsiUpperCase(Value)
|
|
else Result := Value;
|
|
end;
|
|
|
|
function GetCurrentStr: string;
|
|
begin
|
|
Result := Field.AsString;
|
|
if Length(Result) > Length(Value) then
|
|
SetLength(Result, Length(Value));
|
|
Result := UpStr(Result);
|
|
end;
|
|
|
|
begin
|
|
Result := False;
|
|
if DataSet = nil then Exit;
|
|
Field := DataSet.FindField(FieldName);
|
|
if Field = nil then Exit;
|
|
if Field.DataType = ftString then begin
|
|
DataSet.DisableControls;
|
|
BookMk := DataSet.GetBookmark;
|
|
try
|
|
L := 0;
|
|
DataSet.First;
|
|
CurrentPos := 0;
|
|
H := DataSet.RecordCount - 1;
|
|
if Value <> '' then begin
|
|
while L <= H do begin
|
|
I := (L + H) shr 1;
|
|
if I <> CurrentPos then DataSet.MoveBy(I - CurrentPos);
|
|
CurrentPos := I;
|
|
CurrentValue := GetCurrentStr;
|
|
if (UpStr(Value) > CurrentValue) then
|
|
L := I + 1
|
|
else begin
|
|
H := I - 1;
|
|
if (UpStr(Value) = CurrentValue) then Result := True;
|
|
end;
|
|
end; { while }
|
|
if Result then begin
|
|
if (L <> CurrentPos) then DataSet.MoveBy(L - CurrentPos);
|
|
while (L < DataSet.RecordCount) and
|
|
(UpStr(Value) <> GetCurrentStr) do
|
|
begin
|
|
Inc(L);
|
|
DataSet.MoveBy(1);
|
|
end;
|
|
end;
|
|
end
|
|
else Result := True;
|
|
if not Result then SetToBookmark(DataSet, BookMk);
|
|
finally
|
|
DataSet.FreeBookmark(BookMk);
|
|
DataSet.EnableControls;
|
|
end;
|
|
end
|
|
else
|
|
DatabaseErrorFmt(SFieldTypeMismatch, [Field.DisplayName]);
|
|
end;
|
|
|
|
{ Save and restore DataSet Fields layout }
|
|
|
|
function DataSetSectionName(DataSet: TDataSet): string;
|
|
begin
|
|
with DataSet do
|
|
if (Owner <> nil) and (Owner is TCustomForm) then
|
|
Result := GetDefaultSection(Owner as TCustomForm)
|
|
else Result := Name;
|
|
end;
|
|
|
|
function CheckSection(DataSet: TDataSet; const Section: string): string;
|
|
begin
|
|
Result := Section;
|
|
if Result = '' then Result := DataSetSectionName(DataSet);
|
|
end;
|
|
|
|
procedure InternalSaveFields(DataSet: TDataSet; IniFile: TObject;
|
|
const Section: string);
|
|
var
|
|
I: Integer;
|
|
begin
|
|
with DataSet do begin
|
|
for I := 0 to FieldCount - 1 do begin
|
|
IniWriteString(IniFile, CheckSection(DataSet, Section),
|
|
Name + Fields[I].FieldName,
|
|
Format('%d,%d,%d', [Fields[I].Index, Fields[I].DisplayWidth,
|
|
Integer(Fields[I].Visible)]));
|
|
end;
|
|
end;
|
|
end;
|
|
|
|
procedure InternalRestoreFields(DataSet: TDataSet; IniFile: TObject;
|
|
const Section: string; RestoreVisible: Boolean);
|
|
type
|
|
TFieldInfo = packed record
|
|
Field: TField;
|
|
EndIndex: Integer;
|
|
end;
|
|
PFieldArray = ^TFieldArray;
|
|
TFieldArray = array[0..(65528 div SizeOf(TFieldInfo)) - 1] of TFieldInfo;
|
|
const
|
|
Delims = [' ',','];
|
|
var
|
|
I, J: Integer;
|
|
S: string;
|
|
FieldArray: PFieldArray;
|
|
begin
|
|
{ with DataSet do begin
|
|
FieldArray := AllocMem(FieldCount * SizeOf(TFieldInfo));
|
|
try
|
|
for I := 0 to FieldCount - 1 do begin
|
|
S := IniReadString(IniFile, CheckSection(DataSet, Section),
|
|
Name + Fields[I].FieldName, '');
|
|
FieldArray^[I].Field := Fields[I];
|
|
FieldArray^[I].EndIndex := Fields[I].Index;
|
|
if S <> '' then begin
|
|
FieldArray^[I].EndIndex := StrToIntDef(ExtractWord(1, S, Delims),
|
|
FieldArray^[I].EndIndex);
|
|
Fields[I].DisplayWidth := StrToIntDef(ExtractWord(2, S, Delims),
|
|
Fields[I].DisplayWidth);
|
|
if RestoreVisible then
|
|
Fields[I].Visible := Boolean(StrToIntDef(ExtractWord(3, S, Delims),
|
|
Integer(Fields[I].Visible)));
|
|
end;
|
|
end;
|
|
for I := 0 to FieldCount - 1 do begin
|
|
for J := 0 to FieldCount - 1 do begin
|
|
if FieldArray^[J].EndIndex = I then begin
|
|
FieldArray^[J].Field.Index := FieldArray^[J].EndIndex;
|
|
Break;
|
|
end;
|
|
end;
|
|
end;
|
|
finally
|
|
FreeMemo(Pointer(FieldArray));
|
|
end;
|
|
end;}
|
|
end;
|
|
|
|
(*
|
|
procedure InternalSaveFields(DataSet: TDataSet; IniFile: TIniFile;
|
|
const Section: string);
|
|
var
|
|
I: Integer;
|
|
begin
|
|
with DataSet do
|
|
begin
|
|
for I := 0 to FieldCount - 1 do
|
|
begin
|
|
IniWriteString(IniFile, CheckSection(DataSet, Section),
|
|
Name + Fields[I].FieldName,
|
|
Format('%d,%d,%d', [Fields[I].Index, Fields[I].DisplayWidth,
|
|
Integer(Fields[I].Visible)]));
|
|
end;
|
|
end;
|
|
end;
|
|
|
|
procedure InternalRestoreFields(DataSet: TDataSet; IniFile: TObject;
|
|
const Section: string; RestoreVisible: Boolean);
|
|
type
|
|
TFieldInfo = packed record
|
|
Field: TField;
|
|
EndIndex: Integer;
|
|
end;
|
|
PFieldArray = ^TFieldArray;
|
|
TFieldArray = array[0..(65528 div SizeOf(TFieldInfo)) - 1] of TFieldInfo;
|
|
const
|
|
Delims = [' ',','];
|
|
var
|
|
I, J: Integer;
|
|
S: string;
|
|
FieldArray: PFieldArray;
|
|
begin
|
|
{ with DataSet do
|
|
begin
|
|
FieldArray := AllocMemo(FieldCount * SizeOf(TFieldInfo));
|
|
try
|
|
for I := 0 to FieldCount - 1 do begin
|
|
S := IniReadString(IniFile, CheckSection(DataSet, Section),
|
|
Name + Fields[I].FieldName, '');
|
|
FieldArray^[I].Field := Fields[I];
|
|
FieldArray^[I].EndIndex := Fields[I].Index;
|
|
if S <> '' then begin
|
|
FieldArray^[I].EndIndex := StrToIntDef(ExtractWord(1, S, Delims),
|
|
FieldArray^[I].EndIndex);
|
|
Fields[I].DisplayWidth := StrToIntDef(ExtractWord(2, S, Delims),
|
|
Fields[I].DisplayWidth);
|
|
if RestoreVisible then
|
|
Fields[I].Visible := Boolean(StrToIntDef(ExtractWord(3, S, Delims),
|
|
Integer(Fields[I].Visible)));
|
|
end;
|
|
end;
|
|
for I := 0 to FieldCount - 1 do begin
|
|
for J := 0 to FieldCount - 1 do begin
|
|
if FieldArray^[J].EndIndex = I then begin
|
|
FieldArray^[J].Field.Index := FieldArray^[J].EndIndex;
|
|
Break;
|
|
end;
|
|
end;
|
|
end;
|
|
finally
|
|
FreeMemo(Pointer(FieldArray));
|
|
end;
|
|
end;
|
|
}
|
|
end;
|
|
*)
|
|
|
|
{
|
|
procedure SaveFields(DataSet: TDataSet; IniFile: TIniFile);
|
|
begin
|
|
InternalSaveFields(DataSet, IniFile, DataSetSectionName(DataSet));
|
|
end;
|
|
|
|
procedure RestoreFields(DataSet: TDataSet; IniFile: TIniFile;
|
|
RestoreVisible: Boolean);
|
|
begin
|
|
InternalRestoreFields(DataSet, IniFile, DataSetSectionName(DataSet),
|
|
RestoreVisible);
|
|
end;
|
|
}
|
|
function IsDataSetEmpty(DataSet: TDataSet): Boolean;
|
|
begin
|
|
with DataSet do Result := (not Active) or (Eof and Bof);
|
|
end;
|
|
|
|
{ SQL expressions }
|
|
|
|
function DateToSQL(Value: TDateTime): string;
|
|
begin
|
|
Result := IntToStr(Trunc(Value));
|
|
end;
|
|
|
|
function FormatSQLDateRange(Date1, Date2: TDateTime;
|
|
const FieldName: string): string;
|
|
begin
|
|
Result := TrueExpr;
|
|
if (Date1 = Date2) and (Date1 <> NullDate) then
|
|
begin
|
|
Result := Format('%s = %s', [FieldName, FormatDateTime(ServerDateFmt,
|
|
Date1)]);
|
|
end
|
|
else
|
|
if (Date1 <> NullDate) or (Date2 <> NullDate) then
|
|
begin
|
|
if Date1 = NullDate then
|
|
Result := Format('%s < %s', [FieldName,
|
|
FormatDateTime(ServerDateFmt, IncDay(Date2, 1))])
|
|
else if Date2 = NullDate then
|
|
Result := Format('%s > %s', [FieldName,
|
|
FormatDateTime(ServerDateFmt, IncDay(Date1, -1))])
|
|
else
|
|
Result := Format('(%s < %s) AND (%s > %s)',
|
|
[FieldName, FormatDateTime(ServerDateFmt, IncDay(Date2, 1)),
|
|
FieldName, FormatDateTime(ServerDateFmt, IncDay(Date1, -1))]);
|
|
end;
|
|
end;
|
|
|
|
function FormatSQLDateRangeEx(Date1, Date2: TDateTime;
|
|
const FieldName: string): string;
|
|
begin
|
|
Result := TrueExpr;
|
|
if (Date1 <> NullDate) or (Date2 <> NullDate) then begin
|
|
if Date1 = NullDate then
|
|
Result := Format('%s < %s', [FieldName,
|
|
FormatDateTime(ServerDateFmt, IncDay(Date2, 1))])
|
|
else if Date2 = NullDate then
|
|
Result := Format('%s >= %s', [FieldName,
|
|
FormatDateTime(ServerDateFmt, Date1)])
|
|
else
|
|
Result := Format('(%s < %s) AND (%s >= %s)',
|
|
[FieldName, FormatDateTime(ServerDateFmt, IncDay(Date2, 1)),
|
|
FieldName, FormatDateTime(ServerDateFmt, Date1)]);
|
|
end;
|
|
end;
|
|
|
|
function FormatSQLNumericRange(const FieldName: string;
|
|
LowValue, HighValue, LowEmpty, HighEmpty: Double; Inclusive: Boolean): string;
|
|
const
|
|
Operators: array[Boolean, 1..2] of string[2] = (('>', '<'), ('>=', '<='));
|
|
begin
|
|
Result := TrueExpr;
|
|
if (LowValue = HighValue) and (LowValue <> LowEmpty) then begin
|
|
Result := Format('%s = %g', [FieldName, LowValue]);
|
|
end
|
|
else if (LowValue <> LowEmpty) or (HighValue <> HighEmpty) then begin
|
|
if LowValue = LowEmpty then
|
|
Result := Format('%s %s %g', [FieldName, Operators[Inclusive, 2], HighValue])
|
|
else if HighValue = HighEmpty then
|
|
Result := Format('%s %s %g', [FieldName, Operators[Inclusive, 1], LowValue])
|
|
else begin
|
|
Result := Format('(%s %s %g) AND (%s %s %g)',
|
|
[FieldName, Operators[Inclusive, 2], HighValue,
|
|
FieldName, Operators[Inclusive, 1], LowValue]);
|
|
end;
|
|
end;
|
|
end;
|
|
|
|
function StrMaskSQL(const Value: string): string;
|
|
begin
|
|
if (Pos('*', Value) = 0) and (Pos('?', Value) = 0) and (Value <> '') then
|
|
Result := '*' + Value + '*'
|
|
else Result := Value;
|
|
end;
|
|
|
|
function FormatSQLCondition(const FieldName, AOperator, Value: string;
|
|
FieldType: TFieldType; Exact: Boolean): string;
|
|
var
|
|
EmptyValue: Boolean;
|
|
FieldValue: string;
|
|
DateValue: TDateTime;
|
|
LogicOperator: string;
|
|
begin
|
|
FieldValue := '';
|
|
DateValue := NullDate;
|
|
Exact := Exact or not (FieldType in
|
|
[ftString, ftDate, ftTime, ftDateTime]);
|
|
if FieldType in [ftDate, ftTime, ftDateTime] then
|
|
begin
|
|
DateValue := StrToDateDef(Value, NullDate);
|
|
EmptyValue := (DateValue = NullDate);
|
|
FieldValue := FormatDateTime(ServerDateFmt, DateValue);
|
|
end
|
|
else begin
|
|
FieldValue := Value;
|
|
EmptyValue := FieldValue = '';
|
|
if not (Exact or EmptyValue) then
|
|
FieldValue := ReplaceStr(ReplaceStr(StrMaskSQL(FieldValue),
|
|
'*', '%'), '?', '_');
|
|
if FieldType = ftString then FieldValue := '''' + FieldValue + '''';
|
|
end;
|
|
LogicOperator := AOperator;
|
|
if LogicOperator = '' then begin
|
|
if Exact then LogicOperator := '='
|
|
else begin
|
|
if FieldType = ftString then LogicOperator := 'LIKE'
|
|
else LogicOperator := '>=';
|
|
end;
|
|
end;
|
|
if EmptyValue then Result := TrueExpr
|
|
else if (FieldType = ftDateTime) and Exact then begin
|
|
DateValue := IncDay(DateValue, 1);
|
|
Result := Format('(%s >= %s) and (%s < %s)', [FieldName, FieldValue,
|
|
FieldName, FormatDateTime(ServerDateFmt, DateValue)]);
|
|
end
|
|
else Result := Format('%s %s %s', [FieldName, LogicOperator, FieldValue]);
|
|
end;
|
|
|
|
function FormatAnsiSQLCondition(const FieldName, AOperator, Value: string;
|
|
FieldType: TFieldType; Exact: Boolean): string;
|
|
var
|
|
S, Esc: string;
|
|
begin
|
|
Esc := '';
|
|
if not Exact and (FieldType = ftString) then begin
|
|
S := ReplaceStr(ReplaceStr(ReplaceStr(Value, '/', '//'),
|
|
'_', '/_'), '%', '/%');
|
|
if S <> Value then Esc := ' ESCAPE''/''';
|
|
end
|
|
else S := Value;
|
|
Result := FormatSQLCondition(FieldName, AOperator, S, FieldType, Exact) + Esc;
|
|
end;
|
|
|
|
procedure CheckRequiredField(Field: TField);
|
|
begin
|
|
with Field do
|
|
if not ReadOnly and not Calculated and IsNull then
|
|
begin
|
|
FocusControl;
|
|
DatabaseErrorFmt(SFieldRequired, [DisplayName]);
|
|
end;
|
|
end;
|
|
|
|
procedure CheckRequiredFields(const Fields: array of TField);
|
|
var
|
|
I: Integer;
|
|
begin
|
|
for I := Low(Fields) to High(Fields) do
|
|
CheckRequiredField(Fields[I]);
|
|
end;
|
|
|
|
procedure AssignRecord(Source, Dest: TDataSet; ByName: Boolean);
|
|
var
|
|
I: Integer;
|
|
F, FSrc: TField;
|
|
begin
|
|
if not (Dest.State in dsEditModes) then _DBError(SNotEditing);
|
|
if ByName then begin
|
|
for I := 0 to Source.FieldCount - 1 do begin
|
|
F := Dest.FindField(Source.Fields[I].FieldName);
|
|
if F <> nil then begin
|
|
if (F.DataType = Source.Fields[I].DataType) and
|
|
(F.DataSize = Source.Fields[I].DataSize) then
|
|
F.Assign(Source.Fields[I])
|
|
else F.AsString := Source.Fields[I].AsString;
|
|
end;
|
|
end;
|
|
end
|
|
else begin
|
|
for I := 0 to Min(Source.FieldDefs.Count - 1, Dest.FieldDefs.Count - 1) do
|
|
begin
|
|
F := Dest.FindField(Dest.FieldDefs[I].Name);
|
|
FSrc := Source.FindField(Source.FieldDefs[I].Name);
|
|
if (F <> nil) and (FSrc <> nil) then begin
|
|
if F.DataType = FSrc.DataType then F.Assign(FSrc)
|
|
else F.AsString := FSrc.AsString;
|
|
end;
|
|
end;
|
|
end;
|
|
end;
|
|
|
|
function ExtractFieldName(const Fields: string; var Pos: Integer): string;
|
|
var
|
|
I: Integer;
|
|
begin
|
|
I := Pos;
|
|
while (I <= Length(Fields)) and (Fields[I] <> ';') do Inc(I);
|
|
Result := Trim(Copy(Fields, Pos, I - Pos));
|
|
if (I <= Length(Fields)) and (Fields[I] = ';') then Inc(I);
|
|
Pos := I;
|
|
end;
|
|
|
|
procedure FillValueForField(const Field: TField; Value: Variant);
|
|
var
|
|
DS:TDataSet;
|
|
P:TBookmark;
|
|
begin
|
|
DS:=Field.DataSet;
|
|
DS.DisableControls;
|
|
P:=DS.GetBookmark;
|
|
try
|
|
DS.First;
|
|
while not DS.EOF do
|
|
begin
|
|
DS.Edit;
|
|
Field.Value:=Value;
|
|
DS.Post;
|
|
DS.Next;
|
|
end;
|
|
finally
|
|
DS.GotoBookmark(P);
|
|
DS.FreeBookmark(P);
|
|
DS.EnableControls;
|
|
end;
|
|
end;
|
|
|
|
function FieldInArray(Field: TField; Arr: array of const): boolean;
|
|
var
|
|
i: integer;
|
|
CI: boolean;
|
|
begin
|
|
Result := False;
|
|
for i := Low(Arr) to High(Arr) do
|
|
begin
|
|
with Arr[i] do
|
|
begin
|
|
case VType of
|
|
vtInteger: Result := Field.Index = VInteger;
|
|
vtPChar:
|
|
Result :=
|
|
AnsiUpperCase(Field.FieldName) = AnsiUpperCase(vPChar);
|
|
vtString,
|
|
vtAnsiString:
|
|
Result :=UpperCase(Field.FieldName) = UpperCase(string(VAnsiString));
|
|
end
|
|
end;
|
|
if Result then
|
|
exit;
|
|
end;
|
|
end;
|
|
|
|
procedure CloneRecord(DataSet: TDataSet; IgnoreFields: array of const);
|
|
var
|
|
Rec:Array of variant;
|
|
i:integer;
|
|
begin
|
|
if not DataSet.Active then exit;
|
|
i:=DataSet.FieldCount;
|
|
SetLength(Rec, DataSet.FieldCount);
|
|
|
|
for i:=0 to DataSet.FieldCount-1 do
|
|
begin
|
|
if (DataSet.Fields[i].FieldKind in [fkData]) and (not DataSet.Fields[i].IsBlob)
|
|
and (not FieldInArray(DataSet.Fields[i], IgnoreFields)) then
|
|
begin
|
|
Rec[i] := DataSet.Fields[i].Value;
|
|
end;
|
|
end;
|
|
|
|
DataSet.Append;
|
|
|
|
for i:=0 to DataSet.FieldCount-1 do
|
|
begin
|
|
if (DataSet.Fields[i].FieldKind in [fkData]) and (not DataSet.Fields[i].IsBlob) and (not DataSet.Fields[i].ReadOnly)
|
|
and (not FieldInArray(DataSet.Fields[i], IgnoreFields)) then
|
|
begin
|
|
DataSet.Fields[i].Value:=Rec[i];
|
|
Rec[i]:=Null;
|
|
end;
|
|
end;
|
|
end;
|
|
|
|
function FieldValueToStrings(const DataSet: TDataSet; const FieldName: string;
|
|
List: TStrings): TStrings;
|
|
var
|
|
Field: TField;
|
|
P: TBookMark;
|
|
begin
|
|
Result:=List;
|
|
if not Assigned(Result) then
|
|
Result:=TStringList.Create;
|
|
if not Assigned(DataSet) then exit;
|
|
Field:=DataSet.FindField(FieldName);
|
|
if not Assigned(Field) then exit;
|
|
|
|
DataSet.DisableControls;
|
|
Result.BeginUpdate;
|
|
P:=DataSet.GetBookmark;
|
|
try
|
|
DataSet.First;
|
|
while not DataSet.EOF do
|
|
begin
|
|
if Result.IndexOf(Field.AsString) < 0 then
|
|
Result.Add(Field.AsString);
|
|
DataSet.Next;
|
|
end;
|
|
finally
|
|
DataSet.GotoBookmark(P);
|
|
DataSet.FreeBookmark(P);
|
|
Result.EndUpdate;
|
|
DataSet.EnableControls;
|
|
end;
|
|
end;
|
|
|
|
procedure AddSQLExpressionAnd(var MacroStr: string; const MacroWhere: string);
|
|
begin
|
|
if MacroWhere <> '' then
|
|
begin
|
|
if MacroStr<>'' then MacroStr:=MacroStr + ' and ';
|
|
MacroStr:=MacroStr + '('+MacroWhere+')';
|
|
end;
|
|
end;
|
|
|
|
procedure AddSQLExpressionAnd(var MacroStr: string; const MacroWhere: string;
|
|
Params: array of const);
|
|
begin
|
|
AddSQLExpressionAnd(MacroStr, Format(MacroWhere, Params));
|
|
end;
|
|
|
|
procedure AddSQLExpressionOr(var MacroStr: string; const MacroWhere: string);
|
|
begin
|
|
if MacroWhere<>'' then
|
|
begin
|
|
if MacroStr<>'' then MacroStr:=MacroStr + ' or ';
|
|
MacroStr:=MacroStr + '('+MacroWhere+')';
|
|
end;
|
|
end;
|
|
|
|
end.
|