Chip 2001 December/Chip_2001-12_cd1.bin/zkuste/delphi/kolekce/d3456/ALEXSOFT.ZIP/DBTools.pas

Pascal/Delphi Source File | 2001-09-29 | 21.4 KB | 627 lines

(*////////////////////////////////////////////////////////////////////////////
//   Part of AlexSoft VCL/DLL Library.                                      //
//   All rights reserved. (c) Copyright 1998.                               //
//   Created by: Alex Rabichooc                                             //
//**************************************************************************//
//  Users of this unit must accept this disclaimer of warranty:             //
//    "This unit is supplied as is. The author disclaims all warranties,    //
//    expressed or implied, including, without limitation, the warranties   //
//    of merchantability and of fitness for any purpose.                    //
//    The author assumes no liability for damages, direct or                //
//    consequential, which may result from the use of this unit."           //
//                                                                          //
//  This Unit is donated to the public as public domain.                    //
//                                                                          //
//  This Unit can be freely used and distributed in commercial and          //
//  private environments provided this notice is not modified in any way.   //
//                                                                          //
//  If you do find this Unit handy and you feel guilty for using such a     //
//  great product without paying someone - sorry :-)                        //
//                                                                          //
//  Please forward any comments or suggestions to Alex Rabichooc at:        //
//                                                                          //
//  [e-mail] or [e-mail]                         //
/////////////////////////////////////////////////////////////////////////////*)

unit dbtools;

interface
uses db, Classes, Controls, dialogs, SysUtils, dbGrids, DBForms, dbTables, DBSearch;

procedure DoEditButtonClick(Field: TField; AOwner: TComponent);
function ShowDate(AField: TField; Sender: TWinControl):Integer;
function ShowSpr(AField: TField; AOwner: TComponent): Integer;
function ShowMemo(AField: TField; AOwner: TComponent):Integer;
function ShowImage(AField: TField; AOwner: TComponent):Integer;
function ValidData(AField: TField): Boolean;
procedure GetLookUpText(Sender: TField; var Text: String; DisplayText: Boolean);
procedure SetLookUpText(Sender: TField; const Text: String);
function IsLookUpField(AField: TField): Boolean;
procedure SetFieldAttributes(Field: TField);
function DBSearch(DataSet: TDataSet; AFields: TList; AField: TField;
                                                  AOwner: TComponent; AKind: TSearchKind = skNormal): boolean;
function InitDBForm(DataSet: TDataSet; Field: TField; AOwner: TComponent): Integer;
procedure ReplaceField(AField: TField);
function GetMasterSource(DataSet: TDataSet): TDataSource;
procedure GetReplaceParams(AField: TField;
                           var KeyField, LKeyField: TField;
                           var LDataSet: TDataSet);
procedure BindParams(DataSet: TDataSet; Query: TQuery);

type

TSender = class
public
    class procedure GetFieldText(Sender: TField; var Text: String; DisplayText: Boolean);
    class procedure SetFieldText(Sender: TField; const Text: String);
    class procedure ValidateData(Sender: TField);
end;

TSenderClass = class of TSender;

implementation
uses Windows, Graphics, StdUtils, FrmDSrce, dbConsts,
     dbBoxGrd, Mask, Forms, grids, fmClndr, dbClient, dbPanel, fmSearch,
     MemoEdit, {$IFDEF PROFI}ImagEdit{$ELSE}ImgEdt{$ENDIF}
     {$IFNDEF VER120}
     {$IFNDEF VER110},ADOdb
     {$ENDIF}
     {$ENDIF}
     {$IFDEF VER140},Variants, MaskUtils
     {$ENDIF};

procedure BindParams(DataSet: TDataSet; Query: TQuery);
var
  I: Integer;
  Old: Boolean;
  Param: TParam;
  PName: string;
  Field: TField;
  Value: Variant;
begin
  if (DataSet = nil) or (Query = nil) then
    Exit;
  with Query do
  begin
    for I := 0 to Params.Count - 1 do
    begin
      Param := Params[I];
      PName := Param.Name;
      Old := CompareText(Copy(PName, 1, 4), 'OLD_') = 0;
      if Old then System.Delete(PName, 1, 4);
      Field := DataSet.FindField(PName);
      if not Assigned(Field) then Continue;
      if Old then Param.AssignFieldValue(Field, Field.OldValue) else
      begin
        Value := Field.NewValue;
        if VarIsEmpty(Value) then Value := Field.OldValue;
        Param.AssignFieldValue(Field, Value);
      end;
    end;
  end;
end;

function DBSearch(DataSet: TDataSet; AFields: TList; AField: TField;
                    AOwner: TComponent; AKind: TSearchKind = skNormal): boolean;
var Frm: TForm;
begin
   Result := False;
   if DataSet = nil then
     exit;
   Frm := TSearchForm.CreateWithDataSet(AOwner, DataSet, AFields, AField);
   if Frm.HandleAllocated then
   try
     if AKind <> skNormal then
     with Frm as TSearchForm do
     begin
        ckExtendedSearch.Checked := True;
        if AKind = skContext then
           ckContext.Checked := True;
     end;
     Result := Frm.ShowModal = mrOK;
   finally
     Frm.Free;
   end;
end;

function InitDBForm(DataSet: TDataSet; Field: TField; AOwner: TComponent): Integer;
const MinWidth = 340;
var AWidth, AHeight: Integer;
    Form: TDBForm;
    FormClass: TDBFormClass;
    FieldP: ^TField;

    procedure ChangePanelBounds;
    var ALeft, ATop: Integer;
    begin
      with Form as TDefaultForm do
      if (AWidth <> ClientWidth) or (AHeight <> ClientHeight) then
      begin
         ALeft := Left - (AWidth-Width) div 2;
         ATop := Top-(AHeight-Height) div 2;
         if ALeft < 0 then ALeft := 0;
         if ATop < 0 then ATop := 0;
         SetBounds(ALeft, ATop, AWidth, AHeight);
      end;
    end;

begin
   try
      if Screen.Cursor = crDefault then
          Screen.Cursor := crHourGlass;

      FormClass := GetFormClass(DataSet);
      if FormClass = nil then
      begin
         FormClass := TDefaultForm;
      end;
      Form := FindCreateForm(FormClass, GetFormCaption(DataSet), AOwner) as TDBForm;

      if Form is TDBForm then
      with Form as TDBForm do
      begin
         FieldP := @ParentField;
         FieldP^ := Field;
      end;

      if Form is TDefaultForm then
      with Form as TDefaultForm do
      if DataSource.DataSet = nil then
      begin
         //DbPanel.Box.CreateMode := cmManual;
         DataSource.DataSet := DataSet;
         if GetMasterSource(DataSet) <> nil then
            DBPanel.Orientation := orHorizontal;
         Application.ProcessMessages;
         //SendMessage(DBPanel.Handle, CN_STYLECHANGED, 0, 0);
         AWidth := DbPanel.ActualWidth+Width-ClientWidth;
         if AWidth > Screen.Width then AWidth := Screen.Width;
         if AWidth < MinWidth then AWidth := MinWidth;
         if DbPanel.Box.Visible then
         begin
            Width := AWidth;
            DbPanel.Box.RefreshFields;
            DbPanel.StoreFields := True;
            DbPanel.BoxHeight := DbPanel.Box.ActualHeight + DbPanel.Box.OriginY;
            AWidth := DbPanel.ActualWidth+Width-ClientWidth;
         end;
         AHeight := DbPanel.ActualHeight+paTop.Height+paBottom.Height+
                                                         Height-ClientHeight;
         if AHeight > Screen.Height then
           AHeight := Screen.Height;
         //if DbPanel.Box.Visible and DbPanel.Grid.Visible then
                     Inc(AHeight, 3);
         if not DbPanel.Box.Visible then
            DbPanel.PanelStyle := psGrid;
         ChangePanelBounds;
      end;
      if IsModalForm(DataSet) or (GetFormCaption(DataSet) = '') then
         Result := Form.ShowModal
        else
        begin
           Form.Show;
           Result := 0;
        end;
   finally
      Screen.Cursor := crDefault;
   end;
end;

procedure DoEditButtonClick(Field: TField; AOwner: TComponent);
begin
   if Field <> nil then
   with Field do
   begin
      case DataType of
        ftMemo, ftFmtMemo:
           ShowMemo(Field, AOwner);
        ftGraphic, ftTypedBinary, ftBlob:
           ShowImage(Field, AOwner);
        {$IFNDEF VER110}
        ftDataSet:
           InitDBForm((Field as TDataSetField).NestedDataSet, nil, AOwner);
        {$ENDIF}
        ftDate, ftDateTime:
           if AOwner is TWinControl then
               ShowDate(Field, AOwner as TWinControl)
              else
               ShowSpr(Field, AOwner);
        else
         ShowSpr(Field, AOwner);
      end;
   end;
end;

function ShowDate(AField: TField; Sender: TWinControl):Integer;
begin
   Result := ord(CreateCalendar(AField, Sender));
end;

procedure GetReplaceParams(AField: TField;
                           var KeyField, LKeyField: TField;
                           var LDataSet: TDataSet);
var i: Integer;
begin
   LDataSet := nil;
   LKeyField := nil;
   KeyField := nil;
   if AField <> nil then
   begin
      if IsLookUpField(AField) then
      begin
         KeyField := AField.DataSet.FindField(AField.KeyFields);
         LDataSet := AField.LookupDataSet;
         if LDataSet <> nil then
            LKeyField := LDataSet.FindField(AField.LookUpKeyFields);
      end
       else
       for i := 0 to AField.DataSet.FieldCount-1 do
           with AField.DataSet.Fields[i] do
             if UpperCase(KeyFields) = UpperCase(AField.FieldName) then
             begin
                KeyField := AField.DataSet.FindField(KeyFields);
                LDataSet := LookupDataSet;
                if LDataSet <> nil then
                  LKeyField := LDataSet.FindField(LookUpKeyFields);
                break;
             end;
   end;
end;

procedure ReplaceField(AField: TField);
var KeyField, LKeyField, ResultField: TField;
    LDataSet: TDataSet;
    AValue: Variant;
begin
   GetReplaceParams(AField, KeyField, LKeyField, LDataSet);
   if (LDataSet <> nil) and (LKeyField <> nil) and (KeyField <> nil) and
                       KeyField.CanModify and KeyField.DataSet.Active then
   begin
      with AField.DataSet do
      begin
         AValue := LKeyField.Value;
         if not (AField.DataSet.State in [dsEdit, dsInsert]) then
            if IsEmpty then
               Insert
              else
               Edit;
         KeyField.Value := AValue;
         if AField.FieldKind = fkLookUp then
         begin
            ResultField := LDataSet.FindField(AField.LookupResultField);
            if ResultField <> nil then
              AField.Value := ResultField.Value;
         end;
      end;
   end;
end;

function ShowSpr(AField: TField; AOwner: TComponent): Integer;
var KeyField, LKeyField: TField;
    LDataSet: TDataSet;
begin
   try
      Screen.Cursor := crHourGlass;
      Result := -1;
      GetReplaceParams(AField, KeyField, LKeyField, LDataSet);
      if (LDataSet <> nil) and (LKeyField <> nil) and (KeyField <> nil) then
      begin
         if AOwner is TInplaceEdit then
            AOwner := (AOwner as TInplaceEdit).Owner;
         Result := InitDBForm(LDataSet, AField, AOwner);
      end;
   finally
      Screen.Cursor := crDefault;
   end;
end;

function ShowMemo(AField: TField; AOwner: TComponent):Integer;
var Form: TForm;
begin
   Result := 0;
   if AField <> nil then
   begin
      Screen.Cursor := crHourGlass;
      try
        Form := TMemoEditor.CreateWithField(AOwner, AField);
      finally
        Screen.Cursor := crDefault;
      end;
      try
        Form.ShowModal;
        Result := 1;
      finally
        Form.Free;
      end;
   end;
end;

function ShowImage(AField: TField; AOwner: TComponent):Integer;
var Form: TForm;
begin
   Result := 0;
   if AField <> nil then
   begin
      with AField.DataSet do
        if (State = dsInsert) and not Modified then
            Exit
           else
            CheckBrowseMode;
      Screen.Cursor := crHourGlass;
      try
        Form := TImageEditor.CreateWithField(AOwner, AField);
      finally
        Screen.Cursor := crDefault;
      end;
      try
        Form.ShowModal;
        Result := 1;
      finally
        Form.Free;
      end;
   end;
end;

function ValidData(AField: TField): Boolean;
var KeyField, LKeyField: TField;
    LDataSet: TDataSet;
    i: Integer;
begin
   Result := True;
   LDataSet := nil;
   LKeyField := nil;
   KeyField := nil;
   if (AField <> nil) and (AField.DataSet <> nil) and (AField.DataSet.State in [dsEdit, dsInsert]) then
   begin
      if AField.FieldKind = fkLookUp then
      begin
         KeyField := AField.DataSet.FindField(AField.KeyFields);
         LDataSet := AField.LookupDataSet;
         if LDataSet <> nil then
           LKeyField := LDataSet.FindField(AField.LookUpKeyFields);
      end
       else
       for i := 0 to AField.DataSet.FieldCount-1 do
           with AField.DataSet.Fields[i] do
             if UpperCase(KeyFields) = UpperCase(AField.FieldName) then
             begin
                KeyField := AField.DataSet.FindField(KeyFields);
                LDataSet := LookupDataSet;
                if LDataSet <> nil then
                  LKeyField := LDataSet.FindField(LookUpKeyFields);
                break;
             end;
      if (LDataSet <> nil) and (LKeyField <> nil) and
         (KeyField <> nil) and AField.DataSet.Active then
      begin
         Result := LDataSet.Locate(LKeyField.FieldName, KeyField.Value, []);
         if Result then
            for i := 0 to AField.DataSet.FieldCount-1 do
            with AField.DataSet.Fields[i] do
              if (UpperCase(KeyFields) = UpperCase(AField.FieldName)) and
                 (LookUpDataSet <> nil) and
                 (AField.DataSet.Fields[i]<> AField) then
                 Value :=
                     LookUpDataSet.Lookup(LookUpKeyFields, AField.Value, LookupResultField)
         end
   end;
end;

procedure GetLookUpText(Sender: TField; var Text: String; DisplayText: Boolean);
var Result: Variant;
    AField: TField;
begin
   AField := Sender.DataSet.FindField(Sender.KeyFields);
   if AField <> nil then
   begin
      Result := AField.Value;
      With Sender do
      if (LookUpDataSet <> nil) and LookUpDataSet.Active then
         Result := LookUpDataSet.Lookup(LookUpKeyFields, Result, LookUpResultField);
      Text := VarToStr(Result);
   end;
end;


procedure SetLookUpText(Sender: TField; const Text: String);
var Result: Variant;
    AField: TField;
begin
   AField := Sender.DataSet.FindField(Sender.KeyFields);
   if (AField <> nil) and
      (Sender.DataSet <> nil) and
      Sender.DataSet.Active then
   begin
      Result := Text;
      With Sender do
      if LookUpDataSet <> nil then
         Result := LookUpDataSet.Lookup(LookUpResultField, Result, LookUpKeyFields);
      AField.Value := Result;
   end;
end;

function IsLookUpField(AField: TField): Boolean;
begin
   with AField do
   Result :=
       (AField <> nil) and ((FieldKind = fkLookUp) or (LookUpDataSet <> nil));
end;

procedure SetFieldAttributes(Field: TField);
var AField, KeyField, LKeyField: TField;
    LDataSet: TDataSet;
    i: Integer;
begin
   if (Field <> nil) then
   begin
      if (Field.FieldKind = fkData) and
         not Assigned(Field.OnValidate) and
         {not (csLoading in Field.ComponentState) and}
         not (csDesigning in Field.ComponentState) then
      begin
         //******************************??????????????????
         LDataSet := nil;
         LKeyField := nil;
         KeyField := nil;
         for i := 0 to Field.DataSet.FieldCount-1 do
            with Field.DataSet.Fields[i] do
            if UpperCase(KeyFields) = UpperCase(Field.FieldName) then
            begin
              KeyField := Field.DataSet.FindField(KeyFields);
              LDataSet := LookupDataSet;
              if LDataSet <> nil then
                LKeyField := LDataSet.FindField(LookUpKeyFields);
              break;
            end;
         if (LDataSet <> nil) and (LKeyField <> nil) and
            (KeyField <> nil) and Field.DataSet.Active then
           //******************************??????????????????
             Field.OnValidate := TSenderClass.ValidateData;
      end;
      if (Field is TNumericField) then
      begin
         Field.DisplayWidth := Length((Field as TNumericField).DisplayFormat);
         if Field.DisplayWidth < Length((Field as TNumericField).EditFormat) then
            Field.DisplayWidth := Length((Field as TNumericField).EditFormat);
      end
       else
      if Field.EditMaskPtr = '' then
          Field.DisplayWidth := -1
         else
          Field.DisplayWidth := Length(FormatMaskText(Field.EditMaskPtr, ''));
      if (Field.FieldKind = fkData) and (Field.LookUpDataSet <> nil) then
      begin
         if not Assigned(Field.OnGetText) and
            not Assigned(Field.OnSetText) and
            {not (csLoading in Field.ComponentState) and}
            not (csDesigning in Field.ComponentState) then
         begin
            Field.OnGetText := TSenderClass.GetFieldText;
            Field.OnSetText := TSenderClass.SetFieldText;
         end;
         AField := Field.LookUpDataSet.FindField(Field.LookUpResultField);
         if AField <> nil then
         begin
            if Field.EditMaskPtr = '' then
                Field.EditMask := AField.EditMaskPtr;
            if (Field.DisplayWidth = Field.Size) or (Field.Size = 0) then
            begin
               Field.DisplayWidth := AField.DisplayWidth;
               Field.Alignment := AField.Alignment;
            end;
            if Field.EditMaskPtr <> '' then
               Field.DisplayWidth := Length(FormatMaskText(Field.EditMaskPtr, ''));
            if (AField is TNumericField) then
            begin
               Field.DisplayWidth := Length((AField as TNumericField).DisplayFormat);
               if Field.DisplayWidth < Length((AField as TNumericField).EditFormat) then
                  Field.DisplayWidth := Length((AField as TNumericField).EditFormat);
            end;
         end;
      end
       else
       if (@Field.OnGetText = @TSenderClass.GetFieldText) and
                         (@Field.OnSetText = @TSenderClass.SetFieldText) then
       begin
          Field.OnSetText := nil;
          Field.OnGetText := nil;
       end;
   end;
end;

function GetMasterSource(DataSet: TDataSet): TDataSource;
{$IFNDEF VER110}
var i: Integer;
{$ENDIF}
begin
   Result := nil;
   if DataSet <> nil then
   begin
      {$IFNDEF VER120}
      {$IFNDEF VER110}
      if DataSet is TADOTable then
        Result := (DataSet as TADOTable).MasterSource
       else
      if DataSet is TADOQuery then
        Result := (DataSet as TADOQuery).DataSource
       else
      if DataSet is TADODataSet then
        Result := (DataSet as TADODataSet).DataSource
       else
      if DataSet is TADOStoredProc then
        Result := (DataSet as TADOStoredProc).DataSource
       else
      {$ENDIF}
      {$ENDIF}
      if DataSet is TTable then
         Result := (DataSet as TTable).MasterSource
        else
      if DataSet is TQuery then
         Result := (DataSet as TQuery).DataSource
        else
      if DataSet is TClientDataSet then
      begin
         Result := (DataSet as TClientDataSet).MasterSource;
      end;
      {$IFNDEF VER110}
         if not Assigned(Result) then
            if DataSet is TClientDataSet then
            begin
               if ((DataSet as TClientDataSet).DataSetField <> nil) and
                  ((DataSet as TClientDataSet).DataSetField.DataSet <> nil) then
               with (DataSet as TClientDataSet).DataSetField.DataSet.Owner do
               for i := 0 to ComponentCount-1 do
                  if (Components[i] is TDataSource) and
                     ((Components[i] as TDataSource).DataSet =
                          (DataSet as TClientDataSet).DataSetField.DataSet) then
                  begin
                     Result := Components[i] as TDataSource;
                     break;
                  end;
            end
             else
            if DataSet is TNestedTable then
            begin
               if ((DataSet as TNestedTable).DataSetField <> nil) and
                  ((DataSet as TNestedTable).DataSetField.DataSet <> nil) then
               with (DataSet as TNestedTable).DataSetField.DataSet.Owner do
               for i := 0 to ComponentCount-1 do
                  if (Components[i] is TDataSource) and
                     ((Components[i] as TDataSource).DataSet =
                          (DataSet as TNestedTable).DataSetField.DataSet) then
                  begin
                     Result := Components[i] as TDataSource;
                     break;
                  end;
            end;
      {$ENDIF}
   end;
end;

{TSender}
class procedure TSender.GetFieldText(Sender: TField; var Text: String;
       DisplayText: Boolean);
begin
   GetLookUpText(Sender, Text, DisplayText);
end;

class procedure TSender.SetFieldText(Sender: TField; const Text: String);
begin
   SetLookUpText(Sender, Text);
end;

class procedure TSender.ValidateData(Sender: TField);
begin
   if not ValidData(Sender) then
     if Sender.IsNULL and not Sender.Required then
     begin
        MessageBeep(MB_ICONASTERISK);
        MessageDlg(SRecordNotFound, mtInformation, [mbOk], 0);
     end
      else
       Raise EDataBaseError.Create(SRecordNotFound);
end;

end.