jvlistbox.pas

East make Tray Icon in delphi

      Len := SendMessage(ListBox.Handle, LB_GETTEXT, Index, Longint(PChar(Result)));
      SetLength(Result, Len);
    end;
  end;
end;

function TJvListBoxStrings.GetCount: Integer;
begin
  if (DestroyCount > 0) and UseInternal then
    Result := 0
  else
  begin
    if UseInternal then
      Result := InternalList.Count
    else
      Result := SendMessage(ListBox.Handle, LB_GETCOUNT, 0, 0);
  end;
end;

function TJvListBoxStrings.GetObject(Index: Integer): TObject;
begin
  if UseInternal then
    Result := InternalList.Objects[Index]
  else
  {$IFDEF COMPILER6_UP}
  if ListBox.Style in [lbVirtual, lbVirtualOwnerDraw] then
    Result := ListBox.DoGetDataObject(Index)
  else
  {$ENDIF COMPILER6_UP}
  begin
    Result := TObject(ListBox.GetItemData(Index));
    if Longint(Result) = LB_ERR then
      Error(SListIndexError, Index);
  end;
end;

procedure TJvListBoxStrings.Put(Index: Integer; const S: string);
var
  I: Integer;
  TempData: Longint;
begin
  if UseInternal then
    InternalList[Index] := S
  else
  begin
    ListBox.DeselectProvider;
    I := ListBox.ItemIndex;
    TempData := ListBox.InternalGetItemData(Index);
    // Set the Item to 0 in case it is an object that gets freed during Delete
    ListBox.InternalSetItemData(Index, 0);
    Delete(Index);
    InsertObject(Index, S, nil);
    ListBox.InternalSetItemData(Index, TempData);
    ListBox.ItemIndex := I;
  end;
end;

procedure TJvListBoxStrings.PutObject(Index: Integer; AObject: TObject);
begin
  if UseInternal then
    InternalList.Objects[Index] := AObject
  else
  begin
    if (Index <> -1) {$IFDEF COMPILER6_UP} and not (ListBox.Style in [lbVirtual, lbVirtualOwnerDraw]) {$ENDIF} then
    begin
      ListBox.DeselectProvider;
      ListBox.SetItemData(Index, Longint(AObject));
    end;
  end;
end;

procedure TJvListBoxStrings.SetUpdateState(Updating: Boolean);
begin
  FUpdating := Updating;
  if ListBox.HandleAllocated then
  begin
    SendMessage(ListBox.Handle, WM_SETREDRAW, Ord(not Updating), 0);
    if not Updating then
      ListBox.Refresh;
  end;
end;

procedure TJvListBoxStrings.SetWndDestroying(Destroying: Boolean);
begin
  if Destroying then
    Inc(FDestroyCnt)
  else
  if FDestroyCnt > 0 then
    Dec(FDestroyCnt);
end;

function TJvListBoxStrings.GetListBox: TJvCustomListBox;
begin
  Result := FListBox;
end;

procedure TJvListBoxStrings.SetListBox(Value: TJvCustomListBox);
begin
  FListBox := Value;
end;

function TJvListBoxStrings.GetInternalList: TStrings;
begin
  Result := FInternalList;
end;

function TJvListBoxStrings.Add(const S: string): Integer;
begin
  if (csLoading in ListBox.ComponentState) and UseInternal then
    Result := InternalList.Add(S)
  else
  begin
    {$IFDEF COMPILER6_UP}
    Result := -1;
    if ListBox.Style in [lbVirtual, lbVirtualOwnerDraw] then
      Exit;
    {$ENDIF COMPILER6_UP}
    ListBox.DeselectProvider;
    Result := SendMessage(ListBox.Handle, LB_ADDSTRING, 0, Longint(PChar(S)));
    if Result < 0 then
      raise EOutOfResources.CreateRes(@SInsertLineError);
  end;
end;

procedure TJvListBoxStrings.Clear;
begin
  if (FDestroyCnt <> 0) and UseInternal then
    Exit;
  if (csLoading in ListBox.ComponentState) and UseInternal then
    InternalList.Clear
  else
  begin
    ListBox.DeselectProvider;
    ListBox.ResetContent;
  end;
end;

procedure TJvListBoxStrings.Delete(Index: Integer);
begin
  if (csLoading in ListBox.ComponentState) and UseInternal then
    InternalList.Delete(Index)
  else
  begin
    ListBox.DeselectProvider;
    ListBox.DeleteString(Index);
  end;
end;

function TJvListBoxStrings.IndexOf(const S: string): Integer;
begin
  if UseInternal then
    Result := InternalList.IndexOf(S)
  else
  {$IFDEF COMPILER6_UP}
  if ListBox.Style in [lbVirtual, lbVirtualOwnerDraw] then
    Result := ListBox.DoFindData(S)
  else
  {$ENDIF COMPILER6_UP}
    Result := SendMessage(ListBox.Handle, LB_FINDSTRINGEXACT, -1, Longint(PChar(S)));
end;

procedure TJvListBoxStrings.Insert(Index: Integer; const S: string);
begin
  if (csLoading in ListBox.ComponentState) and UseInternal then
    InternalList.Insert(Index, S)
  else
  begin
    ListBox.DeselectProvider;
    {$IFDEF COMPILER6_UP}
    if ListBox.Style in [lbVirtual, lbVirtualOwnerDraw] then
      Exit;
    {$ENDIF COMPILER6_UP}
    if SendMessage(ListBox.Handle, LB_INSERTSTRING, Index, Longint(PChar(S))) < 0 then
      raise EOutOfResources.CreateRes(@SInsertLineError);
  end;
end;

procedure TJvListBoxStrings.Move(CurIndex, NewIndex: Integer);
var
  TempData: Longint;
  TempString: string;
begin
  if (csLoading in ListBox.ComponentState) and UseInternal then
    InternalList.Move(CurIndex, NewIndex)
  else
  begin
    {$IFDEF COMPILER6_UP}
    if ListBox.Style in [lbVirtual, lbVirtualOwnerDraw] then
      Exit;
    {$ENDIF COMPILER6_UP}
    BeginUpdate;
    ListBox.FMoving := True;
    try
      if CurIndex <> NewIndex then
      begin
        TempString := Get(CurIndex);
        TempData := ListBox.InternalGetItemData(CurIndex);
        ListBox.InternalSetItemData(CurIndex, 0);
        Delete(CurIndex);
        Insert(NewIndex, TempString);
        ListBox.InternalSetItemData(NewIndex, TempData);
      end;
    finally
      ListBox.FMoving := False;
      EndUpdate;
    end;
  end;
end;

{ Copies the strings at the list box to the FInternalList. To minimize the memory usage when a
  large list is used, each item copied is immediately removed from the list box list. }
procedure TJvListBoxStrings.MakeListInternal;
var
  Cnt: Integer;
  Text: array [0..4095] of Char;
  Len: Integer;
  S: string;
  Obj: TObject;
begin
  if ListBox.HandleAllocated then
    SendMessage(ListBox.Handle, WM_SETREDRAW, Ord(False), 0);
  try
    InternalList.Clear;
    if ListBox.HandleAllocated then
      Cnt := SendMessage(ListBox.Handle, LB_GETCOUNT, 0, 0)
    else
      Cnt := 0;
    while Cnt > 0 do
    begin
      Len := SendMessage(ListBox.Handle, LB_GETTEXT, 0, Longint(@Text));
      SetString(S, Text, Len);
      Obj := TObject(SendMessage(ListBox.Handle, LB_GETITEMDATA, 0, 0));
      SendMessage(ListBox.Handle, LB_DELETESTRING, 0, 0);
      InternalList.AddObject(S, Obj);
      Dec(Cnt);
    end;
  finally
    UseInternal := True;
    if not Updating and ListBox.HandleAllocated then
      SendMessage(ListBox.Handle, WM_SETREDRAW, Ord(True), 0);
  end;
end;

procedure TJvListBoxStrings.ActivateInternal;
var
  S: string;
  Obj: TObject;
  Index: Integer;
begin
  SendMessage(ListBox.Handle, WM_SETREDRAW, Ord(False), 0);
  try
    InternalList.BeginUpdate;
    try
      SendMessage(ListBox.Handle, LB_RESETCONTENT, 0, 0);
      while InternalList.Count > 0 do
      begin
        S := InternalList[0];
        Obj := InternalList.Objects[0];
        Index := SendMessage(ListBox.Handle, LB_ADDSTRING, 0, Longint(PChar(S)));
        if Index < 0 then
          raise EOutOfResources.CreateRes(@SInsertLineError);
        SendMessage(ListBox.Handle, LB_SETITEMDATA, Index, Longint(Obj));
        InternalList.Delete(0);
      end;
    finally
      InternalList.EndUpdate;
    end;
  finally
    if not Updating then
      SendMessage(ListBox.Handle, WM_SETREDRAW, Ord(True), 0);
    UseInternal := False;
  end;
end;

//=== { TJvCustomListBox } ===================================================

constructor TJvCustomListBox.Create(AOwner: TComponent);
var
  PI: PPropInfo;
  PStringsAddr: PStrings;
begin
  inherited Create(AOwner);
  // JvBMPListBox:
  //  Style := lbOwnerDrawFixed;

  { The following hack assumes that TJvListBox.Items reads directly from the private FItems field
    of TCustomListBox and that TJvListBox.Items is actually published.

    What we do here is remove the original string list used and place our own version in it's place.
    This would give us the benefit of keeping the list of strings (and objects) even if a provider
    is active and the list box windows has no strings at all. }
  FConsumerSvc := TJvDataConsumer.Create(Self, [DPA_RenderDisabledAsGrayed,
    DPA_ConsumerDisplaysList]);
  FConsumerSvc.OnChanging := ConsumerServiceChanging;
  FConsumerSvc.OnChanged := ConsumerServiceChanged;
  FConsumerSvc.AfterCreateSubSvc := ConsumerSubServiceCreated;
  FConsumerStrings := TJvConsumerStrings.Create(FConsumerSvc);
  PI := GetPropInfo(TJvListBox, 'Items');
  PStringsAddr := Pointer(Integer(PI.GetProc) and $00FFFFFF + Integer(Self));
  Items.Free;                                 // remove original item list (TListBoxStrings instance)
  PStringsAddr^ := GetItemsClass.Create;      // create our own implementation and put it in place.
  TJvListBoxStrings(Items).ListBox := Self;   // link it to the list box.

  FBackground := TJvListBoxBackground.Create;
  FBackground.OnChange := DoBackgroundChange;
  FScrollBars := ssBoth;
  FAlignment := taLeftJustify;
  FMultiline := False;
  FSelectedColor := clHighlight;
  FSelectedTextColor := clHighlightText;
  FDisabledTextColor := clGrayText;
  FShowFocusRect := True;
  //  Style := lbOwnerDrawVariable;

  FMaxWidth := 0;
  FHotTrack := False;
  // ControlStyle := ControlStyle + [csAcceptsControls];
end;

destructor TJvCustomListBox.Destroy;
begin
  FreeAndNil(FBackground);
  FreeAndNil(FConsumerStrings);
  FreeAndNil(FConsumerSvc);
  inherited Destroy;
end;

function TJvCustomListBox.GetItemsClass: TJvListBoxStringsClass;
begin
  Result := TJvListBoxStrings;
end;

procedure TJvCustomListBox.BeginRedraw;
begin
  SendMessage(Handle, WM_SETREDRAW, Ord(False), 0);
end;

procedure TJvCustomListBox.Changed;
begin
  // (rom) TODO?
  inherited Changed; // (marcelb): I added this, 'caus I assume it needs to be called.
end;

procedure TJvCustomListBox.FontChanged;
const
  CShowFocusRect: array [Boolean] of Integer = (0, 2);
begin
  inherited FontChanged;
  Canvas.Font := Font;
  if Style <> lbStandard then
    ItemHeight := CanvasMaxTextHeight(Canvas) + CShowFocusRect[ShowFocusRect];
  RemeasureAll;
end;

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

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

{ This routine is copied mostly from TCustomListbox.CNDRawItem.
  The setting of colors is modified.
  Drawing of the focus rectangle is delegated to DrawItem.}

procedure TJvCustomListBox.CNDrawItem(var Msg: TWMDrawItem);
var
  State: TOwnerDrawState;
begin
  with Msg.DrawItemStruct^ do
  begin
    State := TOwnerDrawState(LongRec(itemState).Lo);
    Canvas.Handle := hDC;
    Canvas.Font := Font;
    Canvas.Brush := Brush;
    if Integer(itemID) >= 0 then
    begin
      if odSelected in State then
      begin
        Canvas.Brush.Color := FSelectedColor;
        Canvas.Font.Color := FSelectedTextColor;
      end;
      if (([odDisabled, odGrayed] * State) <> []) or not Enabled then
        Canvas.Font.Color := FDisabledTextColor;
    end;
    if Integer(itemID) >= 0 then
      DrawItem(itemID, rcItem, State)
    else
    begin
      if Background.DoDraw then
      begin
        Perform(WM_ERASEBKGND, Canvas.Handle, 0);
        if odFocused in State then
          DrawFocusRect(hDC, rcItem);
      end
      else
      begin
        Canvas.FillRect(rcItem);
        if odFocused in State then
          DrawFocusRect(hDC, rcItem);
      end;
    end;
    Canvas.Handle := 0;
  end;
end;

procedure TJvCustomListBox.CNKeyDown(var Msg: TWMKeyDown);
begin
  if Background.DoDraw and (Msg.Result = 0) and
    (Msg.CharCode in [VK_LEFT, VK_RIGHT, VK_UP, VK_DOWN]) then
  begin
    BeginRedraw;
    try
      inherited;
    finally
      EndRedraw;
    end;
  end
  else
    inherited;
end;

procedure TJvCustomListBox.CreateDragImage(const S: string);
const