lbctrls.pas

天涯進銷存系統

end;

class function TLBNumberEdit.StrToFloatEx(const S: string; var Value: Double): Boolean;
const
  MinDouble = 5.0e-324;
  MaxDouble = 1.7e+308;
var
  E: Extended;  
begin
  if not TextToFloat(PChar(S), E, fvExtended) or
    ((E <> 0) and ((Abs(E) < MinDouble) or (Abs(E) > MaxDouble))) then
  begin
    Value := 0;
    Result := False;
  end
  else
    begin
      Value := E;
      Result := True;
    end;  
end;

procedure TLBNumberEdit.SetEditMinMaxValues(AMinValue, AMaxValue: Double);
begin
  if AMinValue > AMaxValue then AMinValue := AMaxValue;
  FMinValue := AMinValue;
  FMaxValue := AMaxValue;
  SetValue(GetValue);
end;

function TLBNumberEdit.GetValue: Double;
begin
  if Text = '' then
    Result := 0
  else
    if not StrToFloatEx(Text, Result) then
      Result := MinValue;
end;

function TLBNumberEdit.IsDisplayFormatStored: Boolean;
begin
end;

function TLBNumberEdit.IsMaxValueStored: Boolean;
begin
end;

function TLBNumberEdit.IsMinValueStored: Boolean;
begin
end;

function TLBNumberEdit.IsValueStored: Boolean;
begin
  Result := GetValue <> 0.0;
end;

procedure TLBNumberEdit.SetDisplayFormat(const Value: string);
begin
  SetEditDisplayFormat(Value);
end;

procedure TLBNumberEdit.SetMaxValue(Value: Double);
begin
  SetEditMaxValue(Value);
end;

procedure TLBNumberEdit.SetMinValue(Value: Double);
begin
  SetEditMinValue(Value);
end;

procedure TLBNumberEdit.SetValue(Value: Double);
var
  S: string;
  PrevModified: Boolean;
begin
  if MaxValue <> MinValue then
  begin
    if Value < MinValue then Value := MinValue
    else if Value > MaxValue then Value := MaxValue;
  end;
  // TODO !!
  S := FloatToStrF(Value, ffGeneral{ffFixed}, 15, 0);
  PrevModified := Modified;
  try
    if Text <> S then Text := S;
  finally
    Modified := PrevModified;
  end;
end;

procedure TLBNumberEdit.WMPaste(var Message: TWMPaste);
var
  S: string;
begin
  S := Text;
  inherited;
  try
    StrToFloat(Text);
  except
    Text := S;
    SelectAll;
  end;
end;

procedure TLBNumberEdit.CMWinIniChange(var Message: TWMWinIniChange);
begin
  inherited;
  SysUtils.GetFormatSettings; // TODO?
  SetEditDisplayFormat(DefaultDisplayFormat);
end;


constructor TLBComboBox.Create (AOwner: TComponent);
begin
  inherited Create(AOwner);
  ControlStyle := ControlStyle - [csFixedHeight] + [csOpaque];
  TControlCanvas(Canvas).Control := self;
  FButtonWidth := 11;
  FSysBtnWidth := GetSystemMetrics(SM_CXVSCROLL);
  FListInstance := MakeObjectInstance(ListWndProc);
  FDefListProc := nil;
  ItemHeight := 13;
  FBorderColor := clBackground;
  FButStyle:=cbsXp;
  FButtonColor:=$00D1ADAD;
end;

destructor TLBComboBox.Destroy;
begin
  FreeObjectInstance(FListInstance);
  inherited;
end;

procedure TLBComboBox.SetColors (Index: Integer; Value: TColor);
begin
  case Index of
    2: FBorderColor := Value;
  end;
  Invalidate;
end;


procedure TLBComboBox.CMSysColorChange (var Message: TMessage);
begin
  Invalidate;
end;

procedure TLBComboBox.CMParentColorChanged (var Message: TWMNoParams);
begin
  Invalidate;
end;

procedure TLBComboBox.WndProc (var Message: TMessage);
begin
  if (Message.Msg = WM_PARENTNOTIFY) then
    case LoWord(Message.wParam) of
      WM_CREATE:
        if FDefListProc <> nil then
        begin
          SetWindowLong(FListHandle, GWL_WNDPROC, Longint(FDefListProc));
          FDefListProc := nil;
          FChildHandle := Message.lParam;
        end
        else
          if FChildHandle = 0 then
            FChildHandle := Message.lParam
          else
            FListHandle := Message.lParam;
      end
  else
    if (Message.Msg = WM_WINDOWPOSCHANGING) then
      if Style in [csDropDown, csSimple] then
        SetWindowPos( EditHandle, 0,
          0, 0, ClientWidth - FButtonWidth - 2 * 2 - 4, Height - 2 * 2 - 2,
          SWP_NOMOVE + SWP_NOZORDER + SWP_NOACTIVATE + SWP_NOREDRAW);
  inherited;
  if Message.Msg = WM_CTLCOLORLISTBOX then
  begin
    SetBkColor(Message.wParam, ColorToRGB(Color));
    Message.Result := CreateSolidBrush(ColorToRGB(Color));
  end;
end;

procedure TLBComboBox.ListWndProc (var Message: TMessage);
begin
  case Message.Msg of
    WM_WINDOWPOSCHANGING:
      with TWMWindowPosMsg(Message).WindowPos^ do
      begin
        // size of the drop down list
        if Style in [csDropDown, csDropDownList] then
          cy := (GetFontHeight(Font)-2) * Min(DropDownCount, Items.Count) + 4
        else
          cy := (ItemHeight) * Min(DropDownCount, Items.Count) + 4;
        if cy <= 4  then
          cy := 10;
      end;
    else
      with Message do
        Result := CallWindowProc(FDefListProc, FListHandle, Msg, WParam, LParam);
  end;
end;

procedure TLBComboBox.ComboWndProc (var Message: TMessage; ComboWnd: HWnd; ComboProc: Pointer);
begin
  inherited;
  if (ComboWnd = EditHandle) then
    case Message.Msg of
      WM_SETFOCUS, WM_KILLFOCUS:
        SetSolidBorder;
    end;
end;

procedure TLBComboBox.WMSetFocus (var Message: TMessage);
begin
  inherited;
  if not (csDesigning in ComponentState) then
  begin
    SetSolidBorder;
    if not (Style in [csSimple, csDropDown]) then
      InvalidateSelection;
  end;
end;

procedure TLBComboBox.WMKillFocus (var Message: TMessage);
begin
  inherited;
  if not (csDesigning in ComponentState) then
  begin
    SetSolidBorder;
    if not (Style in [csSimple, csDropDown]) then
      InvalidateSelection;
  end;
end;

procedure TLBComboBox.CMEnabledChanged (var Msg: TMessage);
begin
  inherited;
  Invalidate;
end;

procedure TLBComboBox.CNCommand (var Message: TWMCommand);
var
  R: TRect;
begin
  inherited;
  if Message.NotifyCode in [1, 9, CBN_DROPDOWN, CBN_SELCHANGE] then
  begin
    if not (Style in [csSimple, csDropDown]) then
      InvalidateSelection;
  end;
  if (Message.NotifyCode in [CBN_CLOSEUP]) then
  begin
    R := GetButtonRect;
    Dec(R.Left, 2);
    InvalidateRect(Handle, @R, FALSE);
  end;
end;

procedure TLBComboBox.WMKeyDown (var Message: TMessage);
var
  S: String;
begin
  S := Text;
  inherited;
  if not (Style in [csSimple, csDropDown]) and (Text <> S) then
    InvalidateSelection;
end;

procedure TLBComboBox.WMPaint (var Message: TWMPaint);
var
  R: TRect;
  DC: HDC;
  PS: TPaintStruct;
begin
  DC := BeginPaint(Handle, PS);
  try
    R := PS.rcPaint;
    if R.Right > Width - FButtonWidth - 4 then
      R.Right := Width - FButtonWidth - 4;
    FillRect(DC, R, Brush.Handle);
    if RectInRect(GetButtonRect, PS.rcPaint) then
      PaintButton;
    ExcludeClipRect(DC, ClientWidth - FSysBtnWidth - 2, 0, ClientWidth, ClientHeight);
    PaintWindow(DC);
    if (Style = csDropDown) and DroppedDown then
    begin
      R := ClientRect;
      InflateRect(R, -2, -2);
      R.Right := Width - FButtonWidth - 3;
      Canvas.Brush.Color := clWindow;
      Canvas.FrameRect(R);
    end
    else
      if Style <> csDropDown then
        InvalidateSelection;
  finally
    EndPaint(Handle, PS);
  end;
  RedrawBorders;
  Message.Result := 0;
end;

procedure TLBComboBox.WMNCPaint (var Message: TMessage);
begin
  inherited;
  RedrawBorders;
end;

procedure TLBComboBox.CMFontChanged (var Message: TMessage);
begin
  inherited;
  ItemHeight := 13;
  RecreateWnd;
end;

procedure TLBComboBox.InvalidateSelection;
var
  R: TRect;
begin
  R := ClientRect;
  InflateRect(R, -2, -3);
  R.Left := R.Right - FButtonWidth - 8;
  Dec(R.Right, FButtonWidth + 3);
  if (GetFocus = Handle) and not DroppedDown then
    Canvas.Brush.Color := clHighlight
  else
    Canvas.Brush.Color := Color;
  Canvas.Brush.Style := bsSolid;
  Canvas.FillRect(R);
  if (GetFocus = Handle) and not DroppedDown then
  begin
    R := ClientRect;
    InflateRect(R, -3, -3);
    Dec(R.Right, FButtonWidth + 2);
    Canvas.FrameRect(R);
    Canvas.Brush.Color := clWindow;
  end;
  ExcludeClipRect(Canvas.Handle, ClientWidth - FSysBtnWidth - 2, 0, ClientWidth, ClientHeight);
end;

function TLBComboBox.GetButtonRect: TRect;
begin
  GetWindowRect(Handle, Result);
  OffsetRect(Result, -Result.Left, -Result.Top);
  Inc(Result.Left, ClientWidth - FButtonWidth);
  OffsetRect(Result, -1, 0);
end;

procedure TLBComboBox.PaintButton;

const
  Alignments: array[TAlignment] of Longint = (DT_LEFT, DT_RIGHT, DT_CENTER);
var
  PaintRect, R: TRect;
  FontHeight: integer;
  Transparent: Boolean;
  Flags: Longint;
  FAlignment: TAlignment;
  x, y: Integer;
begin
  R := GetButtonRect;
  InflateRect(R, 1, 0);
  x := (R.Right - R.Left) div 2 - 6 + R.Left;
  if FButStyle=cbsLine then
  begin
  x := (R.Right - R.Left) div 2 - 6 + R.Left;
  if DroppedDown then
    y := (R.Bottom - R.Top) div 2 - 1 + R.Top
  else
    y := (R.Bottom - R.Top) div 2 - 1 + R.Top;

  if Enabled then
  begin
    Canvas.Brush.Color := FButtonColor;
    Canvas.FillRect(R);
    Canvas.Brush.Color := FBorderColor;
    Canvas.FrameRect(R);

    canvas.Brush.Color := FArrowColor;
    canvas.Pen.Color := FArrowColor;
    if DroppedDown then
      canvas.Polygon([Point(x + 4, y + 2), Point(x + 8, y + 2), Point(x + 6, y)])
    else
      canvas.Polygon([Point(x + 4, y), Point(x + 8, y), Point(x + 6, y + 2)]);
  end
  else
  begin
    canvas.Brush.Color := clWhite;
    canvas.Pen.Color := clWhite;
    Inc(x); Inc(y);
    if DroppedDown then
      canvas.Polygon([Point(x + 4, y + 2), Point(x + 8, y + 2), Point(x + 6, y)])
    else
      canvas.Polygon([Point(x + 4, y), Point(x + 8, y), Point(x + 6, y + 2)]);
    Dec(x); Dec(y);
    canvas.Brush.Color := clGray;
    canvas.Pen.Color := clGray;
    if DroppedDown then
      canvas.Polygon([Point(x + 4, y + 2), Point(x + 8, y + 2), Point(x + 6, y)])
    else
      canvas.Polygon([Point(x + 4, y), Point(x + 8, y), Point(x + 6, y + 2)]);
  end;
  ExcludeClipRect(Canvas.Handle, ClientWidth - FSysBtnWidth, 0, ClientWidth, ClientHeight);
  end
  else
  if FButStyle=cbsXp then
  begin
  FAlignment:=taCenter;
  PaintRect:=GetButtonRect;
  Canvas.Font := Font;
  with Canvas do
  begin
    Pen.Color:=FBorderColor;
    Rectangle(X, 0, Width, Height);
    Pen.Color:=clWhite;
    Rectangle(X-1, 1, Width-1, Height-1);
    Brush.Color:=Rgb(206, 219,255);
    Pen.Color:=Rgb(181, 207, 247);
    RoundRect(X-2, 2, Width-2, Height-2, 1, 1);

    Pen.Color:=Rgb(206,231, 255);
    Canvas.MoveTo(X-1, 3);
    Canvas.LineTo(Width-3, 3);
    Pen.Color:=Rgb(74, 97, 132);
    MoveTo((width+X-2) div 2-1, Height div 2+2);
    LineTo((width+X-2) div 2-6, Height div 2-3);
    MoveTo((width+X-2) div 2, Height div 2+1);
    LineTo((width+X-2) div 2-5, Height div 2-4);
    MoveTo((width+X-2) div 2, Height div 2+2);
    LineTo((width+X-2) div 2-5, Height div 2-3);
    MoveTo((width+X-2) div 2, Height div 2+2);
    LineTo((width+X-2) div 2+5, Height div 2-3);
    MoveTo((width+X-2) div 2-1, Height div 2+1);
    LineTo((width+X-2) div 2+4, Height div 2-4);
    MoveTo((width+X-2) div 2, Height div 2+1);
    LineTo((width+X-2) div 2+4, Height div 2-3);
    Pen.Color:=Rgb(107, 130, 239);
    MoveTo(X-1,Height-3);
    LineTo(Width-3,Height-3);

    Pen.Color:=Rgb(140, 174, 231);
    MoveTo(X-1,Height-4);
    LineTo(Width-2,Height-4);
    if DroppedDown then
    begin
      Pen.Color:=Rgb(173,195,247);
      Brush.Color:=Rgb(206, 219,255);
      Rectangle(X-2, 2, Width-2, Height-2);

      Pen.Color:=Rgb(107, 130, 239);
      MoveTo(X-1,Height-3);
      LineTo(Width-3,Height-3);
      Pen.Color:=Rgb(74, 97, 132);
      MoveTo((width+X-2) div 2-1, Height div 2+3);
      LineTo((width+X-2) div 2-6, Height div 2-2);
      MoveTo((width+X-2) div 2, Height div 2+2);