salphalistbox.pas

AlphaControls是一个Delphi标准控件的集合

        R := Classes.Rect(0, 0, TempBmp.Width, TempBmp.Height);
        if odFocused in State then DrawFocusRect(TempBmp.Canvas.Handle, R);
      end;
      if not Enabled then begin
        CI.Bmp := CommonData.FCacheBmp;
        CI.X := 0;
        CI.Y := 0;
        CI.Ready := True;
        BmpDisabledKind(TempBmp, FDisabledKind, Parent, CI, Point(Rect.Left + 3, Rect.Top + 3));
      end;
      BitBlt(Canvas.Handle, Rect.Left, Rect.Top, TempBmp.Width, TempBmp.Height, TempBmp.Canvas.Handle, 0, 0, SRCCOPY);
    finally
      FreeAndNil(TempBmp);
    end;
  end
  else if Assigned(FOnDrawItem) then FOnDrawItem(Self, Index, Rect, State) else begin
    FCanvas.FillRect(Rect);
    if (Index < Items.Count) and (Index > -1) then begin
      Flags := DrawTextBiDiModeFlags(DT_SINGLELINE or DT_VCENTER or DT_NOPREFIX);
      if not UseRightToLeftAlignment then Inc(Rect.Left, 2) else Dec(Rect.Right, 2);
      DrawText(FCanvas.Handle, PChar(Items[Index]), Length(Items[Index]), Rect, Flags);
    end;
  end;
end;

function TsAlphaListBox.GetItemData(Index: Integer): LongInt;
begin
  Result := SendMessage(Handle, LB_GETITEMDATA, Index, 0);
end;

function TsAlphaListBox.GetItemHeight: Integer;
var
  R: TRect;
begin
  Result := FItemHeight;
  if HandleAllocated and (FStyle = lbStandard) then begin
    Perform(LB_GETITEMRECT, 0, Longint(@R));
    Result := R.Bottom - R.Top;
  end;
end;

function TsAlphaListBox.GetItemIndex: Integer;
begin
  if FCommonData.Skinned then begin
    Result := SavedIndex;
  end
  else if MultiSelect
    then Result := SendMessage(Handle, LB_GETCARETINDEX, 0, 0)
    else Result := SendMessage(Handle, LB_GETCURSEL, 0, 0);
end;

function TsAlphaListBox.GetSelCount: Integer;
begin
  Result := SendMessage(Handle, LB_GETSELCOUNT, 0, 0);
end;

function TsAlphaListBox.GetSelected(Index: Integer): Boolean;
var
  R: Longint;
begin
  if FCommonData.Skinned then begin // !!! multiselect currently not used
    Result := Index = ItemIndex;
  end
  else begin
    R := SendMessage(Handle, LB_GETSEL, Index, 0);
//    if R = LB_ERR then raise EListError.CreateResFmt(SListIndexError, [Index]);
    Result := LongBool(R);
  end;
end;

function TsAlphaListBox.GetTopIndex: Integer;
begin
  if FCommonData.Skinned then begin
    Result := FTopIndex;
  end
  else Result := SendMessage(Handle, LB_GETTOPINDEX, 0, 0);
end;

function TsAlphaListBox.InternalGetItemData(Index: Integer): Longint;
begin
  Result := GetItemData(Index);
end;

procedure TsAlphaListBox.InternalSetItemData(Index, AData: Integer);
begin
  SetItemData(Index, AData);
end;

function TsAlphaListBox.ItemAtPos(Pos: TPoint; Existing: Boolean): Integer;
var
  Count: Integer;
  ItemRect: TRect;
begin
  if FCommonData.Skinned then begin
    Result := 0;
    Count := Items.Count;
    while Result < Count do begin
      Perform(LB_GETITEMRECT, Result, Longint(@ItemRect));
      if PtInRect(ItemRect, Pos) then begin
        inc(Result, TopIndex);
        Exit;
      end;
      Inc(Result);
    end;
    if not Existing then begin
      Exit;
    end;
  end
  else
  if PtInRect(ClientRect, Pos) then begin
    Result := TopIndex;
    Count := Items.Count;
    while Result < Count do begin
      Perform(LB_GETITEMRECT, Result, Longint(@ItemRect));
      if PtInRect(ItemRect, Pos) then Exit;
      Inc(Result);
    end;
    if not Existing then Exit;
  end;
  Result := -1;
end;

function TsAlphaListBox.ItemRect(Index: Integer): TRect;
var
  Count: Integer;
begin
  if FCommonData.Skinned then begin
    Count := Items.Count;
    if (Index = 0) or (Index < Count) then
      Perform(LB_GETITEMRECT, Index, Longint(@Result))
    else if Index = Count then begin
      Perform(LB_GETITEMRECT, Index - 1, Longint(@Result));
      OffsetRect(Result, 0, Result.Bottom - Result.Top);
    end else FillChar(Result, SizeOf(Result), 0);
  end
  else begin
    Count := Items.Count;
    if (Index = 0) or (Index < Count) then
      Perform(LB_GETITEMRECT, Index, Longint(@Result))
    else if Index = Count then begin
      Perform(LB_GETITEMRECT, Index - 1, Longint(@Result));
      OffsetRect(Result, 0, Result.Bottom - Result.Top);
    end else FillChar(Result, SizeOf(Result), 0);
  end;
end;

procedure TsAlphaListBox.LBGetItemRect(var Message: TMessage);
begin
  inherited;
end;

procedure TsAlphaListBox.Loaded;
begin
  inherited Loaded;
  FCommonData.Loaded;
  RefreshScrolls;
end;

procedure TsAlphaListBox.MeasureItem(Index: Integer; var Height: Integer);
begin
  if Assigned(FOnMeasureItem) then FOnMeasureItem(Self, Index, Height)
end;

procedure TsAlphaListBox.OnVSBChange(Sender: TObject; OldValue: integer);
begin
  if Assigned(VSBar) then begin
    Scrolling := True;
    FTopIndex := min(VSBar.Position, (Items.Count - VisibleRows) - 1);
    if VSBar.Position = VSBar.Max then begin
      if ItemRect(Items.Count - TopIndex).Bottom > Height - 3 then begin
        FTopIndex := TopIndex + 1;
      end;
    end;
{
    if ItemRect(ItemIndex - TopIndex).Bottom > Height - 3 then begin
      TopIndex := TopIndex + 1;
    end;
}
    if FCommondata.Skinned then begin
      FCommonData.BGChanged := True;
      Perform(CM_INVALIDATE, 0, 0);
    end;
    Scrolling := False;
    if Assigned(FOnVScroll) then begin
      FOnVScroll(Self);
    end;
  end;
end;

procedure TsAlphaListBox.Paint;
var
  i : integer;
begin
  if not ControlIsReady(Self) or Scrolling then Exit;
  if FCommonData.BGChanged then begin
    PrepareCache;
  end;
  // Update of piece w/o items
  i := ItemRect(Items.Count - 1).Bottom;
  if Items.Count < 1 then begin
    i := (Height - ClientHeight) div 2;
    BitBlt(Canvas.Handle, 0, 0, Width, Height, CommonData.FCacheBmp.Canvas.Handle, i, i, SRCCOPY);
  end
  else begin
    if i < Height - 3 then BitBlt(Canvas.Handle, 0, i, Width - 6, Height - 3 - i, CommonData.FCacheBmp.Canvas.Handle, 3, i + 3, SRCCOPY);
  end;
//  BitBlt(Canvas.Handle, 0, 0, Width - 6, Height - 6, CommonData.FCacheBmp.Canvas.Handle, 3, 3, SRCCOPY);
end;

procedure TsAlphaListBox.PrepareCache;
var
  CI : TCacheInfo;
begin
  try
    CommonData.InitCacheBmp;
    CI.Ready := False;
    CI := GetParentCache(CommonData);

    PaintItem(CommonData.SkinIndex, CommonData.SkinSection,
                 Ci, False, integer(ControlIsActive(CommonData)),
                 Rect(0, 0, Width, Height),
                 Point(Left, Top), CommonData.FCacheBmp);

    if not Enabled then begin
      BmpDisabledKind(FCommonData.FCacheBmp, FDisabledKind, Parent, CI, Point(Left, Top));
    end;

    CommonData.BGChanged := False;
  except
    Alert('TsAlphaListBox.PrepareCache error');
  end;
end;

procedure TsAlphaListBox.RefreshScrollBounds;
begin
  try
    if not Assigned(VSBar) then Exit;
    VSBar.SetBounds(Left + Width - VSBar.Width - 2, Top + 2, VSBar.Width, Height - 4);
  except
    alert('RefreshScrollBounds error');
  end;
end;

procedure TsAlphaListBox.RefreshScrolls;
var
  SI : TScrollInfo;
  SBI : TScrollBarInfo;
begin
  if not ControlIsReady(Self) then Exit;
  if Flag then Exit;
  Flag := True;

  SBI.cbSize := SizeOf(TScrollBarInfo);

  SI.cbSize := SizeOf(TScrollInfo);
  SI.fMask := SIF_ALL;

  if not GetScrollInfo(Handle, SB_VERT, SI) then begin
    Flag := False;
    Exit;
  end;
  if not GetScrollBarInfo(Handle, Integer(OBJID_VSCROLL), SBI) then begin
    Flag := False;
    Exit;
  end;
  if (not FCommonData.Skinned or not Visible or (SBI.rgstate[0] = STATE_SYSTEM_INVISIBLE) or (SBI.rgstate[0] = STATE_SYSTEM_UNAVAILABLE)) or (SI.nMax <= SI.nMin) then begin
    if Assigned(VSBar) then begin
      FreeAndNil(VSBar);
      Application.ProcessMessages;
    end;
    Flag := False;
    Exit;
  end;

  if (VSBar = nil) and not (SBI.rgstate[0] = STATE_SYSTEM_INVISIBLE) then begin
    VSBar := TsScrollBar.Create(Self);
    VSBar.LinkedControl := Self;
    VSBar.OnChange := OnVSBChange;
    VSBar.DrawingForbidden := True;
    VSBar.Parent := Parent;
    VSBar.Visible := True;
    VSBar.TabStop := False;
    VSBar.Kind := sbVertical;
    VSBar.Width := WidthOf(SBI.rcScrollBar) + 1;
  end;

  if Assigned(VSBar) and not (csDestroying in VSBar.ComponentState) then begin
    VSBar.DrawingForbidden := True;
    VSBar.Height := Height - 6;
    VSBar.Enabled := Enabled;
    if (SI.nMax < SI.nMin) or (SI.nMax = 0) or (SI.nMax - integer(SI.nPage) + 1 = 0) then begin
      VSBar.Max := 1;
      VSBar.Min := 0;
      VSBar.PageSize := 1;
      VSBar.Position := 0;
      VSBar.Enabled := False;
    end
    else begin
      if SI.nMax - integer(SI.nPage) > 0 then VSBar.Max := SI.nMax - integer(SI.nPage) else VSBar.Max := 1;
      VSBar.Min := SI.nMin;
      VSBar.Position := TopIndex;//SI.nPos;
      VSBar.PageSize := SI.nPage;
      if VSBar.PageSize > 0 then VSBar.LargeChange := VSBar.PageSize else VSBar.LargeChange := 1;
    end;
    RefreshScrollBounds;
    VSBar.DrawingForbidden := False;
  end;
  Flag := False;
end;

procedure TsAlphaListBox.ResetContent;
begin
  SendMessage(Handle, LB_RESETCONTENT, 0, 0);
end;

procedure TsAlphaListBox.SetBorderStyle(Value: TBorderStyle);
begin
  if FBorderStyle <> Value then begin
    FBorderStyle := Value;
    RecreateWnd;
  end;
end;

procedure TsAlphaListBox.SetColumns(Value: Integer);
begin
  if FColumns <> Value then begin
    if (FColumns = 0) or (Value = 0) then begin
      FColumns := Value;
      RecreateWnd;
    end else begin
      FColumns := Value;
      if HandleAllocated then SetColumnWidth;
    end;
  end;
end;

procedure TsAlphaListBox.SetColumnWidth;
var
  ColWidth: Integer;
begin
  if (FColumns > 0) and (Width > 0) then begin
    ColWidth := (Width + FColumns - 3) div FColumns;
    if ColWidth < 1 then ColWidth := 1;
    SendMessage(Handle, LB_SETCOLUMNWIDTH, ColWidth, 0);
  end;
end;

procedure TsAlphaListBox.SetDisabledKind(const Value: TsDisabledKind);
begin
  if FDisabledKind <> Value then begin
    FDisabledKind := Value;
    FCommonData.Invalidate;
  end;
end;

procedure TsAlphaListBox.SetExtendedSelect(Value: Boolean);
begin
  if Value <> FExtendedSelect then begin
    FExtendedSelect := Value;
    RecreateWnd;
  end;
end;

procedure TsAlphaListBox.SetIntegralHeight(Value: Boolean);
begin
  if Value <> FIntegralHeight then begin
    FIntegralHeight := Value;
    RecreateWnd;
    RequestAlign;
  end;
end;

procedure TsAlphaListBox.SetItemData(Index, AData: Integer);
begin
  SendMessage(Handle, LB_SETITEMDATA, Index, AData);
end;

procedure TsAlphaListBox.SetItemHeight(Value: Integer);
begin
  if (FItemHeight <> Value) and (Value > 0) then begin
    FItemHeight := Value;
    RecreateWnd;
  end;
end;

procedure TsAlphaListBox.SetItemIndex(Value: Integer);
var
  OldValue : integer;
begin
  if FCommonData.SKinned then begin
    if (SavedIndex <> Value) then begin
      if (Value < Items.Count) and (Value > -1) then begin
        OldValue := SavedIndex;
        SavedIndex := Value;
        inherited Changed;
        Click;
        UpdateListBox;
        ChangeSelected(OldValue, SavedIndex);
      end
      else if (Value = 1) then begin
        SavedIndex := Value;
        inherited Changed;
        Click;
      end;
    end;
  end
  else begin
    if GetItemIndex <> Value
      then if MultiSelect
             then SendMessage(Handle, LB_SETCARETINDEX, Value, 0)
             else SendMessage(Handle, LB_SETCURSEL, Value, 0);
  end;
end;

procedure TsAlphaListBox.SetItems(Value: TStrings);
begin
  Items.Assign(Value);
  if FCommonData.Skinned then RefreshScrolls;
end;

procedure TsAlphaListBox.SetMultiSelect(Value: Boolean);
begin
  if FMultiSelect <> Value then begin
    FMultiSelect := Value;
    RecreateWnd;
  end;
end;

procedure TsAlphaListBox.SetSelected(Index: Integer; Value: Boolean);
begin
  if FCommonData.SKinned then begin // !!! multiselect currently not used
  end
  else
    if SendMessage(Handle, LB_SETSEL, Longint(Value), Index)= LB_ERR then raise EListError.CreateResFmt(@SListIndexError, [Index]);
end;

procedure TsAlphaListBox.SetSorted(Value: Boolean);
begin
  if FSorted <> Value then begin
    FSorted := Value;
    RecreateWnd;
  end;
end;

procedure TsAlphaListBox.SetStyle(Value: TListBoxStyle);
begin
  if FStyle <> Value then begin
    FStyle := Value;
    RecreateWnd;