tntjvchecklistbox.pas

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

  I: Integer;
begin
  if MultiSelect then
    for I := 0 to Items.Count - 1 do
      Selected[I] := not Selected[I];
end;

{$IFDEF VCL}
procedure TTntJvCheckListBox.LBNSelCancel(var Msg: TMessage);
begin
  if Assigned(FOnSelectCancel) then
    FOnSelectCancel(Self);
end;

procedure TTntJvCheckListBox.CNDrawItem(var Msg: TWMDrawItem);
begin
  if (Items.Count = 0) or (Msg.DrawItemStruct.itemID >= UINT(Items.Count)) then
    Exit;
  {$IFDEF COMPILER5}
  with Msg.DrawItemStruct {$IFNDEF CLR}^{$ENDIF} do
    if Header[itemID] then
      if not UseRightToLeftAlignment then
        rcItem.Left := rcItem.Left - GetCheckWidth
      else
        rcItem.Right := rcItem.Right + GetCheckWidth;
  {$ENDIF COMPILER5}
  inherited;
end;
{$ENDIF VCL}

procedure TTntJvCheckListBox.LoadFromFile(FileName: TWideFileName);
var
  Stream: TTntFileStream;
begin
  Stream := TTntFileStream.Create(FileName, fmOpenRead or fmShareDenyWrite);
  try
    LoadFromStream(Stream);
  finally
    Stream.Free;
  end;
end;

procedure TTntJvCheckListBox.LoadFromStream(Stream: TStream);
var
  CheckLst: TCheckListRecord;
  Buf: array [0..1023] of WideChar;
begin
  Items.Clear;
  while Stream.Position + SizeOf(TCheckListRecord) <= Stream.Size do
  begin
    {$IFDEF CLR}
    Stream.Read(CheckLst.Checked);
    Stream.Read(CheckLst.StringSize);
    {$ELSE}
    Stream.Read(CheckLst, SizeOf(TCheckListRecord));
    {$ENDIF CLR}
    if (Stream.Position + CheckLst.StringSize <= Stream.Size) and
       (CheckLst.StringSize < High(Buf)) then
    begin
      {$IFDEF CLR}
      ReadCharsFromStream(Stream, Buf, CheckLst.StringSize);
      {$ELSE}
      Stream.Read(Buf, CheckLst.StringSize);
      {$ENDIF CLR}
      Buf[CheckLst.StringSize] := #0;
      Checked[Items.Add(Buf)] := CheckLst.Checked;
    end;
  end;
end;

{$IFDEF VCL}

procedure TTntJvCheckListBox.MouseEnter(Control: TControl);
begin
  if csDesigning in ComponentState then
    Exit;
  if not MouseOver then
  begin
    if HotTrack then
      Ctl3D := True;
    inherited MouseEnter(Control);
  end;
end;

procedure TTntJvCheckListBox.MouseLeave(Control: TControl);
begin
  if MouseOver then
  begin
    if HotTrack then
      Ctl3D := False;
    inherited MouseLeave(Control);
  end;
end;

procedure TTntJvCheckListBox.RefreshH;
var
  I: Integer;
  ItemWidth: Word;
begin
  FMaxWidth := 0;
  for I := 0 to Items.Count - 1 do
  begin
    ItemWidth := Canvas.TextWidth(Items[I] + ' ');
    if FMaxWidth < ItemWidth then
      FMaxWidth := ItemWidth;
  end;
  SetHScroll(FScroll);
end;

{$ENDIF VCL}

procedure TTntJvCheckListBox.SaveToFile(FileName: TWideFileName);
var
  Stream: TTntFileStream;
begin
  Stream := TTntFileStream.Create(FileName, fmCreate or fmShareExclusive);
  try
    SaveToStream(Stream);
  finally
    Stream.Free;
  end;
end;

procedure TTntJvCheckListBox.SaveToStream(Stream: TStream);
var
  I, J: Integer;
  CheckLst: TCheckListRecord;
  Buf: array [1..1023] of WideChar;
begin
  for I := 0 to Items.Count - 1 do
  begin
    CheckLst.Checked := Checked[I];
    CheckLst.StringSize := Length(Items[I]);
    {$IFDEF CLR}
    Stream.Write(CheckLst.Checked);
    Stream.Write(CheckLst.StringSize);
    {$ELSE}
    Stream.Write(CheckLst, SizeOf(TCheckListRecord));
    {$ENDIF CLR}
    for J := 1 to Length(Items[I]) do
      Buf[J] := Items[I][J];
    {$IFDEF CLR}
    WriteStringToStream(Stream, Buf, CheckLst.StringSize)
    {$ELSE}
    Stream.Write(Buf, CheckLst.StringSize);
    {$ENDIF CLR}
  end;
end;

function TTntJvCheckListBox.SearchExactString(Value: WideString;
  CaseSensitive: Boolean): Integer;
begin
  Result := TTntJvItemsSearchs.SearchExactString(Items, Value, CaseSensitive);
end;

function TTntJvCheckListBox.SearchPrefix(Value: WideString; CaseSensitive: Boolean): Integer;
begin
  Result := TTntJvItemsSearchs.SearchPrefix(Items, Value, CaseSensitive);
end;

function TTntJvCheckListBox.SearchSubString(Value: WideString;
  CaseSensitive: Boolean): Integer;
begin
  Result := TTntJvItemsSearchs.SearchSubString(Items, Value, CaseSensitive);
end;

procedure TTntJvCheckListBox.SelectAll;
var
  I: Integer;
begin
  if MultiSelect then
    for I := 0 to Items.Count - 1 do
      Selected[I] := True;
end;

{$IFDEF VCL}

procedure TTntJvCheckListBox.SetHotTrack(const Value: Boolean);
begin
  FHotTrack := Value;
  if FHotTrack then
    Ctl3D := False;
end;

procedure TTntJvCheckListBox.SetHScroll(const Value: Boolean);
begin
  FScroll := Value;
  if FScroll then
    SendMessage(Handle, LB_SETHORIZONTALEXTENT, FMaxWidth, 0);
end;

{$ENDIF VCL}

procedure TTntJvCheckListBox.UnCheckAll;
var
  I: Integer;
begin
  for I := 0 to Items.Count - 1 do
    Checked[I] := False;
end;

procedure TTntJvCheckListBox.UnselectAll;
var
  I: Integer;
begin
  if MultiSelect then
    for I := 0 to Items.Count - 1 do
      Selected[I] := False;
end;

{$IFDEF VCL}

procedure TTntJvCheckListBox.WMHScroll(var Msg: TWMHScroll);
var
  ScrollPos: Integer;
  R: TRect;
begin
  inherited;
  // (p3) what does this code do, really?
  if Msg.ScrollCode <> SB_ENDSCROLL then
  begin
    ScrollPos := GetScrollPos(Handle, SB_HORZ);
    if ScrollPos < 20 then
    begin
      R := ClientRect;
      R.Right := R.Left + 20;
      InvalidateRect(Handle, {$IFNDEF CLR}@{$ENDIF}R, False);
    end;
  end;
  if Assigned(FOnHScroll) then
    FOnHScroll(Self);
end;

procedure TTntJvCheckListBox.WMVScroll(var Msg: TWMVScroll);
begin
  inherited;
  if Assigned(FOnVScroll) then
    FOnVScroll(Self);
end;

procedure TTntJvCheckListBox.WndProc(var Msg: TMessage);
var
  ItemWidth: Word;
begin
  case Msg.Msg of
    LB_ADDSTRING, LB_INSERTSTRING:
      begin
        {$IFDEF CLR}
        if Msg.LParam <> 0 then
          ItemWidth := Canvas.TextWidth(Marshal.PtrToStringAuto(IntPtr(Msg.lParam)) + ' ')
        else
          ItemWidth := Canvas.TextWidth(' ');
        {$ELSE}
        ItemWidth := Canvas.TextWidth(StrPas(PChar(Msg.lParam)) + ' ');
        {$ENDIF CLR}
        if FMaxWidth < ItemWidth then
          FMaxWidth := ItemWidth;
        SetHScroll(FScroll);
      end;
    LB_DELETESTRING:
      begin
        ItemWidth := WideCanvasTextWidth(Canvas, Items[Msg.wParam] + ' ');
        if ItemWidth = FMaxWidth then
        begin
          inherited WndProc(Msg);
          RefreshH;
          Exit;
        end;
      end;
    LB_RESETCONTENT:
      begin
        FMaxWidth := 0;
        SetHScroll(FScroll);
      end;
    WM_SETFONT:
      begin
        inherited WndProc(Msg);
        Canvas.Font.Assign(Font);
        RefreshH;
        Exit;
      end;
  end;
  inherited WndProc(Msg);
end;

{$ENDIF VCL}

{$IFDEF UNITVERSIONING}
initialization
  RegisterUnitVersion(HInstance, UnitVersioning);

finalization
  UnregisterUnitVersion(HInstance);
{$ENDIF UNITVERSIONING}

end.