toolctrlseh.pas

delphi控件类

  Pos := 0;
  Max := 0;
  Page := 0;
  if (ListLink.DataSet<> nil) and ListLink.DataSet.IsSequenced then
  begin
    Page := FRowCount;
    Max := ListLink.DataSet.RecordCount-1;
    ListLink.ActiveRecord := 0;
    if ListLink.DataSet.State in [dsInactive, dsBrowse, dsEdit] then
      Pos := ListLink.DataSet.RecNo-1;
    if FRecordCount <> 0 then ListLink.ActiveRecord := FRecordIndex;
  end else
  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;
  ScrollInfo.cbSize := SizeOf(TScrollInfo);
  ScrollInfo.fMask := SIF_ALL;
  if not GetScrollInfo(Handle, SB_VERT, ScrollInfo) or
    (ScrollInfo.nPos <> Pos) or (ScrollInfo.nMax <> Max) or
    (ScrollInfo.nPage <> Page) or (ScrollInfo.nPos <> Pos) then
  begin
    ScrollInfo.nMin := 0;
    ScrollInfo.nMax := Max;
    ScrollInfo.nPos := Pos;
    ScrollInfo.nPage := Page;
    SetScrollInfo(Handle, SB_VERT, ScrollInfo, True);
  end;
end;

procedure TDBLookupListBoxEh.CMCtl3DChanged(var Message: TMessage);
begin
  if NewStyleControls and (FBorderStyle = bsSingle) then
  begin
    RecreateWnd;
    RowCount := RowCount;
  end;
  inherited;
end;

procedure TDBLookupListBoxEh.CMFontChanged(var Message: TMessage);
begin
  inherited;
  Height := Height;
end;

procedure TDBLookupListBoxEh.WMCancelMode(var Message: TMessage);
begin
  StopTracking;
  inherited;
end;

procedure TDBLookupListBoxEh.WMTimer(var Message: TMessage);
begin
  TimerScroll;
end;

procedure TDBLookupListBoxEh.WMVScroll(var Message: TWMVScroll);
var
  SI: TScrollInfo;
  OldRecNo:Integer;
  OldActiveRec:Integer;
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;
      SB_THUMBTRACK:
         if IsSequenced then
         begin
            SI.cbSize := SizeOf(SI);
            SI.fMask := SIF_TRACKPOS;
            GetScrollInfo(Self.Handle, SB_VERT, SI);
            OldActiveRec := ListLink.ActiveRecord;
            ListLink.ActiveRecord := 0;
            OldRecNo := RecNo-1;
            if SI.nTrackPos < OldRecNo then
              MoveBy(SI.nTrackPos-OldRecNo)
            else if SI.nTrackPos > OldRecNo then
              MoveBy(SI.nTrackPos-OldRecNo+ListLink.RecordCount-1)
            else
              ListLink.ActiveRecord := OldActiveRec;
         end;
    end;
end;

function TDBLookupListBoxEh.ExecuteAction(Action: TBasicAction): Boolean;
begin
//  Result := inherited ExecuteAction(Action) or (FDataLink <> nil) and
//    FDataLink.ExecuteAction(Action);
  Result := inherited ExecuteAction(Action);
  if not Result and (DataSource <> nil) then
    if Action.HandlesTarget(DataSource) then
      Action.ExecuteTarget(DataSource);
end;

function TDBLookupListBoxEh.UpdateAction(Action: TBasicAction): Boolean;
begin
//  Result := inherited UpdateAction(Action) or (FDataLink <> nil) and
//    FDataLink.UpdateAction(Action);
  Result := inherited UpdateAction(Action);
  if not Result and (DataSource <> nil) then
    if Action.HandlesTarget(DataSource) then
      Action.UpdateTarget(DataSource);
end;

procedure TDBLookupListBoxEh.SetShowTitles(const Value: Boolean);
begin
  if FShowTitles <> Value then
  begin
    FShowTitles := Value;
    if FShowTitles then FTitleHeight := GetTextHeight + 1 else FTitleHeight := 0;
    //if HandleAllocated then
    Height := RowCount * GetTextHeight + GetBorderSize + FTitleHeight;
  end;
end;

{ TSizeGripEh }

constructor TSizeGripEh.Create(AOwner: TComponent);
begin
  inherited Create(AOwner);
  Width := GetSystemMetrics(SM_CXVSCROLL);
  Height := GetSystemMetrics(SM_CYVSCROLL);
  Color := clBtnFace;
  Cursor := crSizeNWSE;
  ControlStyle := ControlStyle + [csCaptureMouse];
  FTriangleWindow := True;
  FPosition := sgpBottomRight;
end;

procedure TSizeGripEh.CreateWnd;
type
  PPoints = ^TPoints;
  TPoints = array[0..0] of TPoint;
var
  Points :array[0..2] of TPoint;
  Region: HRgn;
begin
  inherited CreateWnd;
  if TriangleWindow then
  begin
    if Position = sgpBottomRight then
    begin
      Points[0] := Point(0,Height);
      Points[1] := Point(Width,Height);
      Points[2] := Point(Width,0);
      Cursor := crSizeNWSE;
    end else if Position = sgpBottomLeft then
    begin
      Points[0] := Point(Width,Height);
      Points[1] := Point(0,Height);
      Points[2] := Point(0,0);
      Cursor := crSizeNESW;
    end else if Position = sgpTopLeft then
    begin
      Points[0] := Point(Width-1,0);
      Points[1] := Point(0,0);
      Points[2] := Point(0,Height-1);
      Cursor := crSizeNWSE;
    end else if Position = sgpTopRight then
    begin
      Points[0] := Point(Width,Height-1);
      Points[1] := Point(Width,0);
      Points[2] := Point(1,0);
      Cursor := crSizeNESW;
    end;
    Region:=CreatePolygonRgn(PPoints(@Points)^,3,WINDING);
    SetWindowRgn(Handle, Region, True);
    UpdatePosition;
    //ShowWindow(Handle,SW_SHOW);
  end;
end;

procedure TSizeGripEh.MouseDown(Button: TMouseButton; Shift: TShiftState; X,
  Y: Integer);
begin
  inherited MouseDown(Button,Shift,X,Y);
  FInitScreenMousePos := ClientToScreen(Point(X, Y));
  FParentRect.Right := Parent.Width;
  FParentRect.Bottom := Parent.Height;
  FParentRect.Left := Parent.ClientWidth;
  FParentRect.Top := Parent.ClientHeight;
end;

procedure TSizeGripEh.MouseMove(Shift: TShiftState; X, Y: Integer);
var
  NewMousePos:TPoint;
  OldPos:Integer;
  ParentWidthHeight:TPoint;
begin
  inherited MouseMove(Shift,X,Y);

  if (ssLeft in Shift) and MouseCapture and not FInternalMove then
  begin
    NewMousePos := ClientToScreen(Point(X, Y));
    ParentWidthHeight.x := Parent.ClientWidth;
    ParentWidthHeight.y := Parent.ClientHeight;

    if (FOldMouseMovePos.x = NewMousePos.x) and
       (FOldMouseMovePos.y = NewMousePos.y) then
       Exit;

    if Position in [sgpBottomRight,sgpTopRight] then
      Parent.ClientWidth := FParentRect.Left + NewMousePos.x - FInitScreenMousePos.x
    else
    begin
      OldPos := Parent.Width;
      Parent.Width := FParentRect.Right + FInitScreenMousePos.x - NewMousePos.x;
      Parent.Left := Parent.Left + OldPos - Parent.Width;
    end;

    if Position in [sgpBottomRight,sgpBottomLeft] then
      Parent.ClientHeight := FParentRect.Top + NewMousePos.y - FInitScreenMousePos.y
    else
    begin
      OldPos := Parent.{Client}Height;
      Parent.{Client}Height := FParentRect.Bottom + FInitScreenMousePos.y - NewMousePos.y;
      Parent.Top := Parent.Top + OldPos - Parent.{Client}Height;
    end;

    FOldMouseMovePos := NewMousePos;
    if (ParentWidthHeight.x <> Parent.ClientWidth) or
       (ParentWidthHeight.y <> Parent.ClientHeight) then
      ParentResized;
    UpdatePosition;
  end;
end;

procedure TSizeGripEh.Paint;
var i,xi,yi:Integer;
    x1,x2,y1,y2:Integer;
    px,py:PInteger;
begin
  i := 1;
  if Position = sgpBottomRight then
  begin
    xi := 1; yi := 1;
    px := @x1; py := @y2;
    x1 := 0; y1 := Width;
    x2 := Width; y2 := 0;
  end else if Position = sgpBottomLeft then
  begin
    xi := -1; yi := 1;
    px := @x2; py := @y1;
    x1 := 0; y1 := 1;
    x2 := Width-1; y2 := Width;
  end else if Position = sgpTopLeft then
  begin
    xi := -1; yi := -1;
    px := @x1; py := @y2;
    x1 := Width-1; y1 := -1;
    x2 := -1; y2 := Width-1;
  end else //  Position = sgpTopRight
  begin
    xi := 1; yi := -1;
    px := @x2; py := @y1;
    x1 := Width; y1 := Width-1;
    x2 := 0; y2 := -1;
  end;

  with Canvas do
    while i < Width do
    begin
      Pen.Color := clBtnHighlight;
      PolyLine([Point(x1,y1),Point(x2,y2)]);
      Inc(i); Inc(px^,xi); Inc(py^,yi);

      Pen.Color := clBtnShadow;
      PolyLine([Point(x1,y1),Point(x2,y2)]);
      Inc(i); Inc(px^,xi); Inc(py^,yi);
      PolyLine([Point(x1,y1),Point(x2,y2)]);
      Inc(i); Inc(px^,xi); Inc(py^,yi);

      Pen.Color := clBtnFace;
      PolyLine([Point(x1,y1),Point(x2,y2)]);
      Inc(i); Inc(px^,xi); Inc(py^,yi);
    end;
end;

procedure TSizeGripEh.ParentResized;
begin
  if Assigned(FParentResized) then FParentResized(Self);
end;

procedure TSizeGripEh.SetPosition(const Value: TSizeGripPostion);
begin
  if FPosition = Value then Exit;
  FPosition := Value;
  RecreateWnd;
  HandleNeeded;
end;

procedure TSizeGripEh.SetTriangleWindow(const Value: Boolean);
begin
  if FTriangleWindow = Value then Exit;
  FTriangleWindow := Value;
  RecreateWnd;
  HandleNeeded;
end;

procedure TSizeGripEh.UpdatePosition;
begin
  FInternalMove := True;
  case Position of
    sgpBottomRight: MoveWindow(Handle,Parent.ClientWidth-Width,Parent.ClientHeight-Height,Width,Height,True);
    sgpBottomLeft: MoveWindow(Handle,0,Parent.ClientHeight-Height,Width,Height,True);
    sgpTopLeft: MoveWindow(Handle,0,0,Width,Height,True);
    sgpTopRight: MoveWindow(Handle,Parent.ClientWidth-Width,0,Width,Height,True);
  end;
  FInternalMove := False;
end;

procedure TSizeGripEh.WMMove(var Message: TMessage);
begin
  if not FInternalMove then UpdatePosition;
  inherited;
end;

procedure TSizeGripEh.ChangePosition(NewPosition: TSizeGripChangePosition);
begin
  if NewPosition = sgcpToLeft then
  begin
    if Position = sgpTopRight then Position := sgpTopLeft
    else if Position = sgpBottomRight then Position := sgpBottomLeft;
  end else if NewPosition = sgcpToRight then
  begin
    if Position = sgpTopLeft then Position := sgpTopRight
    else if Position = sgpBottomLeft then Position := sgpBottomRight
  end else if NewPosition = sgcpToTop then
  begin
    if Position = sgpBottomRight then Position := sgpTopRight
    else if Position = sgpBottomLeft then Position := sgpTopLeft
  end else if NewPosition = sgcpToBottom then
  begin
    if Position = sgpTopRight then Position := sgpBottomRight
    else if Position = sgpTopLeft then Position := sgpBottomLeft
  end
end;

function TSizeGripEh.GetVisible: Boolean;
begin
  Result := IsWindowVisible(Handle);
end;

procedure TSizeGripEh.SetVisible(const Value: Boolean);
begin
  if Value then
    ShowWindow(Handle,SW_SHOW)
  else
    ShowWindow(Handle,SW_HIDE);
end;

{ TPopupDataListEh }

constructor TPopupDataListEh.Create(AOwner: TComponent);
begin
  inherited Create(AOwner);
  ControlStyle := ControlStyle + [csNoDesignVisible, csReplicatable];
  FPopup := True;
  FSizeGrip := TSizeGripEh.Create(Self);
  with FSizeGrip do
  begin
    Parent := Self;
    TriangleWindow := True;
  end;
end;

function TPopupDataListEh.CheckNewSize(var NewWidth, NewHeight: Integer): Boolean;
begin
  Result := True;
  if NewWidth < GetSystemMetrics(SM_CXVSCROLL) then
    NewWidth := GetSystemMetrics(SM_CXVSCROLL);
  if NewHeight < GetSystemMetrics(SM_CYVSCROLL) then
    NewHeight := GetSystemMetrics(SM_CYVSCROLL);
end;

procedure TPopupDataListEh.CMSetSizeGripChangePosition(var Message: TMessage);
begin
  FSizeGrip.ChangePosition(TSizeGripChangePosition(Message.WParam));
end;

procedure TPopupDataListEh.CreateParams(var Params: TCreateParams);
begin
  inherited CreateParams(Params);
  with Params do
  begin
    Style := WS_POPUP or WS_BORDER or WS_CLIPCHILDREN;
    ExStyle := WS_EX_TOOLWINDOW;
    AddBiDiModeExStyle(ExStyle);
    WindowClass.Style := CS_SAVEBITS or CS_HREDRAW;
  end;
end;

procedure TPopupDataListEh.KeyDown(var Key: Word; Shift: TShiftState);
begin
  FUserKeyValueChanged := True;
  try
    inherited KeyDown(Key,Shift);
  finally
    FUserKeyValueChanged := False;
  end;
end;

procedure TPopupDataListEh.KeyValueChanged;
begin
  inherited KeyValueChanged;
  if Assigned(OnUserKeyValueChange) and FUserKeyValueChanged then
    OnUserK