xpcombo.pas

非常好的xp界面控件

end;


procedure TxpComboBox.DrawFlatButton (DC : hDC; AButtonRect : TRect);
var
  Brush : hBrush;
  Pen : hPen;
  SepPen : hPen;
begin
  if FFocused or FActive then
  begin
    //left separating line color
    SepPen := CreatePen (PS_SOLID, 1, ColorToRGB (FxpStyle.ActiveBorderColor));
    //Create brush
    Brush := CreateSolidBrush (ColorToRGB (FxpStyle.ActiveButtonColor));
    Pen := CreatePen (PS_SOLID, 1, ColorToRGB (FxpStyle.ActiveButtonColor));
  end
  else
  begin
    //left separating line color
    SepPen := CreatePen (PS_SOLID, 1, ColorToRGB (Color));
    //Create brush
    Brush := CreateSolidBrush (ColorToRGB (FxpStyle.InActiveButtonColor));
    Pen := CreatePen (PS_SOLID, 1, ColorToRGB (Color));
  end;
  SelectObject(DC, Brush);
  SelectObject(DC, Pen);
  SelectObject(DC, SepPen);

  //Draw left separating line
  MoveToEx (DC, AButtonRect.Left, AButtonRect.Top, nil);
  LineTo (DC, AButtonRect.Left, AButtonRect.Bottom);
  DeleteObject (SepPen);


  if (FFocused or FActive) then
  begin
    Inc (AButtonRect.Right);
    Inc (AButtonRect.Bottom);
    Dec (AButtonRect.Top);
  end;

  Rectangle (DC, AButtonRect.Left, AButtonRect.Top, AButtonRect.Right, AButtonRect.Bottom);
  DeleteObject (Brush);
  DeleteObject (Pen);

  //Draw arrow
  Pen := CreatePen (PS_SOLID, 1, ColorToRGB (clBlack));
  SelectObject(DC, Pen);
  MoveToEx (DC, (AButtonRect.Right + AButtonRect.Left - 5) div 2, (AButtonRect.Top + AButtonRect.Bottom) div 2, nil);
  LineTo (DC, (AButtonRect.Right + AButtonRect.Left - 5) div 2 + 5, (AButtonRect.Top + AButtonRect.Bottom) div 2);

  MoveToEx (DC, (AButtonRect.Right + AButtonRect.Left - 5) div 2+1, (AButtonRect.Top + AButtonRect.Bottom) div 2+1, nil);
  LineTo (DC, (AButtonRect.Right + AButtonRect.Left - 5) div 2 + 4, (AButtonRect.Top + AButtonRect.Bottom) div 2+1);

  MoveToEx (DC, (AButtonRect.Right + AButtonRect.Left - 5) div 2+2, (AButtonRect.Top + AButtonRect.Bottom) div 2+2, nil);
  LineTo (DC, (AButtonRect.Right + AButtonRect.Left - 5) div 2 + 3, (AButtonRect.Top + AButtonRect.Bottom) div 2+2);

  DeleteObject (Pen);

end;


procedure TxpComboBox.DrawXPButton (DC : hDC; AButtonRect : TRect);
var
  ACanvas : TCanvas;
begin
  ACanvas := TCanvas.Create;
  try
    ACanvas.Handle := DC;

    ACanvas.Brush.Color := Color;
    ACanvas.Pen.Color := Color;
    ACanvas.FillRect (AButtonRect);

    Inc (AButtonRect.Top);
    Dec (AButtonRect.Bottom);
    Dec (AButtonRect.Right);

    if FFocused or FActive then
    begin
      ACanvas.Brush.Color := FxpStyle.ActiveButtonColor;
      ACanvas.Pen.Color := MakeDarkColor (FxpStyle.ActiveButtonColor, 20);
      ACanvas.RoundRect (AButtonRect.Left, AButtonRect.Top, AButtonRect.Right, AButtonRect.Bottom, 2, 2);
      InflateRect (AButtonRect, -2, -2);
      GradientFillRect (ACanvas, AButtonRect, FxpStyle.ActiveButtonColor, MakeDarkColor (FxpStyle.ActiveButtonColor, 10), fdTopToBottom, 5);
    end
    else
    begin
      ACanvas.Brush.Color := FxpStyle.InActiveButtonColor;
      ACanvas.Pen.Color := MakeDarkColor (FxpStyle.InActiveButtonColor, 20);
      ACanvas.RoundRect (AButtonRect.Left, AButtonRect.Top, AButtonRect.Right, AButtonRect.Bottom, 2, 2);
      InflateRect (AButtonRect, -2, -2);
      GradientFillRect (ACanvas, AButtonRect, FxpStyle.InActiveButtonColor, MakeDarkColor (FxpStyle.InActiveButtonColor, 10), fdTopToBottom, 5);
    end;

    //Arrow drawing
    ACanvas.Pen.Color := clNavy;
    ACanvas.MoveTo ((AButtonRect.Right + AButtonRect.Left - 5) div 2, (AButtonRect.Top + AButtonRect.Bottom) div 2);
    ACanvas.LineTo ((AButtonRect.Right + AButtonRect.Left - 5) div 2 + 5, (AButtonRect.Top + AButtonRect.Bottom) div 2);
    ACanvas.MoveTo ((AButtonRect.Right + AButtonRect.Left - 5) div 2+1, (AButtonRect.Top + AButtonRect.Bottom) div 2+1);
    ACanvas.LineTo ((AButtonRect.Right + AButtonRect.Left - 5) div 2 + 4, (AButtonRect.Top + AButtonRect.Bottom) div 2+1);
    ACanvas.MoveTo ((AButtonRect.Right + AButtonRect.Left - 5) div 2+2, (AButtonRect.Top + AButtonRect.Bottom) div 2+2);
    ACanvas.LineTo ((AButtonRect.Right + AButtonRect.Left - 5) div 2 + 3, (AButtonRect.Top + AButtonRect.Bottom) div 2+2);

  finally
    ACanvas.Free;
  end;
end;



procedure TxpComboBox.DrawButton (DC : hDC; AButtonRect : TRect; AStyle : TxpComboButtonStyle);
begin
  case AStyle of
    cbsFlat : DrawFlatButton (DC, AButtonRect);
    cbsXP   : DrawXPButton (DC, AButtonRect);
  end;
end;

procedure TxpComboBox.NCHitTest (var Message : TWMNCHitTest);
var
  WinRct : TRect;
begin
  if (not FxpStyle.Active) or (csDesigning in ComponentState) then
  begin
    inherited;
    exit;
  end;

  GetWindowRect (Handle, WinRct);

  Message.Result := 0;

  case Style of
    csDropDown:
      if PtInRect (Rect (WinRct.Right - FxpStyle.ButtonWidth - 2, WinRct.Top+1,
         WinRct.Right- 1, WinRct.Bottom-1), Point (Message.XPos, Message.YPos))
      then
      Message.Result := 1;
    csDropDownList, csOwnerDrawFixed, csOwnerDrawVariable:
      Message.Result := 1;
    csSimple:
      Message.Result := 0;
  end;

end;

procedure TxpComboBox.MouseEnter (var Message : TMessage);
begin
  if (not FActive) then
  begin
    FActive := true;
    if not DroppedDown then SendMessage (Handle, WM_NCPAINT, 0, 0);
  end;
end;

procedure TxpComboBox.MouseLeave (var Message : TMessage);
begin
  if FActive then
  begin
    FActive := False;
    if not DroppedDown then SendMessage (Handle, WM_NCPAINT, 0, 0);
  end;
end;

procedure TxpComboBox.WMSetFocus(var Message : TMessage);
begin
  inherited;
  if not FxpStyle.Active then exit;
  FFocused := true;
  SendMessage (Handle, WM_NCPAINT, 0, 0);
end;

procedure TxpComboBox.WMKillFocus(var Message : TMessage);
begin
  inherited;
  if not FxpStyle.Active then exit;
  FFocused := False;
  SendMessage (Handle, WM_NCPAINT, 0, 0);
end;

procedure TxpComboBox.WMCommand (var Message : TWMCOMMAND);
begin
  inherited;

  if Message.NotifyCode = EN_CHANGE then
  begin
    SendMessage (Handle, WM_NCPAINT, 0, 0);
  end;
end;

function TxpComboBox.LocateItem (AStartStr : String) : Integer;
var
  I : Integer;
begin
  Result := -1;
  if AStartStr = '' then Exit;
  I := 0;
  While I < Items.Count do
  begin
    if UpperCase (Copy (Items.Strings [I], 1, Length (AStartStr))) = UpperCase (AStartStr) then
    begin
      Result := I;
      I := Items.Count;
    end;
    Inc (I);
  end;
end;


procedure TxpComboBox.CNCommand (var Message : TWMCOMMAND);
var
  AItemIndex : Integer;
  AStr : String;
  DropRect : TRect;
begin
  inherited;
  if not FxpStyle.Active then Exit;

  case Message.NotifyCode of
    CBN_SELCHANGE:
    begin
      FOldText := Text;
      SendMessage (Handle, WM_NCPAINT, 0, 0);
      Invalidate;
    end;
    CBN_EDITUPDATE: //CBN_EDITCHANGE:
    begin
      if FxpStyle.FAutoSearch then
      begin
        if (not FLocating) and (Length (FOldText) < Length (Text)) then
        begin
          FLocating := true;
          try
            AItemIndex := LocateItem (Text);
            if AItemIndex <> -1 then
            begin
              AStr := Text;
              FOldText := Copy (Text, 1, Length (AStr));
              Self.ItemIndex := AItemIndex;
              SelStart := Length (AStr);
              SelLength := Length (Text) - Length (AStr);
              SendMessage (Handle, WM_NCPAINT, 0, 0);
            end;
          finally
            FLocating := False;
          end;
        end
        else
          FOldText := Copy (Text, 1, SelStart+1);
      end;

    end;
    CBN_CLOSEUP:
    begin
      try
        FBackground.FreeImage;
      except
      end;
      SendMessage (Handle, WM_NCPAINT, 0, 0);
    end;

    CBN_DROPDOWN:
    begin

        SendMessage (Handle, CB_GETDROPPEDCONTROLRECT, 0, LongInt (@DropRect));
        OffsetRect (DropRect, -DropRect.Left, -DropRect.Top);

        try
          FBackground.FreeImage;
        except
        end;
        FBackground.Width := DropRect.Right;
        FBackground.Height := DropRect.Bottom;

          case FxpStyle.BGStyle of
            cbgsGradient:
              begin
                GradientFillRect (FBackground.Canvas, DropRect, FxpStyle.BGStartColor,
                    FxpStyle.BGEndColor, FxpStyle.BGGradientFillDir, 60);
              end;
            cbgsTiledImage:
              begin
                if not FxpStyle.BGImage.Empty then
                  TileImage (FBackground.Canvas, DropRect, FxpStyle.BGImage)
                else
                begin
                  FBackground.Canvas.Brush.Color := Color;
                  FBackground.Canvas.FillRect (DropRect);
                end;
              end;
            cbgsStretchedImage:
              begin
                if not FxpStyle.BGImage.Empty then
                  FBackground.Canvas.StretchDraw (DropRect, FxpStyle.BGImage)
                else
                begin
                  FBackground.Canvas.Brush.Color := Color;
                  FBackground.Canvas.FillRect (DropRect);
                end;
              end;
          end;

    end;
    CBN_SETFOCUS:
    begin
      FFocused := true;
      SendMessage (Handle, WM_NCPAINT, 0, 0);
      Invalidate;
    end;
    CBN_KILLFOCUS:
    begin
      if FxpStyle.AutoSearch then
      begin
        AItemIndex := Perform (CB_FINDSTRINGEXACT, 0, LongInt (PChar (Text)));
        if AItemIndex >= 0 then ItemIndex := AItemIndex;
      end;
      FFocused := False;
      SendMessage (Handle, WM_NCPAINT, 0, 0);
    end;
  end;

end;

procedure TxpComboBox.WndProc( var Message: TMessage);
begin
  inherited WndProc(Message);
end;

procedure TxpComboBox.Notification(AComponent: TComponent;
  Operation: TOperation);
begin
  inherited Notification(AComponent, Operation);
  if Operation = opRemove then
    if AComponent = FxpStyle.Images then FxpStyle.Images := nil;
end;

procedure TxpComboBox.CMEnabledChanged (var Message: TMessage);
begin
  inherited;
  SendMessage (Handle, WM_NCPAINT, 0, 0);
  Invalidate;
end;


procedure Register;
begin
  RegisterComponents('XP Controls', [TxpComboBox]);
end;


end.