Delphi控件源码

开发平台：

Delphi

bsdbctrls.pas：源码内容

inherited Destroy;
end;
procedure TbsNavButton.GetSkinData;
begin
inherited;
MaskPicture := nil;
end;
procedure TbsNavButton.MouseDown(Button: TMouseButton; Shift: TShiftState;
X, Y: Integer);
begin
inherited MouseDown (Button, Shift, X, Y);
if nsAllowTimer in FNavStyle then
begin
if FRepeatTimer = nil then
FRepeatTimer := TTimer.Create(Self);
FRepeatTimer.OnTimer := TimerExpired;
FRepeatTimer.Interval := InitRepeatPause;
FRepeatTimer.Enabled := True;
end;
end;
procedure TbsNavButton.MouseUp(Button: TMouseButton; Shift: TShiftState;
X, Y: Integer);
begin
inherited MouseUp (Button, Shift, X, Y);
if FRepeatTimer <> nil then
FRepeatTimer.Enabled := False;
end;
procedure TbsNavButton.TimerExpired(Sender: TObject);
begin
FRepeatTimer.Interval := RepeatPause;
if (FMouseIn and FDown) and MouseCapture then
begin
try
ButtonClick;
except
FRepeatTimer.Enabled := False;
raise;
end;
end;
end;
{ TbsNavDataLink }
constructor TbsNavDataLink.Create(ANav: TbsSkinDBNavigator);
begin
inherited Create;
FNavigator := ANav;
VisualControl := True;
end;
destructor TbsNavDataLink.Destroy;
begin
FNavigator := nil;
inherited Destroy;
end;
procedure TbsNavDataLink.EditingChanged;
begin
if FNavigator <> nil then FNavigator.EditingChanged;
end;
procedure TbsNavDataLink.DataSetChanged;
begin
if FNavigator <> nil then FNavigator.DataChanged;
end;
procedure TbsNavDataLink.ActiveChanged;
begin
if FNavigator <> nil then FNavigator.ActiveChanged;
end;
constructor TbsSkinDBImage.Create(AOwner: TComponent);
begin
inherited Create(AOwner);
Width := 105;
Height := 105;
TabStop := True;
FPicture := TPicture.Create;
FPicture.OnChange := PictureChanged;
FAutoDisplay := True;
FCenter := True;
FDataLink := TFieldDataLink.Create;
FDataLink.Control := Self;
FDataLink.OnDataChange := DataChange;
FDataLink.OnUpdateData := UpdateData;
FQuickDraw := True;
end;
destructor TbsSkinDBImage.Destroy;
begin
FPicture.Free;
FDataLink.Free;
FDataLink := nil;
inherited Destroy;
end;
function TbsSkinDBImage.GetDataSource: TDataSource;
begin
Result := FDataLink.DataSource;
end;
procedure TbsSkinDBImage.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 TbsSkinDBImage.GetDataField: string;
begin
Result := FDataLink.FieldName;
end;
procedure TbsSkinDBImage.SetDataField(const Value: string);
begin
FDataLink.FieldName := Value;
end;
function TbsSkinDBImage.GetReadOnly: Boolean;
begin
Result := FDataLink.ReadOnly;
end;
procedure TbsSkinDBImage.SetReadOnly(Value: Boolean);
begin
FDataLink.ReadOnly := Value;
end;
function TbsSkinDBImage.GetField: TField;
begin
Result := FDataLink.Field;
end;
function TbsSkinDBImage.GetPalette: HPALETTE;
begin
Result := 0;
if FPicture.Graphic is TBitmap then
Result := TBitmap(FPicture.Graphic).Palette;
end;
procedure TbsSkinDBImage.SetAutoDisplay(Value: Boolean);
begin
if FAutoDisplay <> Value then
begin
FAutoDisplay := Value;
if Value then LoadPicture;
end;
end;
procedure TbsSkinDBImage.SetCenter(Value: Boolean);
begin
if FCenter <> Value then
begin
FCenter := Value;
Invalidate;
end;
end;
procedure TbsSkinDBImage.SetPicture(Value: TPicture);
begin
FPicture.Assign(Value);
end;
procedure TbsSkinDBImage.SetStretch(Value: Boolean);
begin
if FStretch <> Value then
begin
FStretch := Value;
Invalidate;
end;
end;
procedure TbsSkinDBImage.CreateControlDefaultImage(B: TBitMap);
begin
inherited;
if not RollUpState then PaintImage(B.Canvas);
end;
procedure TbsSkinDBImage.CreateControlSkinImage(B: TBitMap);
begin
inherited;
if not RollUpState then PaintImage(B.Canvas);
end;
procedure TbsSkinDBImage.PaintImage;
procedure DrawFocus(Cnvs: TCanvas; R: TRect);
begin
with Cnvs do
begin
Pen.Color := clWindowFrame;
Pen.Mode := pmNot;
Brush.Style := bsClear;
Rectangle(R.Left, R.Top, R.Right, R.Bottom);
end;
end;
var
Size: TSize;
DrawRect, R: TRect;
S: string;
DrawPict: TPicture;
Form: TCustomForm;
Pal: HPalette;
begin
DrawRect := Rect(0, 0, Width, Height);
AdjustClientRect(DrawRect);
with Cnvs do
begin
Brush.Style := bsClear;
if FPictureLoaded or (csPaintCopy in ControlState) then
begin
DrawPict := TPicture.Create;
Pal := 0;
try
if (csPaintCopy in ControlState) and
Assigned(FDataLink.Field) and FDataLink.Field.IsBlob
then
begin
DrawPict.Assign(FDataLink.Field);
if DrawPict.Graphic is TBitmap then
DrawPict.Bitmap.IgnorePalette := QuickDraw;
end
else
DrawPict.Assign(Picture);
if Stretch
then
begin
if (DrawPict.Graphic <> nil) and not DrawPict.Graphic.Empty
then
StretchDraw(DrawRect, DrawPict.Graphic);
end
else
begin
Windows.SetRect(R, DrawRect.Left, DrawRect.Top,
DrawRect.Left + DrawPict.Width,
DrawRect.Top + DrawPict.Height);
if Center
then
OffsetRect(R, ((DrawRect.Right - DrawRect.Left) - DrawPict.Width) div 2,
((DrawRect.Bottom - DrawRect.Top) - DrawPict.Height) div 2);
StretchDraw(R, DrawPict.Graphic);
end;
finally
if Pal <> 0 then SelectPalette(Handle, Pal, True);
DrawPict.Free;
end;
end;
Form := GetParentForm(Self);
if (Form <> nil) and (Form.ActiveControl = Self) and
not (csDesigning in ComponentState) and
not (csPaintCopy in ControlState)
then
DrawFocus(Cnvs, DrawRect);
end;
end;
procedure TbsSkinDBImage.PictureChanged(Sender: TObject);
begin
if FPictureLoaded then FDataLink.Modified;
FPictureLoaded := True;
Invalidate;
end;
procedure TbsSkinDBImage.Notification(AComponent: TComponent;
Operation: TOperation);
begin
inherited Notification(AComponent, Operation);
if (Operation = opRemove) and (FDataLink <> nil) and
(AComponent = DataSource) then DataSource := nil;
end;
procedure TbsSkinDBImage.LoadPicture;
begin
if not FPictureLoaded and (not Assigned(FDataLink.Field) or
FDataLink.Field.IsBlob) then
Picture.Assign(FDataLink.Field);
end;
procedure TbsSkinDBImage.DataChange(Sender: TObject);
begin
Picture.Graphic := nil;
FPictureLoaded := False;
if FAutoDisplay then LoadPicture;
end;
procedure TbsSkinDBImage.UpdateData(Sender: TObject);
begin
if Picture.Graphic is TBitmap then
FDataLink.Field.Assign(Picture.Graphic) else
FDataLink.Field.Clear;
end;
procedure TbsSkinDBImage.CopyToClipboard;
begin
if Picture.Graphic <> nil then Clipboard.Assign(Picture);
end;
procedure TbsSkinDBImage.CutToClipboard;
begin
if Picture.Graphic <> nil then
if FDataLink.Edit then
begin
CopyToClipboard;
Picture.Graphic := nil;
end;
end;
procedure TbsSkinDBImage.PasteFromClipboard;
begin
if Clipboard.HasFormat(CF_BITMAP) and FDataLink.Edit then
Picture.Bitmap.Assign(Clipboard);
end;
procedure TbsSkinDBImage.CreateParams(var Params: TCreateParams);
begin
inherited CreateParams(Params);
with Params do
begin
WindowClass.style := WindowClass.style and not (CS_HREDRAW or CS_VREDRAW);
end;
end;
procedure TbsSkinDBImage.KeyDown(var Key: Word; Shift: TShiftState);
begin
inherited KeyDown(Key, Shift);
case Key of
VK_INSERT:
if ssShift in Shift then PasteFromClipBoard else
if ssCtrl in Shift then CopyToClipBoard;
VK_DELETE:
if ssShift in Shift then CutToClipBoard;
end;
end;
procedure TbsSkinDBImage.KeyPress(var Key: Char);
begin
inherited KeyPress(Key);
case Key of
^X: CutToClipBoard;
^C: CopyToClipBoard;
^V: PasteFromClipBoard;
#13: LoadPicture;
#27: FDataLink.Reset;
end;
end;
procedure TbsSkinDBImage.CMGetDataLink(var Message: TMessage);
begin
Message.Result := Integer(FDataLink);
end;
procedure TbsSkinDBImage.CMEnter(var Message: TCMEnter);
begin
Invalidate; { Draw the focus marker }
inherited;
end;
procedure TbsSkinDBImage.CMExit(var Message: TCMExit);
begin
try
FDataLink.UpdateRecord;
except
SetFocus;
raise;
end;
Invalidate; { Erase the focus marker }
inherited;
end;
procedure TbsSkinDBImage.CMTextChanged(var Message: TMessage);
begin
inherited;
if not FPictureLoaded then Invalidate;
end;
procedure TbsSkinDBImage.WMLButtonDown(var Message: TWMLButtonDown);
begin
if TabStop and CanFocus then SetFocus;
inherited;
end;
procedure TbsSkinDBImage.WMLButtonDblClk(var Message: TWMLButtonDblClk);
begin
LoadPicture;
inherited;
end;
procedure TbsSkinDBImage.WMCut(var Message: TMessage);
begin
CutToClipboard;
end;
procedure TbsSkinDBImage.WMCopy(var Message: TMessage);
begin
CopyToClipboard;
end;
procedure TbsSkinDBImage.WMPaste(var Message: TMessage);
begin
PasteFromClipboard;
end;
procedure TbsSkinDBImage.WMSize(var Message: TMessage);
begin
inherited;
Invalidate;
end;
function TbsSkinDBImage.ExecuteAction(Action: TBasicAction): Boolean;
begin
Result := inherited ExecuteAction(Action) or (FDataLink <> nil) and
FDataLink.ExecuteAction(Action);
end;
function TbsSkinDBImage.UpdateAction(Action: TBasicAction): Boolean;
begin
Result := inherited UpdateAction(Action) or (FDataLink <> nil) and
FDataLink.UpdateAction(Action);
end;
{ TbsSkinDBRadioGroup }
constructor TbsSkinDBRadioGroup.Create(AOwner: TComponent);
begin
inherited Create(AOwner);
FDataLink := TFieldDataLink.Create;
FDataLink.Control := Self;
FDataLink.OnDataChange := DataChange;
FDataLink.OnUpdateData := UpdateData;
FValues := TStringList.Create;
FInClick := False;
end;
destructor TbsSkinDBRadioGroup .Destroy;
begin
FDataLink.Free;
FDataLink := nil;
FValues.Free;
inherited Destroy;
end;
procedure TbsSkinDBRadioGroup.Notification(AComponent: TComponent;
Operation: TOperation);
begin
inherited Notification(AComponent, Operation);
if (Operation = opRemove) and (FDataLink <> nil) and
(AComponent = DataSource) then DataSource := nil;
end;
function TbsSkinDBRadioGroup .UseRightToLeftAlignment: Boolean;
begin
Result := inherited UseRightToLeftAlignment;
end;
procedure TbsSkinDBRadioGroup.DataChange(Sender: TObject);
begin
if not FInClick then
if FDataLink.Field <> nil then
Value := FDataLink.Field.Text else
Value := '';
end;
procedure TbsSkinDBRadioGroup.UpdateData(Sender: TObject);
begin
if FDataLink.Field <> nil then FDataLink.Field.Text := Value;
end;
function TbsSkinDBRadioGroup.GetDataSource: TDataSource;
begin
Result := FDataLink.DataSource;
end;
procedure TbsSkinDBRadioGroup.SetDataSource(Value: TDataSource);
begin
FDataLink.DataSource := Value;
if Value <> nil then Value.FreeNotification(Self);
end;
function TbsSkinDBRadioGroup.GetDataField: string;
begin
Result := FDataLink.FieldName;
end;
procedure TbsSkinDBRadioGroup.SetDataField(const Value: string);
begin
FDataLink.FieldName := Value;
end;
function TbsSkinDBRadioGroup.GetReadOnly: Boolean;
begin
Result := FDataLink.ReadOnly;
end;
procedure TbsSkinDBRadioGroup.SetReadOnly(Value: Boolean);
begin
FDataLink.ReadOnly := Value;
end;
function TbsSkinDBRadioGroup.GetField: TField;
begin
Result := FDataLink.Field;
end;
function TbsSkinDBRadioGroup.GetButtonValue(Index: Integer): string;
begin
if (Index < FValues.Count) and (FValues[Index] <> '') then
Result := FValues[Index]
else if Index < Items.Count then
Result := Items[Index]
else
Result := '';
end;
procedure TbsSkinDBRadioGroup.SetValue(const Value: string);
var
I, Index: Integer;
begin
if FValue <> Value then
begin
FInSetValue := True;
try
Index := -1;
for I := 0 to Items.Count - 1 do
if Value = GetButtonValue(I) then
begin
Index := I;
Break;
end;
ItemIndex := Index;
finally
FInSetValue := False;
end;
FValue := Value;
Change;
end;
end;
procedure TbsSkinDBRadioGroup.CMExit(var Message: TCMExit);
begin
try
FDataLink.UpdateRecord;
except
if ItemIndex >= 0 then
TRadioButton(Controls[ItemIndex]).SetFocus else
TRadioButton(Controls[0]).SetFocus;
raise;
end;
inherited;
end;
procedure TbsSkinDBRadioGroup.Click;
begin
if not FInSetValue then
begin
inherited Click;
FInClick := True;
if ItemIndex >= 0
then Value := GetButtonValue(ItemIndex);
if not ReadOnly and not FDataLink.Editing then FDataLink.Edit;
if FDataLink.Editing
then FDataLink.Modified;
FInClick := False;
end;
end;
procedure TbsSkinDBRadioGroup.SetItems(Value: TStrings);
begin
Items.Assign(Value);
DataChange(Self);
end;
procedure TbsSkinDBRadioGroup.SetValues(Value: TStrings);
begin
FValues.Assign(Value);
DataChange(Self);
end;
procedure TbsSkinDBRadioGroup.Change;
begin
if Assigned(FOnChange) then FOnChange(Self);
end;
procedure TbsSkinDBRadioGroup.KeyPress(var Key: Char);
begin
inherited KeyPress(Key);
case Key of
#8, ' ': FDataLink.Edit;
#27: FDataLink.Reset;
end;
end;
function TbsSkinDBRadioGroup.CanModify: Boolean;
begin
Result := FDataLink.Edit;
end;
function TbsSkinDBRadioGroup.ExecuteAction(Action: TBasicAction): Boolean;
begin
Result := inherited ExecuteAction(Action) or (DataLink <> nil) and
DataLink.ExecuteAction(Action);
end;
function TbsSkinDBRadioGroup.UpdateAction(Action: TBasicAction): Boolean;
begin
Result := inherited UpdateAction(Action) or (DataLink <> nil) and
DataLink.UpdateAction(Action);
end;
constructor TbsSkinDBSpinEdit.Create(AOwner: TComponent);
begin
inherited Create(AOwner);
ControlStyle := ControlStyle + [csReplicatable];
FDataLink := TFieldDataLink.Create;
FDataLink.Control := Self;
FDataLink.OnDataChange := DataChange;
FDataLink.OnEditingChange := EditingChange;
FDataLink.OnUpdateData := UpdateData;
FInChange := False;
FInDataChange := False;
end;
destructor TbsSkinDBSpinEdit.Destroy;
begin
FDataLink.Free;
FDataLink := nil;
FCanvas.Free;
inherited Destroy;
end;
procedure TbsSkinDBSpinEdit.Loaded;
begin
inherited Loaded;
if (csDesigning in ComponentState) then DataChange(Self);
end;
procedure TbsSkinDBSpinEdit.Notification(AComponent: TComponent;
Operation: TOperation);
begin
inherited Notification(AComponent, Operation);
if (Operation = opRemove) and (FDataLink <> nil) and
(AComponent = DataSource) then DataSource := nil;
end;
procedure TbsSkinDBSpinEdit.Reset;
begin
FDataLink.Reset;
FEdit.SelectAll;
end;
procedure TbsSkinDBSpinEdit.Change;
begin
FInChange := True;
if not FInDataChange and (FDataLink <> nil) and
not ReadOnly and FDataLink.CanModify
then
begin
if not FDataLink.Editing then FDataLink.Edit;
FDataLink.Modified;
inherited Change;
end;
FInChange := False;
end;
function TbsSkinDBSpinEdit.GetDataSource: TDataSource;
begin
Result := FDataLink.DataSource;
end;
procedure TbsSkinDBSpinEdit.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 TbsSkinDBSpinEdit.GetDataField: string;
begin
Result := FDataLink.FieldName;
end;
procedure TbsSkinDBSpinEdit.SetDataField(const Value: string);
begin
FDataLink.FieldName := Value;
end;
function TbsSkinDBSpinEdit.GetReadOnly: Boolean;
begin
Result := FDataLink.ReadOnly;
end;
procedure TbsSkinDBSpinEdit.SetReadOnly(Value: Boolean);
begin
FDataLink.ReadOnly := Value;
end;
function TbsSkinDBSpinEdit.GetField: TField;
begin
Result := FDataLink.Field;
end;
procedure TbsSkinDBSpinEdit.DataChange(Sender: TObject);
begin
FInDataChange := True;
if not FInChange then
if FDataLink.Field <> nil
then
begin
if (FDataLink.Field.Text <> '') and
IsNumText(FDataLink.Field.Text)
then Value := StrToInt(FDataLink.Field.Text)
else Value := MinValue;
end
else
Value := MinValue;
FInDataChange := False;
end;
procedure TbsSkinDBSpinEdit.EditingChange(Sender: TObject);
begin
FEdit.ReadOnly := not FDataLink.Editing;
end;
procedure TbsSkinDBSpinEdit.UpdateData(Sender: TObject);
begin
FDataLink.Field.Text := FEdit.Text;
end;
procedure TbsSkinDBSpinEdit.EditEnter;
begin
inherited;
FEdit.ReadOnly := not FDataLink.CanModify;
end;
procedure TbsSkinDBSpinEdit.EditExit;
begin
if (FDataLink <> nil) and (FDataLink.Editing)
then
FDataLink.UpdateRecord;
end;
procedure TbsSkinDBSpinEdit.CMGetDataLink(var Message: TMessage);
begin
Message.Result := Integer(FDataLink);
end;
function TbsSkinDBSpinEdit.ExecuteAction(Action: TBasicAction): Boolean;
begin
Result := inherited ExecuteAction(Action) or (FDataLink <> nil) and
FDataLink.ExecuteAction(Action);
end;
function TbsSkinDBSpinEdit.UpdateAction(Action: TBasicAction): Boolean;
begin
Result := inherited UpdateAction(Action) or (FDataLink <> nil) and
FDataLink.UpdateAction(Action);
end;
{ TbsDataSourceLink }
constructor TbsDataSourceLink.Create;
begin
inherited Create;
VisualControl := True;
end;
procedure TbsDataSourceLink.ActiveChanged;
begin
if FDBLookupControl <> nil then FDBLookupControl.UpdateDataFields;
end;
procedure TbsDataSourceLink.FocusControl(Field: TFieldRef);
begin
if (Field^ <> nil) and (Field^ = FDBLookupControl.Field) and
(FDBLookupControl <> nil) and FDBLookupControl.CanFocus then
begin
Field^ := nil;
FDBLookupControl.SetFocus;
end;
end;
procedure TbsDataSourceLink.LayoutChanged;
begin
if FDBLookupControl <> nil then FDBLookupControl.UpdateDataFields;
end;
procedure TbsDataSourceLink.RecordChanged(Field: TField);
begin
if FDBLookupControl <> nil then FDBLookupControl.DataLinkRecordChanged(Field);
end;
{ TbsListSourceLink }
constructor TbsListSourceLink.Create;
begin
inherited Create;
VisualControl := True;
end;
procedure TbsListSourceLink.ActiveChanged;
begin
if FDBLookupControl <> nil then FDBLookupControl.UpdateListFields;
end;
procedure TbsListSourceLink.DataSetChanged;
begin
if FDBLookupControl <> nil then FDBLookupControl.ListLinkDataChanged;
end;
procedure TbsListSourceLink.LayoutChanged;
begin
if FDBLookupControl <> nil then FDBLookupControl.UpdateListFields;
end;
{ TbsDBLookupControl }
function VarEquals(const V1, V2: Variant): Boolean;
begin
Result := False;
try
Result := V1 = V2;
except
end;
end;
var
SearchTickCount: Integer = 0;
constructor TbsDBLookupControl.Create(AOwner: TComponent);
begin
inherited Create(AOwner);
ParentColor := False;
TabStop := True;
FLookupSource := TDataSource.Create(Self);
FDataLink := TbsDataSourceLink.Create;
FDataLink.FDBLookupControl := Self;
FListLink := TbsListSourceLink.Create;
FListLink.FDBLookupControl := Self;
FListFields := TList.Create;
FKeyValue := Null;
end;
destructor TbsDBLookupControl.Destroy;
begin
inherited Destroy;
FListFields.Free;
FListFields := nil;
if FListLink <> nil then
FListLink.FDBLookupControl := nil;
FListLink.Free;
FListLink := nil;
if FDataLink <> nil then
FDataLink.FDBLookupControl := nil;
FDataLink.Free;
FDataLink := nil;
end;
function TbsDBLookupControl.CanModify: Boolean;
begin
Result := FListActive and not ReadOnly and ((FDataLink.DataSource = nil) or
(FMasterField <> nil) and FMasterField.CanModify);
end;
procedure TbsDBLookupControl.CheckNotCircular;
begin
if FListLink.Active and FListLink.DataSet.IsLinkedTo(DataSource) then
DatabaseError('Circular datalinks are not allowed');
end;
procedure TbsDBLookupControl.CheckNotLookup;
begin
if FLookupMode then DatabaseError('SPropDefByLookup');
if FDataLink.DataSourceFixed then DatabaseError('SDataSourceFixed');
end;
procedure TbsDBLookupControl.UpdateDataFields;
begin
FDataField := nil;
FMasterField := nil;
if FDataLink.Active and (FDataFieldName <> '') then
begin
CheckNotCircular;
FDataField := GetFieldProperty(FDataLink.DataSet, Self, FDataFieldName);
if FDataField.FieldKind = fkLookup then
FMasterField := GetFieldProperty(FDataLink.DataSet, Self, FDataField.KeyFields)
else
FMasterField := FDataField;
end;
SetLookupMode((FDataField <> nil) and (FDataField.FieldKind = fkLookup));
DataLinkRecordChanged(nil);
end;
procedure TbsDBLookupControl.DataLinkRecordChanged(Field: TField);
begin
if (Field = nil) or (Field = FMasterField) then
if FMasterField <> nil then
SetKeyValue(FMasterField.Value) else
SetKeyValue(Null);
end;
function TbsDBLookupControl.GetDataSource: TDataSource;
begin
Result := FDataLink.DataSource;
end;
function TbsDBLookupControl.GetKeyFieldName: string;
begin
if FLookupMode then Result := '' else Result := FKeyFieldName;
end;
function TbsDBLookupControl.GetListSource: TDataSource;
begin
if FLookupMode then Result := nil else Result := FListLink.DataSource;
end;
function TbsDBLookupControl.GetReadOnly: Boolean;
begin
Result := FDataLink.ReadOnly;
end;
procedure TbsDBLookupControl.KeyValueChanged;
begin
end;
procedure TbsDBLookupControl.UpdateListFields;
var
DataSet: TDataSet;
ResultField: TField;
begin
FListActive := False;
FKeyField := nil;
FListField := nil;
FListFields.Clear;
if FListLink.Active and (FKeyFieldName <> '') then
begin
CheckNotCircular;
DataSet := FListLink.DataSet;
FKeyField := GetFieldProperty(DataSet, Self, FKeyFieldName);
try
DataSet.GetFieldList(FListFields, FListFieldName);
except
DatabaseErrorFmt('Field ''%s'' not found', [Self.Name, FListFieldName]);
end;
if FLookupMode then
begin
ResultField := GetFieldProperty(DataSet, Self, FDataField.LookupResultField);
if FListFields.IndexOf(ResultField) < 0 then
FListFields.Insert(0, ResultField);
FListField := ResultField;
end else
begin
if FListFields.Count = 0 then FListFields.Add(FKeyField);
if (FListFieldIndex >= 0) and (FListFieldIndex < FListFields.Count) then
FListField := FListFields[FListFieldIndex] else
FListField := FListFields[0];
end;
FListActive := True;
end;
end;
procedure TbsDBLookupControl.ListLinkDataChanged;
begin
end;
function TbsDBLookupControl.LocateKey: Boolean;
var
KeySave: Variant;
begin
Result := False;
try
KeySave := FKeyValue;
if not VarIsNull(FKeyValue) and FListLink.DataSet.Active and
FListLink.DataSet.Locate(FKeyFieldName, FKeyValue, []) then
begin
Result := True;
FKeyValue := KeySave;
end;
except
end;
end;
procedure TbsDBLookupControl.Notification(AComponent: TComponent;
Operation: TOperation);
begin
inherited Notification(AComponent, Operation);
if Operation = opRemove then
begin
if (FDataLink <> nil) and (AComponent = DataSource) then DataSource := nil;
if (FListLink <> nil) and (AComponent = ListSource) then ListSource := nil;
end;
end;
procedure TbsDBLookupControl.ProcessSearchKey(Key: Char);
var
TickCount: Integer;
S: string;
CharMsg: TMsg;
begin
if (FListField <> nil) and (FListField.FieldKind in [fkData, fkInternalCalc]) and
(FListField.DataType in [ftString, ftWideString]) then
case Key of
#8, #27: SearchText := '';
#32..#255:
if CanModify then
begin
TickCount := GetTickCount;
if TickCount - SearchTickCount > 2000 then SearchText := '';
SearchTickCount := TickCount;
if SysLocale.FarEast and (Key in LeadBytes) then
if PeekMessage(CharMsg, Handle, WM_CHAR, WM_CHAR, PM_REMOVE) then
begin
if CharMsg.Message = WM_Quit then
begin
PostQuitMessage(CharMsg.wparam);
Exit;
end;
SearchText := SearchText + Key;
Key := Char(CharMsg.wParam);
end;
if Length(SearchText) < 32 then
begin
S := SearchText + Key;
try
if FListLink.DataSet.Locate(FListField.FieldName, S,
[loCaseInsensitive, loPartialKey]) then
begin
SelectKeyValue(FKeyField.Value);
SearchText := S;
end;
except
{ If you attempt to search for a string larger than what the field
can hold, and exception will be raised. Just trap it and
reset the SearchText back to the old value. }
SearchText := S;
end;
end;
end;
end;
end;
procedure TbsDBLookupControl.SelectKeyValue(const Value: Variant);
begin
if FMasterField <> nil then
begin
if FDataLink.Edit then
FMasterField.Value := Value;
end else
SetKeyValue(Value);
Repaint;
Click;
end;
procedure TbsDBLookupControl.SetDataFieldName(const Value: string);
begin
if FDataFieldName <> Value then
begin
FDataFieldName := Value;
UpdateDataFields;
end;
end;
procedure TbsDBLookupControl.SetDataSource(Value: TDataSource);
begin
if not (FDataLink.DataSourceFixed and (csLoading in ComponentState)) then
FDataLink.DataSource := Value;
if Value <> nil then Value.FreeNotification(Self);
end;
procedure TbsDBLookupControl.SetKeyFieldName(const Value: string);
begin
CheckNotLookup;
if FKeyFieldName <> Value then
begin
FKeyFieldName := Value;
UpdateListFields;
end;
end;
procedure TbsDBLookupControl.SetKeyValue(const Value: Variant);
begin
if not VarEquals(FKeyValue, Value) then
begin
FKeyValue := Value;
KeyValueChanged;
end;
end;
procedure TbsDBLookupControl.SetListFieldName(const Value: string);
begin
if FListFieldName <> Value then
begin
FListFieldName := Value;
UpdateListFields;
end;
end;
procedure TbsDBLookupControl.SetListSource(Value: TDataSource);
begin
CheckNotLookup;
FListLink.DataSource := Value;
if Value <> nil then Value.FreeNotification(Self);
end;
procedure TbsDBLookupControl.SetLookupMode(Value: Boolean);
begin
if FLookupMode <> Value then
if Value then
begin
FMasterField := GetFieldProperty(FDataField.DataSet, Self, FDataField.KeyFields);
FLookupSource.DataSet := FDataField.LookupDataSet;
FKeyFieldName := FDataField.LookupKeyFields;
FLookupMode := True;
FListLink.DataSource := FLookupSource;
end else
begin
FListLink.DataSource := nil;
FLookupMode := False;
FKeyFieldName := '';
FLookupSource.DataSet := nil;
FMasterField := FDataField;
end;
end;
procedure TbsDBLookupControl.SetReadOnly(Value: Boolean);
begin
FDataLink.ReadOnly := Value;
end;
procedure TbsDBLookupControl.WMGetDlgCode(var Message: TMessage);
begin
Message.Result := DLGC_WANTARROWS or DLGC_WANTCHARS;
end;
procedure TbsDBLookupControl.WMKillFocus(var Message: TMessage);
begin
FHasFocus := False;
inherited;
Invalidate;
end;
procedure TbsDBLookupControl.WMSetFocus(var Message: TMessage);
begin
SearchText := '';
FHasFocus := True;
inherited;
Invalidate;
end;
procedure TbsDBLookupControl.CMEnabledChanged(var Message: TMessage);
begin
inherited;
Invalidate;
end;
procedure TbsDBLookupControl.CMGetDataLink(var Message: TMessage);
begin
Message.Result := Integer(FDataLink);
end;
function TbsDBLookupControl.ExecuteAction(Action: TBasicAction): Boolean;
begin
Result := inherited ExecuteAction(Action) or (FDataLink <> nil) and
FDataLink.ExecuteAction(Action);
end;
function TbsDBLookupControl.UpdateAction(Action: TBasicAction): Boolean;
begin
Result := inherited UpdateAction(Action) or (FDataLink <> nil) and
FDataLink.UpdateAction(Action);
end;
procedure TbsDBLookupControl.WMKeyDown(var Message: TWMKeyDown);
begin
if (FNullValueKey <> 0) and CanModify and (FNullValueKey = ShortCut(Message.CharCode,
KeyDataToShiftState(Message.KeyData))) then
begin
FDataLink.Edit;
Field.Clear;
Message.CharCode := 0;
end;
inherited;
end;
{ TbsSkinDBLookupListBox }
constructor TbsSkinDBLookupListBox.Create(AOwner: TComponent);
begin
inherited Create(AOwner);
ControlStyle := ControlStyle + [csDoubleClicks];
FSkinDataName := 'listbox';
FDefaultItemHeight := 20;
FScrollBar := nil;
FStopThumbScroll := False;
Width := 100;
FRowCount := 7;
end;
destructor TbsSkinDBLookupListBox.Destroy;
begin
inherited;
end;
procedure TbsSkinDBLookupListBox.ShowScrollBar;
begin
if FScrollBar = nil
then
begin
FScrollBar := TbsSkinScrollBar.Create(Self);
FScrollBar.Kind := sbVertical;
FScrollBar.Kind := sbVertical;
if FIndex <> -1
then
FScrollBar.SkinDataName := ScrollBarName;
FScrollBar.SkinData := SkinData;
FScrollBar.Parent := Self;
FScrollBar.DefaultWidth := 19;
FScrollBar.OnChange := OnScrollBarChange;
FScrollBar.OnUpButtonClick := OnScrollBarUpButtonClick;
FScrollBar.OnDownButtonClick := OnScrollBarDownButtonClick;
AlignScrollBar;
RePaint;
end;
end;
procedure TbsSkinDBLookupListBox.HideScrollBar;
begin
if FScrollBar <> nil
then
begin
FScrollBar.Visible := False;
FScrollBar.Free;
FScrollBar := nil;
RePaint;
end;
end;
type
TXScrollBar = class(TBsSkinScrollBar);
procedure TbsSkinDBLookupListBox.OnScrollBarUpButtonClick;
begin
FStopThumbScroll := True;
SendMessage(Handle, WM_VSCROLL,
MakeWParam(SB_LINEDOWN, FScrollBar.Position), 0);
end;
procedure TbsSkinDBLookupListBox.OnScrollBarDownButtonClick(Sender: TObject);
begin
FStopThumbScroll := True;
SendMessage(Handle, WM_VSCROLL,
MakeWParam(SB_LINEUP, FScrollBar.Position), 0);
end;
procedure TbsSkinDBLookupListBox.OnScrollBarChange;
begin
if not FStopThumbScroll then
SendMessage(Handle, WM_VSCROLL,
MakeWParam(SB_THUMBPOSITION, FScrollBar.Position), 0);
FStopThumbScroll := False;
end;
procedure TbsSkinDBLookupListBox.AlignScrollBar;
begin
if FScrollBar <> nil
then
FScrollBar.SetBounds(ClientWidth - FScrollBar.Width, 0,
FScrollBar.Width, ClientHeight);
end;
procedure TbsSkinDBLookupListBox.ChangeSkinData;
begin
inherited;
if FScrollBar <> nil
then
begin
if FIndex <> -1
then
begin
FScrollBar.SkinDataName := ScrollBarName;
FScrollBar.SkinData := SkinData;
end
else
begin
FScrollBar.SkinDataName := '';
FScrollBar.ChangeSkinData;
end;
end;
SetBounds(Left, Top, Width, Height);
SendMessage(Handle, WM_NCPAINT, 0, 0);
end;
function TbsSkinDBLookupListBox.GetItemHeight;
begin
if FIndex = -1
then
Result := FDefaultItemHeight
else
Result := RectHeight(SItemRect);
end;
function TbsSkinDBLookupListBox.GetItemWidth;
begin
Result := ClientWidth;
if FScrollBar <> nil
then
Result := Result - FScrollBar.Width;
end;
function TbsSkinDBLookupListBox.GetBorderHeight;
begin
if FIndex = -1
then
Result := 4
else
Result := RectHeight(SkinRect) - RectHeight(ClRect);
end;
procedure TbsSkinDBLookupListBox.GetSkinData;
begin
inherited;
if FIndex <> -1
then
if TbsDataSkinControl(FSD.CtrlList.Items[FIndex]) is TbsDataSkinListBox
then
with TbsDataSkinListBox(FSD.CtrlList.Items[FIndex]) do
begin
Self.FontName := FontName;
Self.FontStyle := FontStyle;
Self.FontHeight := FontHeight;
Self.SItemRect := SItemRect;
Self.ActiveItemRect := ActiveItemRect;
if isNullRect(ActiveItemRect)
then
Self.ActiveItemRect := SItemRect;
Self.FocusItemRect := FocusItemRect;
if isNullRect(FocusItemRect)
then
Self.FocusItemRect := SItemRect;
Self.ItemLeftOffset := ItemLeftOffset;
Self.ItemRightOffset := ItemRightOffset;
Self.ItemTextRect := ItemTextRect;
Self.FontColor := FontColor;
Self.ActiveFontColor := ActiveFontColor;
Self.FocusFontColor := FocusFontColor;
//
Self.ScrollBarName := VScrollBarName;
end;
end;
procedure TbsSkinDBLookupListBox.WMNCCALCSIZE;
begin
GetSkinData;
if FIndex = -1
then
with Message.CalcSize_Params^.rgrc[0] do
begin
Inc(Left, 2);
Inc(Top, 2);
Dec(Right, 2);
Dec(Bottom, 2);
end
else
with Message.CalcSize_Params^.rgrc[0] do
begin
Inc(Left, ClRect.Left);
Inc(Top, ClRect.Top);
Dec(Right, RectWidth(SkinRect) - ClRect.Right);
Dec(Bottom, RectHeight(SkinRect) - ClRect.Bottom);
end;
end;
procedure TbsSkinDBLookupListBox.FramePaint(C: TCanvas);
var
R: TRect;
LeftB, TopB, RightB, BottomB: TBitMap;
OffX, OffY: Integer;
begin
GetSkinData;
if FIndex = -1
then
with C do
begin
Brush.Style := bsClear;
Pen.Color := clBtnFace;
Rectangle(1, 1, Width-1, Height-1);
R := Rect(0, 0, Width, Height);
Frame3D(C, R, clBtnShadow, clBtnShadow, 1);
Exit;
end;
LeftB := TBitMap.Create;
TopB := TBitMap.Create;
RightB := TBitMap.Create;
BottomB := TBitMap.Create;
OffX := Width - RectWidth(SkinRect);
OffY := Height - RectHeight(SkinRect);
CreateSkinBorderImages(LTPt, RTPt, LBPt, RBPt, CLRect,
NewLtPoint, NewRTPoint, NewLBPoint, NewRBPoint, NewCLRect,
LeftB, TopB, RightB, BottomB, Picture, SkinRect, Width, Height);
C.Draw(0, 0, TopB);
C.Draw(0, TopB.Height, LeftB);
C.Draw(Width - RightB.Width, TopB.Height, RightB);
C.Draw(0, Height - BottomB.Height, BottomB);
TopB.Free;
LeftB.Free;
RightB.Free;
BottomB.Free;
end;
procedure TbsSkinDBLookupListBox.WMNCPAINT;
var
DC: HDC;
C: TCanvas;
begin
DC := GetWindowDC(Handle);
C := TControlCanvas.Create;
C.Handle := DC;
try
FramePaint(C);
finally
C.Free;
ReleaseDC(Handle, DC);
end;
end;
procedure TbsSkinDBLookupListBox.SetDefaultItemHeight;
begin
if Value > 0
then
begin
FDefaultItemHeight := Value;
if FIndex = -1
then
SetBounds(Left, Top, Width, Height);
end;
end;
procedure TbsSkinDBLookupListBox.CreateParams(var Params: TCreateParams);
begin
inherited CreateParams(Params);
end;
procedure TbsSkinDBLookupListBox.CreateWnd;
begin
inherited CreateWnd;
UpdateScrollBar;
end;
function TbsSkinDBLookupListBox.GetKeyIndex: Integer;
var
FieldValue: Variant;
begin
if not VarIsNull(FKeyValue) then
for Result := 0 to FRecordCount - 1 do
begin
ListLink.ActiveRecord := Result;
FieldValue := FKeyField.Value;
ListLink.ActiveRecord := FRecordIndex;
if VarEquals(FieldValue, FKeyValue) then Exit;
end;
Result := -1;
end;
procedure TbsSkinDBLookupListBox.KeyDown(var Key: Word; Shift: TShiftState);
var
Delta, KeyIndex: Integer;
begin
inherited KeyDown(Key, Shift);
if CanModify then
begin
Delta := 0;
case Key of
VK_UP, VK_LEFT: Delta := -1;
VK_DOWN, VK_RIGHT: Delta := 1;
VK_PRIOR: Delta := 1 - FRowCount;
VK_NEXT: Delta := FRowCount - 1;
VK_HOME: Delta := -Maxint;
VK_END: Delta := Maxint;
end;
if Delta <> 0 then
begin
SearchText := '';
if Delta = -Maxint then ListLink.DataSet.First else
if Delta = Maxint then ListLink.DataSet.Last else
begin
KeyIndex := GetKeyIndex;
if KeyIndex >= 0 then
ListLink.DataSet.MoveBy(KeyIndex - FRecordIndex)
else
begin
KeyValueChanged;
Delta := 0;
end;
ListLink.DataSet.MoveBy(Delta);
end;
SelectCurrent;
end;
end;
end;
procedure TbsSkinDBLookupListBox.KeyPress(var Key: Char);
begin
inherited KeyPress(Key);
ProcessSearchKey(Key);
end;
procedure TbsSkinDBLookupListBox.KeyValueChanged;
begin
if ListActive and not FLockPosition then
if not LocateKey then ListLink.DataSet.First;
if FListField <> nil then
FSelectedItem := FListField.DisplayText else
FSelectedItem := '';
end;
procedure TbsSkinDBLookupListBox.UpdateListFields;
begin
try
inherited;
finally
if ListActive then KeyValueChanged else ListLinkDataChanged;
end;
end;
procedure TbsSkinDBLookupListBox.ListLinkDataChanged;
begin
if ListActive then
begin
FRecordIndex := ListLink.ActiveRecord;
FRecordCount := ListLink.RecordCount;
FKeySelected := not VarIsNull(FKeyValue) or
not ListLink.DataSet.BOF;
end else
begin
FRecordIndex := 0;
FRecordCount := 0;
FKeySelected := False;
end;
if HandleAllocated then
begin
UpdateScrollBar;
Invalidate;
end;
end;
procedure TbsSkinDBLookupListBox.MouseDown(Button: TMouseButton; Shift: TShiftState;
X, Y: Integer);
begin
if Button = mbLeft then
begin
SearchText := '';
if not FPopup then
begin
SetFocus;
if not HasFocus then Exit;
end;
if CanModify then
if ssDouble in Shift then
begin
if FRecordIndex = Y div GetItemHeight then DblClick;
end else
begin
MouseCapture := True;
FTracking := True;
SelectItemAt(X, Y);
end;
end;
inherited MouseDown(Button, Shift, X, Y);
end;
procedure TbsSkinDBLookupListBox.MouseMove(Shift: TShiftState; X, Y: Integer);
begin
if FTracking then
begin
SelectItemAt(X, Y);
FMousePos := Y;
TimerScroll;
end;
inherited MouseMove(Shift, X, Y);
end;
procedure TbsSkinDBLookupListBox.MouseUp(Button: TMouseButton; Shift: TShiftState;
X, Y: Integer);
begin
if FTracking then
begin
StopTracking;
SelectItemAt(X, Y);
end;
inherited MouseUp(Button, Shift, X, Y);
end;
procedure TbsSkinDBLookupListBox.CreateControlDefaultImage(B: TBitMap);
procedure DrawDefaultItem(R: TRect; ASelected, AFocused: Boolean;
S: String);
begin
if ASelected
then
with B.Canvas do
begin
Brush.Style := bsSolid;
Brush.Color := clHighLight;
FillRect(R);
Brush.Style := bsClear;
Font.Color := clHighLightText;
end
else
B.Canvas.Font.Color := DefaultFont.Color;
//
InflateRect(R, -2, -2);
SPDrawText2(B.Canvas, S, R);
InflateRect(R, 2, 2);
//
if AFocused
then
B.Canvas.DrawFocusRect(R);
end;
var
I, J, LastFieldIndex: Integer;
R: TRect;
Selected: Boolean;
Field: TField;
S: String;
W, TextWidth: Integer;
begin
inherited;
B.Width := GetItemWidth;
with B.Canvas do
begin
Brush.Style := bsSolid;
Brush.Color := clWindow;
FillRect(ClientRect);
Font := FDefaultFont;
Brush.Style := bsClear;
end;
TextWidth := B.Canvas.TextWidth('0');
R.Left := 0;
R.Right := B.Width;
LastFieldIndex := ListFields.Count - 1;
for I := 0 to FRowCount - 1 do
begin
Selected := not FKeySelected and (I = 0);
R.Top := I * GetItemHeight;
R.Bottom := R.Top + GetItemHeight;
if I < FRecordCount then
begin
ListLink.ActiveRecord := I;
if not VarIsNull(FKeyValue) and
VarEquals(FKeyField.Value, FKeyValue)
then
Selected := True;
if LastFieldIndex = 0
then
begin
Field := ListFields[0];
DrawDefaultItem(R, Selected, Selected and (HasFocus or FPopup), Field.DisplayText);
end
else
begin
R.Left := 0;
R.Right := 0;
for J := 0 to LastFieldIndex do
begin
Field := ListFields[J];
W := Field.DisplayWidth * TextWidth + 4;
R.Right := R.Left + W;
if R.Right > B.Width then R.Right := B.Width;
if (J = LastFieldIndex) and (R.Right < B.Width)
then R.Right := B.Width;
if RectWidth(R) > 0
then
DrawDefaultItem(R, Selected, Selected and (HasFocus or FPopup), Field.DisplayText);
R.Left := R.Right;
end;
end;
end;
end;
if FRecordCount <> 0 then ListLink.ActiveRecord := FRecordIndex;
end;
procedure TbsSkinDBLookupListBox.CreateControlSkinImage(B: TBitMap);
procedure DrawSkinItem(R: TRect; ASelected, AFocused: Boolean;
S: String);
var
Buffer: TBitMap;
TR: TRect;
begin
if AFocused or ASelected
then
begin
Buffer := TBitMap.Create;
with Buffer.Canvas do
begin
Font.Name := FontName;
Font.Height := FontHeight;
Font.Style := FontStyle;
if AFocused
then Font.Color := FocusFontColor
else Font.Color := ActiveFontColor;
Brush.Style := bsClear;
end;
if AFocused
then
CreateHSkinImage(ItemLeftOffset, ItemRightOffset, Buffer, Picture,
FocusItemRect, RectWidth(R), RectHeight(R))
else
CreateHSkinImage(ItemLeftOffset, ItemRightOffset, Buffer, Picture,
ActiveItemRect, RectWidth(R), RectHeight(R));
TR := ItemTextRect;
Inc(TR.Right, Buffer.Width - RectWidth(SItemRect));
SPDrawText2(Buffer.Canvas, S, TR);
B.Canvas.Draw(R.Left, R.Top, Buffer);
Buffer.Free;
end
else
begin
InflateRect(R, -2, -2);
SPDrawText2(B.Canvas, S, R);
end;
end;
procedure PaintBG;
var
w, h, rw, rh, XCnt, YCnt, X, Y, XO, YO: Integer;
begin
w := RectWidth(ClRect);
h := RectHeight(ClRect);
rw := B.Width;
rh := B.Height;
with B.Canvas do
begin
XCnt := rw div w;
YCnt := rh div h;
for X := 0 to XCnt do
for Y := 0 to YCnt do
begin
if X * w + w > rw then XO := X * W + W - rw else XO := 0;
if Y * h + h > rh then YO := Y * h + h - rh else YO := 0;
CopyRect(Rect(X * w, Y * h,X * w + w - XO, Y * h + h - YO),
Picture.Canvas,
Rect(SkinRect.Left + ClRect.Left,
SkinRect.Top + ClRect.Top,
SkinRect.Left + ClRect.Right - XO,
SkinRect.Top + ClRect.Bottom - YO));
end;
end;
end;
var
I, J, LastFieldIndex: Integer;
R: TRect;
Selected: Boolean;
Field: TField;
W, TextWidth: Integer;
begin
B.Width := GetItemWidth;
with B.Canvas do
begin
Font.Name := FontName;
Font.Height := FontHeight;
Font.Style := FontStyle;
Font.Color := FontColor;
Brush.Style := bsClear;
end;
TextWidth := B.Canvas.TextWidth('0');
if not IsNullRect(ClRect) and (ClientWidth > 0) and (ClientHeight > 0)
then
PaintBG;
R.Left := 0;
R.Right := B.Width;
LastFieldIndex := ListFields.Count - 1;
for I := 0 to FRowCount - 1 do
begin
Selected := not FKeySelected and (I = 0);
R.Top := I * GetItemHeight;
R.Bottom := R.Top + GetItemHeight;
if I < FRecordCount then
begin
ListLink.ActiveRecord := I;
if not VarIsNull(FKeyValue) and
VarEquals(FKeyField.Value, FKeyValue)
then
Selected := True;
//
if LastFieldIndex = 0
then
begin
Field := ListFields[0];
DrawSkinItem(R, Selected, Selected and (HasFocus or FPopup), Field.DisplayText);
end
else
begin
R.Left := 0;
R.Right := 0;
for J := 0 to LastFieldIndex do
begin
Field := ListFields[J];
W := Field.DisplayWidth * TextWidth + RectWidth(SItemRect) -
RectWidth(ItemTextRect);
R.Right := R.Left + W;
if R.Right > B.Width then R.Right := B.Width;
if (J = LastFieldIndex) and (R.Right < B.Width)
then R.Right := B.Width;
if RectWidth(R) > 0
then
DrawSkinItem(R, Selected, Selected and (HasFocus or FPopup), Field.DisplayText);
R.Left := R.Right;
end;
end;
end;
end;
if FRecordCount <> 0 then ListLink.ActiveRecord := FRecordIndex;
end;
procedure TbsSkinDBLookupListBox.SelectCurrent;
begin
FLockPosition := True;
try
SelectKeyValue(FKeyField.Value);
finally
FLockPosition := False;
end;
end;
procedure TbsSkinDBLookupListBox.SelectItemAt(X, Y: Integer);
var
Delta: Integer;
begin
if Y < 0 then Y := 0;
if Y > ClientHeight then Y := ClientHeight;
Delta := Y div GetItemHeight - FRecordIndex;
ListLink.DataSet.MoveBy(Delta);
SelectCurrent;
end;
procedure TbsSkinDBLookupListBox.SetBorderStyle(Value: TBorderStyle);
begin
if FBorderStyle <> Value then
begin
FBorderStyle := Value;
RecreateWnd;
RowCount := RowCount;
end;
end;
procedure TbsSkinDBLookupListBox.SetBounds(ALeft, ATop, AWidth, AHeight: Integer);
var
TextHeight, BorderHeight: Integer;
begin
BorderHeight := GetBorderHeight;
TextHeight := GetItemHeight;
if Align = alNone
then
inherited SetBounds(ALeft, ATop, AWidth, FRowCount * TextHeight + BorderHeight)
else
begin
FRowCount := (AHeight - BorderHeight) div TextHeight;
inherited;
end;
if ListLink.BufferCount <> FRowCount then
begin
ListLink.BufferCount := FRowCount;
ListLinkDataChanged;
end;
if HandleAllocated
then
SendMessage(Handle, WM_NCPAINT, 0, 0);
AlignScrollBar;
end;
function TbsSkinDBLookupListBox.UseRightToLeftAlignment: Boolean;
begin
Result := DBUseRightToLeftAlignment(Self, Field);
end;
procedure TbsSkinDBLookupListBox.SetRowCount(Value: Integer);
begin
if Value < 1 then Value := 1;
if Value > 100 then Value := 100;
FRowCount := Value;
Height := Value * GetItemHeight;
end;
procedure TbsSkinDBLookupListBox.StopTimer;
begin
if FTimerActive then
begin
KillTimer(Handle, 1);
FTimerActive := False;
end;
end;
procedure TbsSkinDBLookupListBox.StopTracking;
begin
if FTracking then
begin
StopTimer;
FTracking := False;
MouseCapture := False;
end;
end;
procedure TbsSkinDBLookupListBox.TimerScroll;
var
Delta, Distance, Interval: Integer;
begin
Delta := 0;
Distance := 0;
if FMousePos < 0 then
begin
Delta := -1;
Distance := -FMousePos;
end;
if FMousePos >= ClientHeight then
begin
Delta := 1;
Distance := FMousePos - ClientHeight + 1;
end;
if Delta = 0 then StopTimer else
begin
if ListLink.DataSet.MoveBy(Delta) <> 0 then SelectCurrent;
Interval := 200 - Distance * 15;
if Interval < 0 then Interval := 0;
SetTimer(Handle, 1, Interval, nil);
FTimerActive := True;
end;
end;
procedure TbsSkinDBLookupListBox.UpdateScrollBar;
var
Pos, Max: Integer;
ScrollInfo: TScrollInfo;
begin
Pos := 0;
Max := 0;
if (FRowCount <> FRecordCount) or (KeyField = '') or
(ListLink.DataSet = nil)
then HideScrollBar
else ShowScrollBar;
if (FScrollBar <> nil)
then
begin
if FRecordCount = FRowCount then
begin
Max := 4;
if not ListLink.DataSet.BOF then
if not ListLink.DataSet.EOF then Pos := 2 else Pos := 4;
end;
FScrollBar.SetRange(0, Max, Pos, 0);
end;
end;
procedure TbsSkinDBLookupListBox.CMFontChanged(var Message: TMessage);
begin
inherited;
Height := Height;
end;
procedure TbsSkinDBLookupListBox.WMCancelMode(var Message: TMessage);
begin
StopTracking;
inherited;
end;
procedure TbsSkinDBLookupListBox.WMTimer(var Message: TMessage);
begin
TimerScroll;
end;
procedure TbsSkinDBLookupListBox.WMVScroll(var Message: TWMVScroll);
begin
SearchText := '';
if ListLink.DataSet = nil then
Exit;
with Message, ListLink.DataSet do
case ScrollCode of
SB_LINEUP: MoveBy(-FRecordIndex - 1);
SB_LINEDOWN: MoveBy(FRecordCount - FRecordIndex);
SB_PAGEUP: MoveBy(-FRecordIndex - FRecordCount + 1);
SB_PAGEDOWN: MoveBy(FRecordCount - FRecordIndex + FRecordCount - 2);
SB_THUMBPOSITION:
begin
case Pos of
0: First;
1: MoveBy(-FRecordIndex - FRecordCount + 1);
2: Exit;
3: MoveBy(FRecordCount - FRecordIndex + FRecordCount - 2);
4: Last;
end;
end;
SB_BOTTOM: Last;
SB_TOP: First;
end;
end;
function TbsSkinDBLookupListBox.ExecuteAction(Action: TBasicAction): Boolean;
begin
Result := inherited ExecuteAction(Action) or (FDataLink <> nil) and
FDataLink.ExecuteAction(Action);
end;
function TbsSkinDBLookupListBox.UpdateAction(Action: TBasicAction): Boolean;
begin
Result := inherited UpdateAction(Action) or (FDataLink <> nil) and
FDataLink.UpdateAction(Action);
end;
{ TbsPopupDataList }
constructor TbsPopupDataList.Create(AOwner: TComponent);
begin
inherited Create(AOwner);
ControlStyle := ControlStyle + [csNoDesignVisible, csReplicatable];
FPopup := True;
end;
procedure TbsPopupDataList.CreateParams(var Params: TCreateParams);
begin
inherited CreateParams(Params);
with Params do
begin
Style := WS_POPUP;
ExStyle := WS_EX_TOOLWINDOW;
AddBiDiModeExStyle(ExStyle);
WindowClass.Style := CS_SAVEBITS;
end;
end;
procedure TbsPopupDataList.WMMouseActivate(var Message: TMessage);
begin
Message.Result := MA_NOACTIVATE;
end;
{ TbsSkinDBLookupComboBox }
constructor TbsSkinDBLookupComboBox.Create(AOwner: TComponent);
begin
inherited Create(AOwner);
ControlStyle := ControlStyle + [csReplicatable];
Width := 145;
Height := 20;
FDataList := TbsPopupDataList.Create(Self);
FDataList.Visible := False;
FDataList.TabStop := False;
FDataList.Parent := Self;
FDataList.OnMouseUp := ListMouseUp;
FButtonWidth := 17;
FDropDownRows := 7;
FDefaultHeight := 20;
FSkinDataName := 'combobox';
end;
procedure TbsSkinDBLookupComboBox.GetSkinData;
begin
inherited;
if FIndex <> -1
then
if TbsDataSkinControl(FSD.CtrlList.Items[FIndex]) is TbsDataSkinComboBox
then
with TbsDataSkinComboBox(FSD.CtrlList.Items[FIndex]) do
begin
Self.SItemRect := SItemRect;
Self.FocusItemRect := FocusItemRect;
if isNullRect(FocusItemRect)
then
Self.FocusItemRect := SItemRect;
Self.ItemLeftOffset := ItemLeftOffset;
Self.ItemRightOffset := ItemRightOffset;
Self.ItemTextRect := ItemTextRect;
Self.FontName := FontName;
Self.FontStyle := FontStyle;
Self.FontHeight := FontHeight;
Self.FontColor := FontColor;
Self.FocusFontColor := FocusFontColor;
Self.ButtonRect := ButtonRect;
Self.ActiveButtonRect := ActiveButtonRect;
Self.DownButtonRect := DownButtonRect;
Self.ListBoxName := ListBoxName;
end;
end;
procedure TbsSkinDBLookupComboBox.CloseUp(Accept: Boolean);
var
ListValue: Variant;
begin
if FListVisible then
begin
if GetCapture <> 0 then SendMessage(GetCapture, WM_CANCELMODE, 0, 0);
SetFocus;
ListValue := FDataList.KeyValue;
SetWindowPos(FDataList.Handle, 0, 0, 0, 0, 0, SWP_NOZORDER or
SWP_NOMOVE or SWP_NOSIZE or SWP_NOACTIVATE or SWP_HIDEWINDOW);
FListVisible := False;
FDataList.ListSource := nil;
Invalidate;
SearchText := '';
if Accept and CanModify then SelectKeyValue(ListValue);
if Assigned(FOnCloseUp) then FOnCloseUp(Self);
end;
end;
procedure TbsSkinDBLookupComboBox.CMDialogKey(var Message: TCMDialogKey);
begin
if (Message.CharCode in [VK_RETURN, VK_ESCAPE]) and FListVisible then
begin
CloseUp(Message.CharCode = VK_RETURN);
Message.Result := 1;
end else
inherited;
end;
procedure TbsSkinDBLookupComboBox.CreateParams(var Params: TCreateParams);
begin
inherited CreateParams(Params);
end;
procedure TbsSkinDBLookupComboBox.DropDown;
var
P: TPoint;
I, Y: Integer;
S: string;
ADropDownAlign: TDropDownAlign;
begin
if not FListVisible and ListActive then
begin
if Assigned(FOnDropDown) then FOnDropDown(Self);
if FDropDownWidth > 0 then
FDataList.Width := FDropDownWidth else
FDataList.Width := Width;
FDataList.ReadOnly := not CanModify;
if (ListLink.DataSet.RecordCount > 0) and
(FDropDownRows > ListLink.DataSet.RecordCount) then
FDataList.RowCount := ListLink.DataSet.RecordCount else
FDataList.RowCount := FDropDownRows;
FDataList.KeyField := FKeyFieldName;
for I := 0 to ListFields.Count - 1 do
S := S + TField(ListFields[I]).FieldName + ';';
FDataList.ListField := S;
FDataList.ListFieldIndex := ListFields.IndexOf(FListField);
FDataList.ListSource := ListLink.DataSource;
FDataList.KeyValue := KeyValue;
P := Parent.ClientToScreen(Point(Left, Top));
Y := P.Y + Height;
if Y + FDataList.Height > Screen.Height then Y := P.Y - FDataList.Height;
ADropDownAlign := FDropDownAlign;
{ This alignment is for the ListField, not the control }
if DBUseRightToLeftAlignment(Self, FListField) then
begin
if ADropDownAlign = daLeft then
ADropDownAlign := daRight
else if ADropDownAlign = daRight then
ADropDownAlign := daLeft;
end;
case ADropDownAlign of
daRight: Dec(P.X, FDataList.Width - Width);
daCenter: Dec(P.X, (FDataList.Width - Width) div 2);
end;
if FIndex = -1
then
begin
FDataList.DefaultFont := DefaultFont;
FDataList.DefaultItemHeight := Height - 2;
FDataList.SkinDataName := ''
end
else
FDataList.SkinDataName := ListBoxName;
FDataList.SkinData := SkinData;
SetWindowPos(FDataList.Handle, HWND_TOP, P.X, Y, 0, 0,
SWP_NOSIZE or SWP_NOACTIVATE or SWP_SHOWWINDOW);
FListVisible := True;
FDataList.Visible := True;
Repaint;
end;
end;
procedure TbsSkinDBLookupComboBox.KeyDown(var Key: Word; Shift: TShiftState);
var
Delta: Integer;
begin
inherited KeyDown(Key, Shift);
if ListActive and ((Key = VK_UP) or (Key = VK_DOWN)) then
if ssAlt in Shift then
begin
if FListVisible then CloseUp(True) else DropDown;
Key := 0;
end else
if not FListVisible then
begin
if not LocateKey then
ListLink.DataSet.First
else
begin
if Key = VK_UP then Delta := -1 else Delta := 1;
ListLink.DataSet.MoveBy(Delta);
end;
SelectKeyValue(FKeyField.Value);
Key := 0;
end;
if (Key <> 0) and FListVisible then FDataList.KeyDown(Key, Shift);
end;
procedure TbsSkinDBLookupComboBox.KeyPress(var Key: Char);
begin
inherited KeyPress(Key);
if FListVisible then
if Key in [#13, #27] then
CloseUp(Key = #13)
else
FDataList.KeyPress(Key)
else
ProcessSearchKey(Key);
end;
procedure TbsSkinDBLookupComboBox.KeyValueChanged;
begin
if FLookupMode then
begin
FText := FDataField.DisplayText;
FAlignment := FDataField.Alignment;
end else
if ListActive and LocateKey then
begin
FText := FListField.DisplayText;
FAlignment := FListField.Alignment;
end else
begin
FText := '';
FAlignment := taLeftJustify;
end;
Invalidate;
end;
procedure TbsSkinDBLookupComboBox.UpdateListFields;
begin
inherited;
KeyValueChanged;
end;
procedure TbsSkinDBLookupComboBox.ListMouseUp(Sender: TObject; Button: TMouseButton;
Shift: TShiftState; X, Y: Integer);
begin
if Button = mbLeft then
CloseUp(PtInRect(FDataList.ClientRect, Point(X, Y)));
end;
procedure TbsSkinDBLookupComboBox.MouseDown(Button: TMouseButton; Shift: TShiftState;
X, Y: Integer);
begin
if Button = mbLeft then
begin
SetFocus;
if not HasFocus then Exit;
if FListVisible then CloseUp(False) else
if ListActive then
begin
MouseCapture := True;
FTracking := True;
TrackButton(X, Y);
DropDown;
end;
end;
inherited MouseDown(Button, Shift, X, Y);
end;
procedure TbsSkinDBLookupComboBox.MouseMove(Shift: TShiftState; X, Y: Integer);
var
ListPos: TPoint;
MousePos: TSmallPoint;
begin
if FTracking then
begin
TrackButton(X, Y);
if FListVisible then
begin
ListPos := FDataList.ScreenToClient(ClientToScreen(Point(X, Y)));
if PtInRect(FDataList.ClientRect, ListPos) then
begin
StopTracking;
MousePos := PointToSmallPoint(ListPos);
SendMessage(FDataList.Handle, WM_LBUTTONDOWN, 0, Integer(MousePos));
Exit;
end;
end;
end;
inherited MouseMove(Shift, X, Y);
end;
procedure TbsSkinDBLookupComboBox.MouseUp(Button: TMouseButton; Shift: TShiftState;
X, Y: Integer);
begin
StopTracking;
inherited MouseUp(Button, Shift, X, Y);
end;
procedure TbsSkinDBLookupComboBox.CreateControlSkinImage;
var
OX: Integer;
Text: string;
Selected: Boolean;
R: TRect;
TX, TY: Integer;
Buffer: TBitMap;
begin
inherited;
with B.Canvas do
begin
Brush.Style := bsClear;
Font.Name := FontName;
Font.Style := FontStyle;
Font.Height := FontHeight;
Font.Color := FontColor;
end;
// calc rects
OX := Width - RectWidth(SkinRect);
FButtonRect := ButtonRect;
if ButtonRect.Left >= RectWidth(SkinRect) - RTPt.X
then
OffsetRect(FButtonRect, OX, 0);
FItemRect := ClRect;
Inc(FItemRect.Right, OX);
// draw button
if FPressed and not IsNullRect(DownButtonRect)
then
B.Canvas.CopyRect(FButtonRect, Picture.Canvas, DownButtonRect);
// draw item
if (csPaintCopy in ControlState) and (FDataField <> nil) and
(FDataField.Lookup)
then
Text := FDataField.DisplayText
else
begin
if (csDesigning in ComponentState) and (FDataField = nil) then
Text := Name else
Text := FText;
end;
Selected := HasFocus and not FListVisible and
not (csPaintCopy in ControlState);
if Selected and not IsNullRect(FocusItemRect)
then
begin
Buffer := TBitMap.Create;
if not IsNullRect(FocusItemRect)
then
CreateHSkinImage(ItemLeftOffset, ItemRightOffset, Buffer, Picture,
FocusItemRect, RectWidth(FItemRect), RectHeight(FocusItemRect));
B.Canvas.Draw(FItemRect.Left, FItemRect.Top, Buffer);
Buffer.Free;
R := ItemTextRect;
Inc(R.Right, RectWidth(FItemRect) - RectWidth(FocusItemRect));
OffsetRect(R, FItemRect.Left, FItemRect.Top);
B.Canvas.Font.Color := FocusFontColor;
end
else
R := FItemRect;
TX := R.Left + 2;
TY := R.Top + RectHeight(R) div 2 - B.Canvas.TextHeight(Text) div 2;
B.Canvas.TextRect(R, TX, TY, Text);
end;
procedure TbsSkinDBLookupComboBox.CreateControlDefaultImage;
var
W, X, Flags: Integer;
Text: string;
Selected: Boolean;
R: TRect;
TX, TY: Integer;
begin
with B.Canvas do
begin
Brush.Color := clBtnFace;
Brush.Style := bsSolid;
R := ClientRect;
FillRect(R);
Font := DefaultFont;
end;
// frame
Frame3D(B.Canvas, R, clbtnShadow, clbtnShadow, 1);
// button
R := Rect(Width - 2 - FButtonWidth, 2, Width - 2, Height - 2);
if FPressed
then
begin
Frame3D(B.Canvas, R, BS_XP_BTNFRAMECOLOR, BS_XP_BTNFRAMECOLOR, 1);
B.Canvas.Brush.Color := BS_XP_BTNDOWNCOLOR;
B.Canvas.FillRect(R);
end
else
Frame3D(B.Canvas, R, clbtnShadow, clbtnShadow, 1);
DrawArrowImage(B.Canvas, R, clBtnText, 4);
// item
if (csPaintCopy in ControlState) and (FDataField <> nil) and
(FDataField.Lookup)
then
Text := FDataField.DisplayText
else
begin
if (csDesigning in ComponentState) and (FDataField = nil) then
Text := Name else
Text := FText;
end;
Selected := HasFocus and not FListVisible and
not (csPaintCopy in ControlState);
if Enabled then
B.Canvas.Font.Color := Font.Color
else
B.Canvas.Font.Color := clGrayText;
if Selected
then
begin
B.Canvas.Font.Color := clHighlightText;
B.Canvas.Brush.Color := clHighlight;
end
else
B.Canvas.Brush.Color := clWindow;
TX := 4;
TY := Height div 2 - B.Canvas.TextHeight(Text) div 2;
R := Rect(2, 2, Width - 2 - FButtonWidth, Height - 2);
B.Canvas.TextRect(R, TX, TY, Text);
if Selected then B.Canvas.DrawFocusRect(R);
end;
procedure TbsSkinDBLookupComboBox.SetBounds(ALeft, ATop, AWidth, AHeight: Integer);
begin
inherited;
end;
function TbsSkinDBLookupComboBox.UseRightToLeftAlignment: Boolean;
begin
Result := DBUseRightToLeftAlignment(Self, Field);
end;
procedure TbsSkinDBLookupComboBox.StopTracking;
begin
if FTracking then
begin
TrackButton(-1, -1);
FTracking := False;
MouseCapture := False;
end;
end;
procedure TbsSkinDBLookupComboBox.TrackButton(X, Y: Integer);
var
NewState: Boolean;
BR: TRect;
begin
if FIndex = -1
then
NewState := PtInRect(Rect(ClientWidth - FButtonWidth - 2, 2, ClientWidth - 2,
ClientHeight - 2), Point(X, Y))
else
begin
BR := FButtonRect;
Inc(BR.Right);
Inc(BR.Bottom);
NewState := PtInRect(BR, Point(X, Y));
end;
if FPressed <> NewState then
begin
FPressed := NewState;
Repaint;
end;
end;
procedure TbsSkinDBLookupComboBox.CMCancelMode(var Message: TCMCancelMode);
begin
if (Message.Sender <> Self) and (Message.Sender <> FDataList) and
(Message.Sender <> FDataList.FScrollBar)
then
CloseUp(False);
end;
procedure TbsSkinDBLookupComboBox.CMFontChanged(var Message: TMessage);
begin
inherited;
end;
procedure TbsSkinDBLookupComboBox.CMGetDataLink(var Message: TMessage);
begin
Message.Result := Integer(FDataLink);
end;
procedure TbsSkinDBLookupComboBox.WMCancelMode(var Message: TMessage);
begin
StopTracking;
inherited;
end;
procedure TbsSkinDBLookupComboBox.WMKillFocus(var Message: TWMKillFocus);
begin
inherited;
CloseUp(False);
end;
function TbsSkinDBLookupComboBox.ExecuteAction(Action: TBasicAction): Boolean;
begin
Result := inherited ExecuteAction(Action) or (FDataLink <> nil) and
FDataLink.ExecuteAction(Action);
end;
function TbsSkinDBLookupComboBox.UpdateAction(Action: TBasicAction): Boolean;
begin
Result := inherited UpdateAction(Action) or (FDataLink <> nil) and
FDataLink.UpdateAction(Action);
end;
{ TbsSkinDBRichEdit }
constructor TbsSkinDBRichEdit.Create(AOwner: TComponent);
begin
inherited Create(AOwner);
inherited ReadOnly := True;
FAutoDisplay := True;
FDataLink := TFieldDataLink.Create;
FDataLink.Control := Self;
FDataLink.OnDataChange := DataChange;
FDataLink.OnEditingChange := EditingChange;
FDataLink.OnUpdateData := UpdateData;
end;
destructor TbsSkinDBRichEdit.Destroy;
begin
FDataLink.Free;
FDataLink := nil;
inherited Destroy;
end;
procedure TbsSkinDBRichEdit.Loaded;
begin
inherited Loaded;
if (csDesigning in ComponentState) then DataChange(Self);
end;
procedure TbsSkinDBRichEdit.Notification(AComponent: TComponent;
Operation: TOperation);
begin
inherited Notification(AComponent, Operation);
if (Operation = opRemove) and (FDataLink <> nil) and
(AComponent = DataSource) then DataSource := nil;
end;
function TbsSkinDBRichEdit.UseRightToLeftAlignment: Boolean;
begin
Result := DBUseRightToLeftAlignment(Self, Field);
end;
procedure TbsSkinDBRichEdit.BeginEditing;
begin
if not FDataLink.Editing then
try
if FDataLink.Field.IsBlob then
FDataSave := FDataLink.Field.AsString;
FDataLink.Edit;
finally
FDataSave := '';
end;
end;
procedure TbsSkinDBRichEdit.KeyDown(var Key: Word; Shift: TShiftState);
begin
inherited KeyDown(Key, Shift);
if FMemoLoaded then
begin
if (Key = VK_DELETE) or (Key = VK_BACK) or
((Key = VK_INSERT) and (ssShift in Shift)) or
(((Key = Ord('V')) or (Key = Ord('X'))) and (ssCtrl in Shift)) then
BeginEditing;
end;
end;
procedure TbsSkinDBRichEdit.KeyPress(var Key: Char);
begin
inherited KeyPress(Key);
if FMemoLoaded then
begin
if (Key in [#32..#255]) and (FDataLink.Field <> nil) and
not FDataLink.Field.IsValidChar(Key) then
begin
MessageBeep(0);
Key := #0;
end;
case Key of
^H, ^I, ^J, ^M, ^V, ^X, #32..#255:
BeginEditing;
#27:
FDataLink.Reset;
end;
end else
begin
if Key = #13 then LoadMemo;
Key := #0;
end;
end;
procedure TbsSkinDBRichEdit.Change;
begin
if FMemoLoaded then FDataLink.Modified;
FMemoLoaded := True;
inherited Change;
end;
function TbsSkinDBRichEdit.GetDataSource: TDataSource;
begin
Result := FDataLink.DataSource;
end;
procedure TbsSkinDBRichEdit.SetDataSource(Value: TDataSource);
begin
FDataLink.DataSource := Value;
if Value <> nil then Value.FreeNotification(Self);
end;
function TbsSkinDBRichEdit.GetDataField: string;
begin
Result := FDataLink.FieldName;
end;
procedure TbsSkinDBRichEdit.SetDataField(const Value: string);
begin
FDataLink.FieldName := Value;
end;
function TbsSkinDBRichEdit.GetReadOnly: Boolean;
begin
Result := FDataLink.ReadOnly;
end;
procedure TbsSkinDBRichEdit.SetReadOnly(Value: Boolean);
begin
FDataLink.ReadOnly := Value;
end;
function TbsSkinDBRichEdit.GetField: TField;
begin
Result := FDataLink.Field;
end;
procedure TbsSkinDBRichEdit.LoadMemo;
begin
if not FMemoLoaded and Assigned(FDataLink.Field) and FDataLink.Field.IsBlob then
begin
try
Lines.Assign(FDataLink.Field);
FMemoLoaded := True;
except
{ Rich Edit Load failure }
on E:EOutOfResources do
Lines.Text := Format('(%s)', [E.Message]);
end;
EditingChange(Self);
end;
end;
procedure TbsSkinDBRichEdit.DataChange(Sender: TObject);
begin
if FDataLink.Field <> nil then
if FDataLink.Field.IsBlob then
begin
if FAutoDisplay or (FDataLink.Editing and FMemoLoaded) then
begin
{ Check if the data has changed since we read it the first time }
if (FDataSave <> '') and (FDataSave = FDataLink.Field.AsString) then Exit;
FMemoLoaded := False;
LoadMemo;
end else
begin
Text := Format('(%s)', [FDataLink.Field.DisplayLabel]);
FMemoLoaded := False;
end;
end else
begin
if FFocused and FDataLink.CanModify then
Text := FDataLink.Field.Text
else
Text := FDataLink.Field.DisplayText;
FMemoLoaded := True;
end
else
begin
if csDesigning in ComponentState then Text := Name else Text := '';
FMemoLoaded := False;
end;
if HandleAllocated then
RedrawWindow(Handle, nil, 0, RDW_INVALIDATE or RDW_ERASE or RDW_FRAME);
end;
procedure TbsSkinDBRichEdit.EditingChange(Sender: TObject);
begin
inherited ReadOnly := not (FDataLink.Editing and FMemoLoaded);
end;
procedure TbsSkinDBRichEdit.UpdateData(Sender: TObject);
begin
if FDataLink.Field.IsBlob then
FDataLink.Field.Assign(Lines) else
FDataLink.Field.AsString := Text;
end;
procedure TbsSkinDBRichEdit.SetFocused(Value: Boolean);
begin
if FFocused <> Value then
begin
FFocused := Value;
if not Assigned(FDataLink.Field) or not FDataLink.Field.IsBlob then
FDataLink.Reset;
end;
end;
procedure TbsSkinDBRichEdit.CMEnter(var Message: TCMEnter);
begin
SetFocused(True);
inherited;
if SysLocale.FarEast and FDataLink.CanModify then
inherited ReadOnly := False;
end;
procedure TbsSkinDBRichEdit.CMExit(var Message: TCMExit);
begin
try
FDataLink.UpdateRecord;
except
SetFocus;
raise;
end;
SetFocused(False);
inherited;
end;
procedure TbsSkinDBRichEdit.SetAutoDisplay(Value: Boolean);
begin
if FAutoDisplay <> Value then
begin
FAutoDisplay := Value;
if Value then LoadMemo;
end;
end;
procedure TbsSkinDBRichEdit.WMLButtonDblClk(var Message: TWMLButtonDblClk);
begin
if not FMemoLoaded then LoadMemo else inherited;
end;
procedure TbsSkinDBRichEdit.WMCut(var Message: TMessage);
begin
BeginEditing;
inherited;
end;
procedure TbsSkinDBRichEdit.WMPaste(var Message: TMessage);
begin
BeginEditing;
inherited;
end;
procedure TbsSkinDBRichEdit.CMGetDataLink(var Message: TMessage);
begin
Message.Result := Integer(FDataLink);
end;
function TbsSkinDBRichEdit.ExecuteAction(Action: TBasicAction): Boolean;
begin
Result := inherited ExecuteAction(Action) or (FDataLink <> nil) and
FDataLink.ExecuteAction(Action);
end;
function TbsSkinDBRichEdit.UpdateAction(Action: TBasicAction): Boolean;
begin
Result := inherited UpdateAction(Action) or (FDataLink <> nil) and
FDataLink.UpdateAction(Action);
end;
constructor TbsSkinDBCalcEdit.Create(AOwner: TComponent);
begin
inherited Create(AOwner);
ControlStyle := ControlStyle + [csReplicatable];
FDataLink := TFieldDataLink.Create;
FDataLink.Control := Self;
FDataLink.OnDataChange := DataChange;
FDataLink.OnEditingChange := EditingChange;
FDataLink.OnUpdateData := UpdateData;
FInChange := False;
FInDataChange := False;
end;
destructor TbsSkinDBCalcEdit.Destroy;
begin
FDataLink.Free;
FDataLink := nil;
inherited Destroy;
end;
procedure TbsSkinDBCalcEdit.Loaded;
begin
inherited Loaded;
if (csDesigning in ComponentState) then DataChange(Self);
end;
procedure TbsSkinDBCalcEdit.Notification(AComponent: TComponent;
Operation: TOperation);
begin
inherited Notification(AComponent, Operation);
if (Operation = opRemove) and (FDataLink <> nil) and
(AComponent = DataSource) then DataSource := nil;
end;
procedure TbsSkinDBCalcEdit.Reset;
begin
FDataLink.Reset;
SelectAll;
end;
procedure TbsSkinDBCalcEdit.Change;
begin
FInChange := True;
if not FInDataChange and (FDataLink <> nil) and
not ReadOnly and FDataLink.CanModify
then
begin
if not FDataLink.Editing then FDataLink.Edit;
FDataLink.Modified;
inherited Change;
end;
FInChange := False;
end;
function TbsSkinDBCalcEdit.GetDataSource: TDataSource;
begin
Result := FDataLink.DataSource;
end;
procedure TbsSkinDBCalcEdit.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 TbsSkinDBCalcEdit.GetDataField: string;
begin
Result := FDataLink.FieldName;
end;
procedure TbsSkinDBCalcEdit.SetDataField(const Value: string);
begin
FDataLink.FieldName := Value;
end;
function TbsSkinDBCalcEdit.GetReadOnly: Boolean;
begin
Result := FDataLink.ReadOnly;
end;
procedure TbsSkinDBCalcEdit.SetReadOnly(Value: Boolean);
begin
FDataLink.ReadOnly := Value;
end;
function TbsSkinDBCalcEdit.GetField: TField;
begin
Result := FDataLink.Field;
end;
procedure TbsSkinDBCalcEdit.DataChange(Sender: TObject);
begin
FInDataChange := True;
if not FInChange then
if FDataLink.Field <> nil
then
begin
if (FDataLink.Field.Text <> '') and
IsNumText(FDataLink.Field.Text)
then Value := StrToInt(FDataLink.Field.Text)
else Value := MinValue;
end
else
Value := MinValue;
FInDataChange := False;
end;
procedure TbsSkinDBCalcEdit.EditingChange(Sender: TObject);
begin
inherited ReadOnly := not FDataLink.Editing;
end;
procedure TbsSkinDBCalcEdit.UpdateData(Sender: TObject);
begin
FDataLink.Field.Text := Text;
end;
procedure TbsSkinDBCalcEdit.CMEnter;
begin
inherited;
inherited ReadOnly := not FDataLink.CanModify;
end;
procedure TbsSkinDBCalcEdit.CMExit;
begin
inherited;
if (FDataLink <> nil) and (FDataLink.Editing)
then
FDataLink.UpdateRecord;
end;
procedure TbsSkinDBCalcEdit.CMGetDataLink(var Message: TMessage);
begin
Message.Result := Integer(FDataLink);
end;
function TbsSkinDBCalcEdit.ExecuteAction(Action: TBasicAction): Boolean;
begin
Result := inherited ExecuteAction(Action) or (FDataLink <> nil) and
FDataLink.ExecuteAction(Action);
end;
function TbsSkinDBCalcEdit.UpdateAction(Action: TBasicAction): Boolean;
begin
Result := inherited UpdateAction(Action) or (FDataLink <> nil) and
FDataLink.UpdateAction(Action);
end;
constructor TbsSkinDBMemo2.Create(AOwner: TComponent);
begin
inherited Create(AOwner);
inherited ReadOnly := True;
ControlStyle := ControlStyle + [csReplicatable];
FAutoDisplay := True;
FDataLink := TFieldDataLink.Create;
FDataLink.Control := Self;
FDataLink.OnDataChange := DataChange;
FDataLink.OnEditingChange := EditingChange;
FDataLink.OnUpdateData := UpdateData;
end;
destructor TbsSkinDBMemo2.Destroy;
begin
FDataLink.Free;
FDataLink := nil;
inherited Destroy;
end;
procedure TbsSkinDBMemo2.Loaded;
begin
inherited Loaded;
// if (csDesigning in ComponentState) then DataChange(Self);
end;
procedure TbsSkinDBMemo2.Notification(AComponent: TComponent;
Operation: TOperation);
begin
inherited Notification(AComponent, Operation);
if (Operation = opRemove) and (FDataLink <> nil) and
(AComponent = DataSource) then DataSource := nil;
end;
function TbsSkinDBMemo2.UseRightToLeftAlignment: Boolean;
begin
Result := DBUseRightToLeftAlignment(Self, Field);
end;
procedure TbsSkinDBMemo2.KeyDown(var Key: Word; Shift: TShiftState);
begin
inherited KeyDown(Key, Shift);
if FMemoLoaded then
begin
if (Key = VK_DELETE) or ((Key = VK_INSERT) and (ssShift in Shift)) then
FDataLink.Edit;
end;
end;
procedure TbsSkinDBMemo2.KeyPress(var Key: Char);
begin
inherited KeyPress(Key);
if FMemoLoaded then
begin
if (Key in [#32..#255]) and (FDataLink.Field <> nil) and
not FDataLink.Field.IsValidChar(Key) then
begin
MessageBeep(0);
Key := #0;
end;
case Key of
^H, ^I, ^J, ^M, ^V, ^X, #32..#255:
FDataLink.Edit;
#27:
FDataLink.Reset;
end;
end else
begin
if Key = #13 then LoadMemo;
Key := #0;
end;
end;
procedure TbsSkinDBMemo2.Change;
begin
if FMemoLoaded then FDataLink.Modified;
FMemoLoaded := True;
inherited Change;
end;
function TbsSkinDBMemo2.GetDataSource: TDataSource;
begin
Result := FDataLink.DataSource;
end;
procedure TbsSkinDBMemo2.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 TbsSkinDBMemo2.GetDataField: string;
begin
Result := FDataLink.FieldName;
end;
procedure TbsSkinDBMemo2.SetDataField(const Value: string);
begin
FDataLink.FieldName := Value;
end;
function TbsSkinDBMemo2.GetReadOnly: Boolean;
begin
Result := FDataLink.ReadOnly;
end;
procedure TbsSkinDBMemo2.SetReadOnly(Value: Boolean);
begin
FDataLink.ReadOnly := Value;
end;
function TbsSkinDBMemo2.GetField: TField;
begin
Result := FDataLink.Field;
end;
procedure TbsSkinDBMemo2.LoadMemo;
begin
if not FMemoLoaded and Assigned(FDataLink.Field) and FDataLink.Field.IsBlob then
begin
try
Lines.Text := FDataLink.Field.AsString;
FMemoLoaded := True;
except
{ Memo too large }
on E:EInvalidOperation do
Lines.Text := Format('(%s)', [E.Message]);
end;
EditingChange(Self);
end;
end;
procedure TbsSkinDBMemo2.DataChange(Sender: TObject);
begin
if FDataLink.Field <> nil then
if FDataLink.Field.IsBlob then
begin
if FAutoDisplay or (FDataLink.Editing and FMemoLoaded) then
begin
FMemoLoaded := False;
LoadMemo;
end else
begin
Text := Format('(%s)', [FDataLink.Field.DisplayLabel]);
FMemoLoaded := False;
end;
end else
begin
if FFocused and FDataLink.CanModify then
Text := FDataLink.Field.Text
else
Text := FDataLink.Field.DisplayText;
FMemoLoaded := True;
end
else
begin
if csDesigning in ComponentState then Text := Name else Text := '';
FMemoLoaded := False;
end;
if HandleAllocated then
RedrawWindow(Handle, nil, 0, RDW_INVALIDATE or RDW_ERASE or RDW_FRAME);
end;
procedure TbsSkinDBMemo2.EditingChange(Sender: TObject);
begin
inherited ReadOnly := not (FDataLink.Editing and FMemoLoaded);
end;
procedure TbsSkinDBMemo2.UpdateData(Sender: TObject);
begin
FDataLink.Field.AsString := Text;
end;
procedure TbsSkinDBMemo2.SetFocused(Value: Boolean);
begin
if FFocused <> Value then
begin
FFocused := Value;
if not Assigned(FDataLink.Field) or not FDataLink.Field.IsBlob then
FDataLink.Reset;
end;
end;
procedure TbsSkinDBMemo2.WndProc(var Message: TMessage);
begin
inherited;
end;
procedure TbsSkinDBMemo2.CMEnter(var Message: TCMEnter);
begin
SetFocused(True);
inherited;
if FDataLink.CanModify then
inherited ReadOnly := False;
end;
procedure TbsSkinDBMemo2.CMExit(var Message: TCMExit);
begin
try
FDataLink.UpdateRecord;
except
SetFocus;
raise;
end;
SetFocused(False);
inherited;
end;
procedure TbsSkinDBMemo2.SetAutoDisplay(Value: Boolean);
begin
if FAutoDisplay <> Value then
begin
FAutoDisplay := Value;
if Value then LoadMemo;
end;
end;
procedure TbsSkinDBMemo2.WMLButtonDblClk(var Message: TWMLButtonDblClk);
begin
if not FMemoLoaded then LoadMemo else inherited;
end;
procedure TbsSkinDBMemo2.WMCut(var Message: TMessage);
begin
FDataLink.Edit;
inherited;
end;
procedure TbsSkinDBMemo2.WMUndo(var Message: TMessage);
begin
FDataLink.Edit;
inherited;
end;
procedure TbsSkinDBMemo2.WMPaste(var Message: TMessage);
begin
FDataLink.Edit;
inherited;
end;
procedure TbsSkinDBMemo2.CMGetDataLink(var Message: TMessage);
begin
Message.Result := Integer(FDataLink);
end;
function TbsSkinDBMemo2.ExecuteAction(Action: TBasicAction): Boolean;
begin
Result := inherited ExecuteAction(Action) or (FDataLink <> nil) and
FDataLink.ExecuteAction(Action);
end;
function TbsSkinDBMemo2.UpdateAction(Action: TBasicAction): Boolean;
begin
Result := inherited UpdateAction(Action) or (FDataLink <> nil) and
FDataLink.UpdateAction(Action);
end;
constructor TbsSkinDBDateEdit.Create(AOwner: TComponent);
begin
inherited Create(AOwner);
ControlStyle := ControlStyle + [csReplicatable];
FDataLink := TFieldDataLink.Create;
FDataLink.Control := Self;
FDataLink.OnDataChange := DataChange;
FDataLink.OnEditingChange := EditingChange;
FDataLink.OnUpdateData := UpdateData;
FInChange := False;
FInDataChange := False;
end;
destructor TbsSkinDBDateEdit.Destroy;
begin
FDataLink.Free;
FDataLink := nil;
inherited Destroy;
end;
procedure TbsSkinDBDateEdit.Loaded;
begin
inherited Loaded;
if (csDesigning in ComponentState) then DataChange(Self);
end;
procedure TbsSkinDBDateEdit.Notification(AComponent: TComponent;
Operation: TOperation);
begin
inherited Notification(AComponent, Operation);
if (Operation = opRemove) and (FDataLink <> nil) and
(AComponent = DataSource) then DataSource := nil;
end;
procedure TbsSkinDBDateEdit.Reset;
begin
FDataLink.Reset;
SelectAll;
end;
procedure TbsSkinDBDateEdit.Change;
begin
FInChange := True;
if not FInDataChange and (FDataLink <> nil) and
not ReadOnly and FDataLink.CanModify
then
begin
if not FDataLink.Editing then FDataLink.Edit;
FDataLink.Modified;
inherited Change;
end;
FInChange := False;
end;
function TbsSkinDBDateEdit.GetDataSource: TDataSource;
begin
Result := FDataLink.DataSource;
end;
procedure TbsSkinDBDateEdit.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 TbsSkinDBDateEdit.GetDataField: string;
begin
Result := FDataLink.FieldName;
end;
procedure TbsSkinDBDateEdit.SetDataField(const Value: string);
begin
FDataLink.FieldName := Value;
end;
function TbsSkinDBDateEdit.GetReadOnly: Boolean;
begin
Result := FDataLink.ReadOnly;
end;
procedure TbsSkinDBDateEdit.SetReadOnly(Value: Boolean);
begin
FDataLink.ReadOnly := Value;
end;
function TbsSkinDBDateEdit.GetField: TField;
begin
Result := FDataLink.Field;
end;
procedure TbsSkinDBDateEdit.DataChange(Sender: TObject);
begin
FInDataChange := True;
if not FInChange then
if FDataLink.Field <> nil
then
begin
if (FDataLink.Field.Text <> '') and
IsValidText(FDataLink.Field.Text)
then Date := StrToDate(FDataLink.Field.Text);
end;
FInDataChange := False;
end;
procedure TbsSkinDBDateEdit.EditingChange(Sender: TObject);
begin
inherited ReadOnly := not FDataLink.Editing;
end;
procedure TbsSkinDBDateEdit.UpdateData(Sender: TObject);
begin
FDataLink.Field.Text := Text;
end;
procedure TbsSkinDBDateEdit.CMEnter;
begin
inherited;
if FDataLink.CanModify then
inherited ReadOnly := False;
end;
procedure TbsSkinDBDateEdit.CMExit;
begin
inherited;
if (FDataLink <> nil) and (FDataLink.Editing)
then
FDataLink.UpdateRecord;
end;
procedure TbsSkinDBDateEdit.CMGetDataLink(var Message: TMessage);
begin
Message.Result := Integer(FDataLink);
end;
function TbsSkinDBDateEdit.ExecuteAction(Action: TBasicAction): Boolean;
begin
Result := inherited ExecuteAction(Action) or (FDataLink <> nil) and
FDataLink.ExecuteAction(Action);
end;
function TbsSkinDBDateEdit.UpdateAction(Action: TBasicAction): Boolean;
begin
Result := inherited UpdateAction(Action) or (FDataLink <> nil) and
FDataLink.UpdateAction(Action);
end;
//////////////////////////////////////////////////////////////////////////////
constructor TbsSkinDBTimeEdit.Create(AOwner: TComponent);
begin
inherited Create(AOwner);
ControlStyle := ControlStyle + [csReplicatable];
FDataLink := TFieldDataLink.Create;
FDataLink.Control := Self;
FDataLink.OnDataChange := DataChange;
FDataLink.OnEditingChange := EditingChange;
FDataLink.OnUpdateData := UpdateData;
FInChange := False;
FInDataChange := False;
end;
destructor TbsSkinDBTimeEdit.Destroy;
begin
FDataLink.Free;
FDataLink := nil;
inherited Destroy;
end;
procedure TbsSkinDBTimeEdit.Loaded;
begin
inherited Loaded;
if (csDesigning in ComponentState) then DataChange(Self);
end;
procedure TbsSkinDBTimeEdit.Notification(AComponent: TComponent;
Operation: TOperation);
begin
inherited Notification(AComponent, Operation);
if (Operation = opRemove) and (FDataLink <> nil) and
(AComponent = DataSource) then DataSource := nil;
end;
procedure TbsSkinDBTimeEdit.Reset;
begin
FDataLink.Reset;
SelectAll;
end;
procedure TbsSkinDBTimeEdit.Change;
begin
FInChange := True;
if not FInDataChange and (FDataLink <> nil) and
not ReadOnly and FDataLink.CanModify
then
begin
if not FDataLink.Editing then FDataLink.Edit;
FDataLink.Modified;
inherited Change;
end;
FInChange := False;
end;
function TbsSkinDBTimeEdit.GetDataSource: TDataSource;
begin
Result := FDataLink.DataSource;
end;
procedure TbsSkinDBTimeEdit.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 TbsSkinDBTimeEdit.GetDataField: string;
begin
Result := FDataLink.FieldName;
end;
procedure TbsSkinDBTimeEdit.SetDataField(const Value: string);
begin
FDataLink.FieldName := Value;
end;
function TbsSkinDBTimeEdit.GetReadOnly: Boolean;
begin
Result := FDataLink.ReadOnly;
end;
procedure TbsSkinDBTimeEdit.SetReadOnly(Value: Boolean);
begin
FDataLink.ReadOnly := Value;
end;
function TbsSkinDBTimeEdit.GetField: TField;
begin
Result := FDataLink.Field;
end;
procedure TbsSkinDBTimeEdit.DataChange(Sender: TObject);
begin
FInDataChange := True;
if not FInChange then
if FDataLink.Field <> nil
then
Text := FDataLink.Field.Text;
FInDataChange := False;
end;
procedure TbsSkinDBTimeEdit.EditingChange(Sender: TObject);
begin
inherited ReadOnly := not FDataLink.Editing;
end;
procedure TbsSkinDBTimeEdit.UpdateData(Sender: TObject);
begin
FDataLink.Field.Text := Text;
end;
procedure TbsSkinDBTimeEdit.CMEnter;
begin
inherited;
if FDataLink.CanModify then
inherited ReadOnly := False;
end;
procedure TbsSkinDBTimeEdit.CMExit;
begin
inherited;
if (FDataLink <> nil) and (FDataLink.Editing)
then
FDataLink.UpdateRecord;
end;
procedure TbsSkinDBTimeEdit.CMGetDataLink(var Message: TMessage);
begin
Message.Result := Integer(FDataLink);
end;
function TbsSkinDBTimeEdit.ExecuteAction(Action: TBasicAction): Boolean;
begin
Result := inherited ExecuteAction(Action) or (FDataLink <> nil) and
FDataLink.ExecuteAction(Action);
end;
function TbsSkinDBTimeEdit.UpdateAction(Action: TBasicAction): Boolean;
begin
Result := inherited UpdateAction(Action) or (FDataLink <> nil) and
FDataLink.UpdateAction(Action);
end;
end.