1{%MainUnit ../dbctrls.pp} 2{ 3 ***************************************************************************** 4 This file is part of the Lazarus Component Library (LCL) 5 6 See the file COPYING.modifiedLGPL.txt, included in this distribution, 7 for details about the license. 8 ***************************************************************************** 9} 10 11{ TDBCheckBox } 12 13function TDBCheckBox.GetDataField: string; 14begin 15 Result:=FDataLink.FieldName; 16end; 17 18function TDBCheckBox.GetDataSource: TDataSource; 19begin 20 Result:=FDataLink.DataSource; 21end; 22 23function TDBCheckBox.GetField: TField; 24begin 25 Result:=FDataLink.Field; 26end; 27 28function TDBCheckBox.GetReadOnly: Boolean; 29begin 30 Result:=FDataLink.ReadOnly; 31end; 32 33procedure TDBCheckBox.SetDataField(const AValue: string); 34begin 35 FDataLink.FieldName:=AValue; 36end; 37 38procedure TDBCheckBox.SetDataSource(const AValue: TDataSource); 39begin 40 if AValue=DataSource then exit; 41 if not (FDataLink.DataSourceFixed and (csLoading in ComponentState)) then 42 ChangeDataSource(Self,FDataLink,AValue); 43end; 44 45procedure TDBCheckBox.SetReadOnly(const AValue: Boolean); 46begin 47 FDataLink.ReadOnly:=AValue; 48end; 49 50procedure TDBCheckBox.SetValueChecked(const AValue: string); 51begin 52 if FValueChecked=AValue then exit; 53 FValueChecked:=AValue; 54 DataChange(Self); 55end; 56 57procedure TDBCheckBox.SetValueUnchecked(const AValue: string); 58begin 59 if FValueUnchecked=AValue then exit; 60 FValueUnchecked:=AValue; 61 DataChange(Self); 62end; 63 64//check if Word is equal to S or is one of the ; delimitted words in s 65//whitespace between Word and delimiter is ignored (Delphi behavior) 66function FindWord(const Word, S: String): Boolean; 67var 68 I, J, L: Integer; 69 C: Char; 70begin 71 I := Pos(Word, S); 72 Result := I > 0; 73 if Result then 74 begin 75 //forward 76 J := I + Length(Word); 77 L := Length(S); 78 while Result and (J < L) do 79 begin 80 C := S[J]; 81 if C = ';' then 82 Break; 83 Result := C = ' '; 84 Inc(J); 85 end; 86 //backward 87 Dec(I); 88 while Result and (I > 0) do 89 begin 90 C := S[I]; 91 if C = ';' then 92 Break; 93 Result := C = ' '; 94 Dec(I); 95 end; 96 end; 97end; 98 99function TDBCheckBox.GetFieldCheckState: TCheckBoxState; 100var 101 FieldText: string; 102 DataLinkField: TField; 103begin 104 DataLinkField := FDataLink.Field; 105 if DatalinkField=nil then begin 106 Result:=cbUnchecked; 107 exit; 108 end; 109 if DataLinkField.IsNull then 110 Result:=cbGrayed 111 else if DataLinkField.DataType = ftBoolean then begin 112 if DataLinkField.AsBoolean then 113 Result:=cbChecked 114 else 115 Result:=cbUnchecked; 116 end else begin 117 FieldText:=UpperCase(DatalinkField.AsString); 118 if FindWord(FieldText,UpperCase(FValueChecked)) then 119 Result:=cbChecked 120 else if FindWord(FieldText,UpperCase(FValueUnchecked)) then 121 Result:=cbUnchecked 122 else 123 Result:=cbGrayed; 124 end; 125end; 126 127procedure TDBCheckBox.DataChange(Sender: TObject); 128begin 129 // avoid DoOnChange circle #33573 130 FDataLink.OnDataChange := nil; 131 State:=GetFieldCheckState; 132 FDataLink.OnDataChange := @DataChange; 133end; 134 135procedure TDBCheckBox.DoOnChange; 136begin 137 // avoid DoOnChange circle #33573 138 if FDataLink.OnDataChange = nil then 139 Exit; 140 141 //avoid reseting value when state changes 142 FDataLink.OnDataChange := nil; 143 if FDatalink.Edit then begin 144 FDatalink.Modified; 145 FDataLink.UpdateRecord; 146 end else 147 State:=GetFieldCheckState; 148 FDataLink.OnDataChange := @DataChange; 149 inherited DoOnChange; 150end; 151 152procedure TDBCheckBox.UpdateData(Sender: TObject); 153var 154 NewFieldText: string; 155begin 156 if State = cbGrayed then 157 FDataLink.Field.Clear 158 else 159 if FDataLink.Field.DataType = ftBoolean then 160 FDataLink.Field.AsBoolean:=Checked 161 else begin 162 if Checked then 163 NewFieldText:=FValueChecked 164 else 165 NewFieldText:=FValueUnchecked; 166 // ToDo: use Field.Text 167 FDataLink.Field.AsString:=Trim(NewFieldText); 168 end; 169end; 170 171procedure TDBCheckBox.Notification(AComponent: TComponent; Operation: TOperation); 172begin 173 inherited Notification(AComponent, Operation); 174 if (Operation=opRemove) then begin 175 if (FDataLink<>nil) and (AComponent=DataSource) then 176 DataSource:=nil; 177 end; 178end; 179 180procedure TDBCheckBox.CMGetDataLink(var Message: TLMessage); 181begin 182 Message.Result := PtrUInt(FDataLink); 183end; 184 185constructor TDBCheckBox.Create(TheOwner: TComponent); 186begin 187 inherited Create(TheOwner); 188 FValueChecked:='True'; 189 FValueUnchecked:='False'; 190 191 ControlStyle:=ControlStyle+[csReplicatable]; 192 State:=cbUnchecked; 193 FDataLink:=TFieldDataLink.Create; 194 FDataLink.Control:=Self; 195 FDataLink.OnDataChange:=@DataChange; 196 FDataLink.OnUpdateData:=@UpdateData; 197end; 198 199destructor TDBCheckBox.Destroy; 200begin 201 FDataLink.Destroy; 202 inherited Destroy; 203end; 204 205function TDBCheckBox.ExecuteAction(AAction: TBasicAction): Boolean; 206begin 207 Result := inherited ExecuteAction(AAction) or 208 (FDataLink <> nil) and FDataLink.ExecuteAction(AAction); 209end; 210 211function TDBCheckBox.UpdateAction(AAction: TBasicAction): Boolean; 212begin 213 Result := inherited UpdateAction(AAction) or 214 (FDataLink <> nil) and FDataLink.UpdateAction(AAction); 215end; 216 217// included by dbctrls.pp 218