tntjvdblookup.pas

TntExUpdate 是 流行的 TntUnicodeControls控件的扩展包.包括很难找到的 TntJVCL 也在里面. TntSysUtils2.pas/TntSysUtilsEx.pa

  begin
    // S := FValue;  // Polaris
    if FDataLink.Edit then
    begin
      // if FMasterField <> nil then FMasterField.AsString := S
      //   else FDataField.AsString := S;
      if FMasterField <> nil then
        SetFieldValue(FMasterField, FValue) // Polaris
      else
        SetFieldValue(FDataField, FValue); // Polaris
    end;
  end
  else
  if FDisplayValue <> Value then
  begin
    FDisplayValue := Value;
    DisplayValueChanged;
    Change;
  end;
end;

procedure TTntJvLookupControl.UpdateKeyValue;
begin
  if FMasterField <> nil then
    FValue := GetAsWideString(FMasterField)
  else
    FValue := FEmptyValue;
  KeyValueChanged;
end;

procedure TTntJvLookupControl.SetValueKey(const Value: WideString);
begin
  if FValue <> Value then
  begin
    FValue := Value;
    KeyValueChanged;
  end;
end;

procedure TTntJvLookupControl.SetValue(const Value: WideString);
begin
  if Value <> FValue then
  begin // Polaris // begin added
    if CanModify and (FDataLink.DataSource <> nil) and FDataLink.Edit then
    begin
      // if FMasterField <> nil then FMasterField.AsString := Value
      //   else FDataField.AsString := Value;
      if FMasterField <> nil then
        SetFieldValue(FMasterField, Value) // Polaris
      else
        SetFieldValue(FDataField, Value); // Polaris
    end
    else // begin  // Polaris
      SetValueKey(Value);
    Change;
  end;
end;

procedure TTntJvLookupControl.SetLookupDisplay(const Value: string);
begin
  if FLookupDisplay <> Value then
  begin
    FLookupDisplay := Value;
    ListLinkActiveChanged;
    if FListActive then
      DataLinkRecordChanged(nil);
  end;
end;

procedure TTntJvLookupControl.SetLookupSource(Value: TDataSource);
begin
  CheckNotFixed;
  FLookupLink.DataSource := Value;
  if Value <> nil then
    Value.FreeNotification(Self);
  if Value <> nil then
    FLocate.DataSet := Value.DataSet
  else
    FLocate.DataSet := nil;
  if FListActive then
    DataLinkRecordChanged(nil);
end;

procedure TTntJvLookupControl.SetReadOnly(Value: Boolean);
begin
  FDataLink.ReadOnly := Value;
end;

function TTntJvLookupControl.GetItemHeight: Integer;
begin
  Result := {Max(GetTextHeight, FItemHeight);} GetTextHeight;
end;

procedure TTntJvLookupControl.SetItemHeight(Value: Integer);
begin
  if not (csReading in ComponentState) then
    FItemHeight := Max(DefaultTextHeight, Value)
  else
    FItemHeight := Value;
  Perform(CM_FONTCHANGED, 0, 0);
end;

function TTntJvLookupControl.ItemHeightStored: Boolean;
begin
  Result := FItemHeight > DefaultTextHeight;
end;

procedure TTntJvLookupControl.DrawPicture(Canvas: TCanvas; Rect: TRect;
  Image: TGraphic);
var
  X, Y, SaveIndex: Integer;
  Ico: HICON;
  W, H: Integer;
begin
  if Image <> nil then
  begin
    X := (Rect.Right + Rect.Left - Image.Width) div 2;
    Y := (Rect.Top + Rect.Bottom - Image.Height) div 2;
    SaveIndex := SaveDC(Canvas.Handle);
    try
      IntersectClipRect(Canvas.Handle, Rect.Left, Rect.Top, Rect.Right,
        Rect.Bottom);
      if Image is TBitmap then
        DrawBitmapTransparent(Canvas, X, Y, TBitmap(Image),
          TBitmap(Image).TransparentColor)
      else
      if Image is TIcon then
      begin
        Ico := CreateRealSizeIcon(TIcon(Image));
        try
          GetIconSize(Ico, W, H);
          DrawIconEx(Canvas.Handle, (Rect.Right + Rect.Left - W) div 2,
            (Rect.Top + Rect.Bottom - H) div 2, Ico, W, H, 0, 0, DI_NORMAL);
        finally
          DestroyIcon(Ico);
        end;
      end
      else
        Canvas.Draw(X, Y, Image);
    finally
      RestoreDC(Canvas.Handle, SaveIndex);
    end;
  end;
end;

function TTntJvLookupControl.GetPicture(Current, Empty: Boolean;
  var TextMargin: Integer): TGraphic;
begin
  TextMargin := 0;
  Result := nil;
  if Assigned(FOnGetImage) then
    FOnGetImage(Self, Empty, Result, TextMargin);
end;

procedure TTntJvLookupControl.GetDlgCode(var Code: TDlgCodes);
begin
  Code := [dcWantArrows, dcWantChars];
end;

procedure TTntJvLookupControl.FocusKilled(NextWnd: THandle);
begin
  FFocused := False;
  inherited FocusKilled(NextWnd);
  Invalidate;
end;

procedure TTntJvLookupControl.FocusSet(PrevWnd: THandle);
begin
  FFocused := True;
  inherited FocusSet(PrevWnd);
  Invalidate;
end;

function TTntJvLookupControl.Locate(const SearchField: TField;
  const AValue: WideString; Exact: Boolean): Boolean;
begin
  FLocate.IndexSwitch := FIndexSwitch;
  Result := False;
  try
    if not ValueIsEmpty(AValue) and (SearchField <> nil) then
    begin
      Result := FLocate.Locate(SearchField.FieldName, AValue, Exact, not IgnoreCase);
      if Result then
      begin
        if SearchField = FDisplayField then
          FValue := GetAsWideString(FKeyField);
        UpdateDisplayValue;
      end;
    end;
  except
  end;
end;

function TTntJvLookupControl.EmptyRowVisible: Boolean;
begin
  Result := DisplayEmpty <> '';
end;

procedure TTntJvLookupControl.UpdateDisplayValue;
begin
  if not ValueIsEmpty(FValue) then
  begin
    if FDisplayField <> nil then
      FDisplayValue := GetAsWideString(FDisplayField)
    else
      FDisplayValue := '';
  end
  else
    FDisplayValue := '';
end;

function TTntJvLookupControl.GetWindowWidth: Integer;
var
  I: Integer;
begin
  Result := 0;
  for I := 0 to FListFields.Count - 1 do
    Inc(Result, TField(FListFields[I]).DisplayWidth);
  Canvas.Font := Font;
  Result := Min(Result * Canvas.TextWidth('M') + FListFields.Count * 4 +
    GetSystemMetrics(SM_CXVSCROLL), Screen.Width);
end;

procedure TTntJvLookupControl.SetLookupFormat(const Value: WideString);
begin
  if Value <> FLookupFormat then
  begin
    CheckLookupFormat(Value);
    FLookupFormat := Value;
    ListLinkActiveChanged;
    if FListActive then
      DataLinkRecordChanged(nil);
  end;
end;

function TTntJvLookupControl.DoFormatLine: WideString;
var
  J, LastFieldIndex: Integer;
  Field: TField;
  LStringList: array of WideString;
  LVarList: array of TVarRec;
begin
  Result := '';
  LastFieldIndex := FListFields.Count - 1;
  if LookupFormat > '' then
  begin
    SetLength(LStringList, LastFieldIndex + 1);
    SetLength(LVarList, LastFieldIndex + 1);

    for J := 0 to LastFieldIndex do
    begin
      LStringList[J] := GetWideDisplayText(TField(FListFields[J]));
      LVarList[J].VPWideChar := PWideChar(LStringList[J]);
      LVarList[J].VType := vtPWideChar;
    end;
    Result := WideFormat(LookupFormat, LVarList);
  end
  else
    for J := 0 to LastFieldIndex do
    begin
      Field := FListFields[J];
      Result := Result + GetWideDisplayText(Field);
      if J < LastFieldIndex then
        Result := Result + FFieldsDelimiter + ' ';
    end;
end;

//=== { TTntJvDBLookupList } ====================================================

constructor TTntJvDBLookupList.Create(AOwner: TComponent);
begin
  inherited Create(AOwner);
  Width := 121;
  Ctl3D := True;
  FBorderStyle := bsSingle;
  ControlStyle := [csOpaque, csDoubleClicks];
  RowCount := 7;
end;

procedure TTntJvDBLookupList.CreateParams(var Params: TCreateParams);
begin
  inherited CreateParams(Params);
  with Params do
  begin
    Style := Style or WS_VSCROLL;
    if FBorderStyle = bsSingle then
      if NewStyleControls and Ctl3D then
        ExStyle := ExStyle or WS_EX_CLIENTEDGE
      else
        Style := Style or WS_BORDER;
  end;
end;

procedure TTntJvDBLookupList.CreateWnd;
begin
  inherited CreateWnd;
  UpdateScrollBar;
end;

procedure TTntJvDBLookupList.Loaded;
begin
  inherited Loaded;
  Height := Height;
end;

function TTntJvDBLookupList.GetKeyIndex: Integer;
var
  FieldValue: WideString;
begin
  if not ValueIsEmpty(FValue) then
    for Result := 0 to FRecordCount - 1 do
    begin
      FLookupLink.ActiveRecord := Result;
      FieldValue := GetAsWideString(FKeyField);
      FLookupLink.ActiveRecord := FRecordIndex;
      if FieldValue = FValue then
        Exit;
    end;
  Result := -1;
end;

procedure TTntJvDBLookupList.KeyDown(var Key: Word; Shift: TShiftState);
var
  Delta, KeyIndex, EmptyRow: Integer;
begin
  inherited KeyDown(Key, Shift);
  FSelectEmpty := False;
  EmptyRow := Ord(EmptyRowVisible);
  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 - EmptyRow);
      VK_NEXT:
        Delta := (FRowCount - EmptyRow) - 1;
      VK_HOME:
        Delta := -MaxInt;
      VK_END:
        Delta := MaxInt;
    end;
    if Delta <> 0 then
    begin
      if ValueIsEmpty(Value) and (EmptyRow > 0) and (Delta < 0) then
        FSelectEmpty := True;
      FSearchText := '';
      if Delta = -MaxInt then
        FLookupLink.DataSet.First
      else
      if Delta = MaxInt then
        FLookupLink.DataSet.Last
      else
      begin
        KeyIndex := GetKeyIndex;
        if KeyIndex >= 0 then
        begin
          FLookupLink.DataSet.MoveBy(KeyIndex - FRecordIndex);
        end
        else
        begin
          KeyValueChanged;
          Delta := 0;
        end;
        FLookupLink.DataSet.MoveBy(Delta);
        if FLookupLink.DataSet.Bof and (Delta < 0) and (EmptyRow > 0) then
          FSelectEmpty := True;
      end;
      SelectCurrent;
    end;
  end;
end;

procedure TTntJvDBLookupList.KeyPress(var Key: Char);
begin
  inherited KeyPress(Key);
  ProcessSearchKey(WideChar(Key));
end;

procedure TTntJvDBLookupList.KeyValueChanged;
begin
  if FListActive and not FLockPosition then
    if not LocateKey then
      FLookupLink.DataSet.First;
end;

procedure TTntJvDBLookupList.DisplayValueChanged;
begin
  if FListActive and not FLockPosition then
    if not LocateDisplay then
      FLookupLink.DataSet.First;
end;

procedure TTntJvDBLookupList.ListLinkActiveChanged;
begin
  try
    inherited ListLinkActiveChanged;
  finally
    if FListActive and not FLockPosition then
    begin
      if Assigned(FMasterField) then
        UpdateKeyValue
      else
        KeyValueChanged;
    end
    else
      ListDataChanged;
  end;
end;

procedure TTntJvDBLookupList.ListDataChanged;
begin
  if FListActive then
  begin
    FRecordIndex := FLookupLink.ActiveRecord;
    FRecordCount := FLookupLink.RecordCount;
    FKeySelected := not ValueIsEmpty(FValue) or not FLookupLink.DataSet.Bof;
  end
  else
  begin
    FRecordIndex := 0;
    FRecordCount := 0;
    FKeySelected := False;
  end;
  if HandleAllocated then
  begin
    UpdateScrollBar;
    Invalidate;
  end;
end;

procedure TTntJvDBLookupList.ListLinkDataChanged;
begin
  ListDataChanged;
end;

procedure TTntJvDBLookupList.MouseDown(Button: TMouseButton; Shift: TShiftState;
  X, Y: Integer);
begin
  if Button = mbLeft then