home *** CD-ROM | disk | FTP | other *** search
/ CD Shareware Magazine 1996 December / CD_shareware_12-96.iso / WIN / Programa / CASCCONT.ZIP / COMPON / CASCCREG.PAS < prev    next >
Encoding:
Pascal/Delphi Source File  |  1996-09-02  |  6.0 KB  |  208 lines
  1. unit CascCReg;
  2. { Register Unit for CascCont}
  3. interface
  4.  
  5. procedure Register;
  6.  
  7. implementation
  8. uses
  9.   Windows,SysUtils, Classes, DB,DsgnIntf, Controls,CascCont,TypInfo
  10.   ;
  11.  
  12. { TDBStringProperty and partially TCascadeFieldProperty is
  13.   Copyright Borland. I had to copy-paste it, because it's not
  14.   accesible in DBReg. (Please correct me if I got something wrong
  15.   here.
  16.    }
  17.  
  18. type
  19.   TCascadeFieldProperty = class(TStringProperty)
  20.   public
  21.     function GetAttributes: TPropertyAttributes; override;
  22.     procedure GetValueList(List: TStrings);
  23.     procedure GetValues(Proc: TGetStrProc); override;
  24.   end;
  25.  
  26. function TCascadeFieldProperty.GetAttributes: TPropertyAttributes;
  27. begin
  28.   Result := [paValueList, paSortList, paMultiSelect];
  29. end;
  30.  
  31. procedure TCascadeFieldProperty.GetValues(Proc: TGetStrProc);
  32. var
  33.   I: Integer;
  34.   Values: TStringList;
  35. begin
  36.   Values := TStringList.Create;
  37.   try
  38.     GetValueList(Values);
  39.     for I := 0 to Values.Count - 1 do Proc(Values[I]);
  40.   finally
  41.     Values.Free;
  42.   end;
  43. end;
  44.  
  45. procedure TCascadeFieldProperty.GetValueList(List: TStrings);
  46. var
  47.   Instance: TComponent;
  48.   PropInfo: PPropInfo;
  49.   DataSource: TDataSource;
  50. begin
  51.   Instance := GetComponent(0);
  52.   PropInfo := TypInfo.GetPropInfo(Instance.ClassInfo, 'CascadeSource');
  53.   if (PropInfo <> nil) and (PropInfo^.PropType^.Kind = tkClass) then
  54.   begin
  55.     DataSource := TObject(GetOrdProp(Instance, PropInfo)) as TDataSource;
  56.     if (DataSource <> nil) and (DataSource.DataSet <> nil) then
  57.       DataSource.DataSet.GetFieldNames(List);
  58.   end;
  59. end;
  60.  
  61. {---------------------------- Property editor ---------------------------------}
  62. { A special case of TDataFieldGroup Property.
  63.   Only shows the first field of the general form  XXXX_First, XXXX_Second,
  64.   with same XXXX in a row.
  65.   This is a candidate for a multiple selection key of DBCheckGroup}
  66.  
  67. type
  68.   TDataFieldGroupProperty = class(TStringProperty)
  69.   public
  70.     function GetAttributes: TPropertyAttributes; override;
  71.     procedure GetValues(Proc: TGetStrProc); override;
  72.   end;
  73.  
  74.  
  75. { ------------------------------- TDataFieldGroupProperty --------------------}
  76. function TDataFieldGroupProperty.GetAttributes: TPropertyAttributes;
  77. begin
  78.   Result:=[paValueList, paSortList,paMultiSelect];
  79. end;
  80.  
  81. procedure TDataFieldGroupProperty.GetValues(Proc: TGetStrProc);
  82. var UPos,I,Len: Integer;
  83.     CTable:TDataSet;
  84.     CDataSource:TDataSource;
  85.     LastGroup,CurGroup: string;
  86.     FD: TFieldDef;
  87. begin
  88.   CDataSource:=(TDBCascCheckGroup(GetComponent(0))).DataSource;
  89.   if CDataSource = nil then exit;
  90.   CTable:=CDataSource.DataSet;
  91.   if (CTable = nil) or not CTable.Active then exit;
  92.  
  93.   LastGroup:='';
  94.   for i := 0 to CTable.FieldDefs.Count - 1 do
  95.   begin
  96.     FD:= CTable.FieldDefs.Items[i];
  97.     if FD.DataType <> ftBoolean then continue;
  98.     UPos:=Pos('_',FD.Name);
  99.     if Upos <=1 then continue; { Skip if no _ or leading _ }
  100.     CurGroup:=Copy(FD.Name,1,UPos-1);
  101.     if CompareText(CurGroup,LastGroup) = 0 then
  102.       continue; { Skip if same group }
  103.     LastGroup:=CurGroup;
  104.     Proc(CurGroup);
  105.   end;
  106. end;
  107.  
  108. { TDBStringProperty }
  109.  
  110. type
  111.   TDBStringProperty = class(TStringProperty)
  112.   public
  113.     function GetAttributes: TPropertyAttributes; override;
  114.     procedure GetValueList(List: TStrings); virtual; abstract;
  115.     procedure GetValues(Proc: TGetStrProc); override;
  116.   end;
  117.  
  118. function TDBStringProperty.GetAttributes: TPropertyAttributes;
  119. begin
  120.   Result := [paValueList, paSortList, paMultiSelect];
  121. end;
  122.  
  123. procedure TDBStringProperty.GetValues(Proc: TGetStrProc);
  124. var
  125.   I: Integer;
  126.   Values: TStringList;
  127. begin
  128.   Values := TStringList.Create;
  129.   try
  130.     GetValueList(Values);
  131.     for I := 0 to Values.Count - 1 do Proc(Values[I]);
  132.   finally
  133.     Values.Free;
  134.   end;
  135. end;
  136.  
  137. { TDataFieldProperty }
  138. type
  139.   TDataFieldProperty = class(TDBStringProperty)
  140.   public
  141.     function GetDataSourcePropName: string; virtual;
  142.     procedure GetValueList(List: TStrings); override;
  143.   end;
  144.  
  145. function TDataFieldProperty.GetDataSourcePropName: string;
  146. begin
  147.   Result := 'DataSource';
  148. end;
  149.  
  150. procedure TDataFieldProperty.GetValueList(List: TStrings);
  151. var
  152.   Instance: TComponent;
  153.   PropInfo: PPropInfo;
  154.   DataSource: TDataSource;
  155. begin
  156.   Instance := GetComponent(0);
  157.   PropInfo := TypInfo.GetPropInfo(Instance.ClassInfo, GetDataSourcePropName);
  158.   if (PropInfo <> nil) and (PropInfo^.PropType^.Kind = tkClass) then
  159.   begin
  160.     DataSource := TObject(GetOrdProp(Instance, PropInfo)) as TDataSource;
  161.     if (DataSource <> nil) and (DataSource.DataSet <> nil) then
  162.       DataSource.DataSet.GetFieldNames(List);
  163.   end;
  164. end;
  165.  
  166. type
  167.   TListFieldProperty = class(TDataFieldProperty)
  168.   public
  169.     function GetDataSourcePropName: string; override;
  170.   end;
  171.  
  172. function TListFieldProperty.GetDataSourcePropName: string;
  173. begin
  174.   Result := 'ListSource';
  175. end;
  176.  
  177. procedure Register;
  178. begin
  179.   RegisterComponents('DBCasc',[
  180.         TDBCascCheckBox,
  181.         TDBCascEdit,
  182.         TDBCascMemo,
  183.         TDBCascLookupCombo,
  184.         TDBCascCheckGroup,
  185.         TDBCascDateEdit
  186.         ]);
  187.   RegisterPropertyEditor(TypeInfo(string), TDBCascLookupCombo, 'CascadeField',
  188.                              TCascadeFieldProperty);
  189.   RegisterPropertyEditor(TypeInfo(string), TDBCascCheckBox, 'CascadeField',
  190.                              TCascadeFieldProperty);
  191.   RegisterPropertyEditor(TypeInfo(string), TDBCascEdit, 'CascadeField',
  192.                              TCascadeFieldProperty);
  193.   RegisterPropertyEditor(TypeInfo(string), TDBCascMemo, 'CascadeField',
  194.                              TCascadeFieldProperty);
  195.   RegisterPropertyEditor(TypeInfo(string), TDBCascCheckGroup, 'CascadeField',
  196.                              TCascadeFieldProperty);
  197.   RegisterPropertyEditor(TypeInfo(string), TDBCascDateEdit, 'CascadeField',
  198.                              TCascadeFieldProperty);
  199.   RegisterPropertyEditor(TypeInfo(string), TDBCascCheckGroup, 'ListField',
  200.                              TListFieldProperty);
  201.   RegisterPropertyEditor(TypeInfo(string),TDBCascCheckGroup,
  202.      'DataFieldGroup',TDataFieldGroupProperty);
  203. end;
  204.  
  205.  
  206. end.
  207.  
  208.