newchecklistbox.pas

源代码

end;

{ TNewCheckListBoxHintWindow }

{$IFNDEF DELPHI2}

procedure TNewCheckListBoxHintWindow.CreateParams(var Params: TCreateParams);
const
  CS_DROPSHADOW = $00020000;
begin
  inherited;
  if (Win32Platform = VER_PLATFORM_WIN32_NT) and
     ((Win32MajorVersion > 5) or
      ((Win32MajorVersion = 5) and (Win32MinorVersion >= 1))) then
    Params.WindowClass.Style := Params.WindowClass.Style or CS_DROPSHADOW;
end;

procedure TNewCheckListBoxHintWindow.ActivateHintData(Rect: TRect;
  const AHint: string; AData: Pointer);
begin
  if AData <> nil then
    Canvas.Font.Assign(TFont(AData));
  ActivateHint(Rect, AHint);
end;

function TNewCheckListBoxHintWindow.CalcHintRect(MaxWidth: Integer;
  const AHint: string; AData: Pointer): TRect;
begin
  if AData <> nil then
    Canvas.Font.Assign(TFont(AData));
  Result := inherited CalcHintRect(MaxWidth, AHint, nil);
end;

function TNewCheckListBoxHintWindow.IsHintMsg(var Msg: TMsg): Boolean;
begin
  Result := inherited IsHintMsg(Msg) and
    ((Msg.Message <> WM_LBUTTONDOWN) and (Msg.Message <> WM_LBUTTONUP) and
     (Msg.Message <> WM_LBUTTONDBLCLK));
end;

procedure TNewCheckListBoxHintWindow.WMNCPaint(var Message: TMessage);
begin
  Canvas.Handle := GetWindowDC(Handle);
  with Canvas do
    try
      Canvas.Pen.Color := clWindowFrame;
      Canvas.Pen.Width := 1;
      Canvas.Rectangle(0, 0, Width, Height);
      //DrawEdge(Handle, R, BDR_RAISEDOUTER, BF_RECT); // as Borland does
    finally
      Canvas.Handle := 0;
    end;
end;

{$ENDIF}

{ TNewCheckListBox }

constructor TNewCheckListBox.Create(AOwner: TComponent);
begin
  inherited Create(AOwner);

  with TBitmap.Create do
  begin
    try
      Handle := LoadBitmap(0, PChar(OBM_CHECKBOXES));
      FCheckWidth := Width div 4;
      FCheckHeight := Height div 3;
    finally
      Free;
    end;
  end;

  FStateList := TList.Create;
  FMinItemHeight := 16;
  FOffset := 4;
  FShowLines := True;
  Style := lbOwnerDrawVariable;
  FHotIndex := -1;
  FCaptureIndex := -1;
end;

procedure TNewCheckListBox.CreateWnd;
var
  I: Integer;
begin
  inherited;
  for I := Items.Count-1 downto 0 do
    RemeasureItem(I);
end;

procedure TNewCheckListBox.UpdateThemeData(const Close, Open: Boolean);
begin
  if Close then begin
    if FThemeData <> 0 then begin
      CloseThemeData(FThemeData);
      FThemeData := 0;
    end;
  end;

  if Open then begin
    if UseThemes then
      FThemeData := OpenThemeData(Handle, 'Button')
    else
      FThemeData := 0;
  end;
end;

procedure TNewCheckListBox.CreateWindowHandle(const Params: TCreateParams);
begin
  inherited CreateWindowHandle(Params);
  UpdateThemeData(True, True);
end;

destructor TNewCheckListBox.Destroy;
var
  I: Integer;
begin
  if Assigned(FAccObjectInstance) then begin
    { Detach from FAccObjectInstance if someone still has a reference to it }
    TAccObject(FAccObjectInstance).ControlDestroying;
    FAccObjectInstance := nil;
  end;
  if Assigned(FStateList) then begin
    for I := FStateList.Count-1 downto 0 do
      TItemState(FStateList[I]).Free;
    FStateList.Free;
  end;
  UpdateThemeData(True, False);
  inherited Destroy;
end;

function TNewCheckListBox.AddCheckBox(const ACaption, ASubItem: string;
  ALevel: Byte; AChecked, AEnabled, AHasInternalChildren,
  ACheckWhenParentChecked: Boolean; AObject: TObject): Integer;
begin
  if not AEnabled and CheckPotentialRadioParents(Items.Count, ALevel) then
    raise Exception.Create(sRadioCantHaveDisabledChildren);
  Result := AddItem(itCheck, ACaption, ASubItem, ALevel, AChecked, AEnabled,
    AHasInternalChildren, ACheckWhenParentChecked, AObject);
end;

function TNewCheckListBox.AddGroup(const ACaption, ASubItem: string;
  ALevel: Byte; AObject: TObject): Integer;
begin
  Result := AddItem(itGroup, ACaption, ASubItem, ALevel, False, True, False,
    True, AObject);
end;

function TNewCheckListBox.AddRadioButton(const ACaption, ASubItem: string;
  ALevel: Byte; AChecked, AEnabled: Boolean; AObject: TObject): Integer;
begin
  if not AEnabled then
    AChecked := False;
  Result := AddItem(itRadio, ACaption, ASubItem, ALevel, AChecked, AEnabled,
    False, True, AObject);
end;

function TNewCheckListBox.CanFocusItem(Item: Integer): Boolean;
begin
  with ItemStates[Item] do
    Result := Self.Enabled and Enabled and (ItemType <> itGroup);
end;

function TNewCheckListBox.CheckPotentialRadioParents(Index, ALevel: Integer): Boolean;
begin
  Result := True;
  Dec(Index);
  Dec(ALevel);
  while Index >= 0 do
  begin
    with ItemStates[Index] do
      if Level = ALevel then
        if ItemType = itRadio then
          Exit
        else
          Break;
    Dec(Index);
  end;
  if Index >= 0 then
  begin
    Index := GetParentOf(Index);
    while Index >= 0 do
    begin
      if ItemStates[Index].ItemType = itRadio then
        Exit;
      Index := GetParentOf(Index);
    end;
  end;
  Result := False;
end;

procedure TNewCheckListBox.CMDialogChar(var Message: TCMDialogChar);
var
  I: Integer;
begin
  if FWantTabs and CanFocus then
    with Message do
    begin
      I := FindAccel(CharCode);
      if I >= 0 then
      begin
        SetFocus;
        if (FCaptureIndex <> I) or FSpaceDown then EndCapture(not FSpaceDown);
        ItemIndex := I;
        Toggle(I);
        Result := 1
      end;
    end;
end;

procedure TNewCheckListBox.CMEnter(var Message: TCMEnter);
var
  GoForward, Arrows: Boolean;
begin
  if FWantTabs and FFormFocusChanged and (GetKeyState(VK_LBUTTON) >= 0) then
  begin
    if GetKeyState(VK_TAB) < 0 then begin
      Arrows := False;
      GoForward := (GetKeyState(VK_SHIFT) >= 0);
    end
    else if (GetKeyState(VK_UP) < 0) or (GetKeyState(VK_LEFT) < 0) then begin
      Arrows := True;
      GoForward := False;
    end
    else if (GetKeyState(VK_DOWN) < 0) or (GetKeyState(VK_RIGHT) < 0) then begin
      Arrows := True;
      GoForward := True;
    end
    else begin
      { Otherwise, just select the first item }
      Arrows := False;
      GoForward := True;
    end;
    if GoForward then
      ItemIndex := FindNextItem(-1, True, not Arrows)
    else
      ItemIndex := FindNextItem(Items.Count, False, not Arrows)
  end;
  inherited;
end;

procedure TNewCheckListBox.CMExit(var Message: TCMExit);
begin
  EndCapture(not FSpaceDown or (GetKeyState(VK_MENU) >= 0));
  inherited;
end;

procedure TNewCheckListBox.CMFocusChanged(var Message: TCMFocusChanged);
begin
  FFormFocusChanged := True;
  inherited;
end;

procedure TNewCheckListBox.CMFontChanged(var Message: TMessage);
begin
  inherited;
  Canvas.Font := Font;
end;

procedure LineDDAProc(X, Y: Integer; Canvas: TCanvas); stdcall;
begin
  if ((X xor Y) and 1) = 0 then
  begin
    Canvas.MoveTo(X, Y);
    Canvas.LineTo(X + 1, Y)
  end;
end;

{$IFDEF DELPHI2}

procedure TNewCheckListBox.ApplicationShowHintHook(var HintStr: string;
  var CanShow: Boolean; var HintInfo: THintInfo);
begin
  Application.OnShowHint := FActiveShowHintHandler;
  if HintInfo.HintControl = Self then
  begin
    HintStr := FHintStr;
    FHintStr := ''
  end
  else
    if Assigned(FActiveShowHintHandler) then
      FActiveShowHintHandler(HintStr, CanShow, HintInfo);
end;

type
  PHintInfo = ^THintInfo;

{$ENDIF}

procedure TNewCheckListBox.CMHintShow(var Message: TMessage);
var
  HintInfo: PHintInfo;
  P: TPoint;
  R: TRect;
  I, OldLeft: Integer;
  ItemSize, SubItemSize: TSize;

  procedure CheckAccelChar(var S: string);
  var
    L, J: Integer;
  begin
    if FWantTabs and (ItemStates[I].ItemType <> itGroup) then
    begin
      L := Length(S);
      J := 1;
      while (L > 0) and (J <= L) do
      begin
        if (S[J] = '&') and ((J < L) and (S[J+1] <> '&')) then
        begin
          Delete(S, J, 1);
          Dec(L);
        end;
        Inc(J);
      end
    end;
  end;
  
begin
  HintInfo := PHintInfo(Message.lParam);
  P := HintInfo.CursorPos;
  I := ItemAtPos(P, True);
  if I >= 0 then
  begin
    GetTextExtentPoint32(Canvas.Handle, PChar(ItemSubItem[I]),
      Length(ItemSubItem[I]), SubItemSize);
    GetTextExtentPoint32(Canvas.Handle, PChar(Items[I]), Length(Items[I]), ItemSize);
    R := ItemRect(I);
    OldLeft := R.Left;
    if ItemStates[I].ItemType <> itGroup then
      Inc(R.Left, (FCheckWidth + 2 * FOffset) * (ItemLevel[I] + 1));
    if R.Left + ItemSize.cx > R.Right - (SubItemSize.cx + Offset * 2) then
      with HintInfo^ do
      begin
        HintPos := ClientToScreen(R.TopLeft);
        Inc(HintPos.y, (R.Bottom - R.Top - Canvas.TextHeight('Wg')) div 2 - 1);
        {$IFDEF DELPHI2}
        Dec(HintPos.x, 1);
        {$ELSE}
        Dec(HintPos.y, 2);
        Dec(HintPos.x, 2);
        {$ENDIF}
        if FWantTabs then
          Dec(HintPos.y)
        else
          Inc(HintPos.x);
        CursorRect := R;
        CursorRect.Left := OldLeft; // always 0 for single column listbox
        {$IFDEF DELPHI2}
        FHintStr := Items[I];
        CheckAccelChar(FHintStr);
        FActiveShowHintHandler := Application.OnShowHint;
        Application.OnShowHint := ApplicationShowHintHook;
        {$ELSE}
        HintStr := Items[I];
        CheckAccelChar(HintStr);
        HideTimeout := MaxInt;
        HintData := Pointer(Font);
        HintWindowClass := TNewCheckListBoxHintWindow;
        {$ENDIF}
        Message.Result := 0;
        {$IFDEF HINTSHOWPAUSE}
        FHintsShowing := True;
        {$ENDIF}
        Exit;
      end;
  end;
  {$IFNDEF DELPHI2}
  Application.HideHint;
  {$IFDEF HINTSHOWPAUSE}
  HintInfo.ReshowTimeout := Ord(FHintsShowing);
  Message.Result := Ord(not FHintsShowing);
  FHintsShowing := True;
  {$ELSE}
  Message.Result := 0;
  {$ENDIF}
  {$ENDIF}
end;

{$IFDEF HINTSHOWPAUSE}

procedure TNewCheckListBox.CMHintShowPause(var Message: TMessage);
begin
  if (Message.WParam <> 0) or (FHintsShowing and FShowHintImmediately) then
    PInteger(Message.lParam)^ := 0;
  FShowHintImmediately := False;
end;

{$ENDIF}

procedure TNewCheckListBox.CMWantSpecialKey(var Message: TMessage);
begin
  Message.Result := Ord(FWantTabs and (Message.WParam = VK_TAB));
end;

procedure TNewCheckListBox.CNDrawItem(var Message: TWMDrawItem);
var
  L: Integer;