salphalistbox.pas

Alpha Controls 界面控件包

  TControlCanvas(FCanvas).Control := Self;
  FItemHeight := 16;
  FAutoComplete := True;
  FBorderStyle := bsSingle;
  FExtendedSelect := True;
  FAutoHideScroll := True;
  FCommonData := TsCommonData.Create(Self, True);
  FCommonData.COC := COC_TsAlphaListBox;
  if FCommonData.SkinSection = '' then FCommonData.SkinSection := s_Edit;
  FTopIndex := 0;
  FDisabledKind := DefDisabledKind;
  FBoundLabel := TsBoundLabel.Create(Self, FCommonData);
  FOldCount := -1;
  FAutoCompleteDelay := 500;
  DoubleBuffered := False;
end;

procedure TsAlphaListBox.CreateParams(var Params: TCreateParams);
type
  PSelects = ^TSelects;
  TSelects = array[Boolean] of DWORD;
const
  Styles: array[TListBoxStyle] of DWORD = (0, LBS_OWNERDRAWFIXED, LBS_OWNERDRAWVARIABLE, LBS_OWNERDRAWFIXED, LBS_OWNERDRAWFIXED);
  Sorteds: array[Boolean] of DWORD = (0, LBS_SORT);
  MultiSelects: array[Boolean] of DWORD = (0, LBS_MULTIPLESEL);
  ExtendSelects: array[Boolean] of DWORD = (0, LBS_EXTENDEDSEL);
  IntegralHeights: array[Boolean] of DWORD = (LBS_NOINTEGRALHEIGHT, 0);
  MultiColumns: array[Boolean] of DWORD = (0, LBS_MULTICOLUMN);
  TabStops: array[Boolean] of DWORD = (0, LBS_USETABSTOPS);
  CSHREDRAW: array[Boolean] of DWORD = (CS_HREDRAW, 0);
  Data: array[Boolean] of DWORD = (LBS_HASSTRINGS, LBS_NODATA);
var
  Selects: PSelects;
begin
  inherited CreateParams(Params);
  CreateSubClass(Params, 'LISTBOX');
  with Params do begin
    Selects := @MultiSelects;
    if FExtendedSelect then Selects := @ExtendSelects;

    Style := Style or ({WS_HSCROLL or }WS_VSCROLL or Data[Self.Style in [lbVirtual, lbVirtualOwnerDraw]] or
      LBS_NOTIFY) or Styles[FStyle] or Sorteds[FSorted] or Selects^[FMultiSelect] or IntegralHeights[FIntegralHeight] or
      MultiColumns[FColumns <> 0] or BorderStyles[FBorderStyle] or TabStops[FTabWidth <> 0];

    if FColumns <> 0 then Style := Style or WS_HSCROLL;

    if not FAutoHideScroll then Style := Style or LBS_DISABLENOSCROLL;// or WS_VSCROLL;

    if NewStyleControls and Ctl3D and (FBorderStyle = bsSingle) then begin
      Style := Style and not WS_BORDER;
      ExStyle := ExStyle or WS_EX_CLIENTEDGE;
    end;

    WindowClass.style := WindowClass.style and not (CSHREDRAW[UseRightToLeftAlignment] or CS_VREDRAW);

  end;
//  if Params.Style and (LBS_OWNERDRAWFIXED or LBS_OWNERDRAWVARIABLE) = 0
//    then Params.Style := Params.Style or LBS_OWNERDRAWFIXED; v5.05
end;

procedure TsAlphaListBox.CreateWnd;
var
  W, H: Integer;
begin
  W := Width;
  H := Height;
  inherited CreateWnd;
  SetWindowPos(Handle, 0, Left, Top, W, H, SWP_NOZORDER or SWP_NOACTIVATE);
  if FTabWidth <> 0 then SendMessage(Handle, LB_SETTABSTOPS, 1, Longint(@FTabWidth));
  SetColumnWidth;
  if (FOldCount <> -1) or Assigned(FSaveItems) then begin
    if (Style in [lbVirtual, lbVirtualOwnerDraw]) then
      Count := FOldCount;
    if FSaveItems <> nil then begin
      FItems.Assign(FSaveItems);
      FreeAndNil(FSaveItems);
    end;
    SetTopIndex(FSaveTopIndex);
    SetItemIndex(FSaveItemIndex);
    FOldCount := -1;
  end;
end;

procedure TsAlphaListBox.DeleteSelected;
var
  I: Integer;
begin
  if MultiSelect then begin
    for I := Items.Count - 1 downto 0 do if Selected[I] then Items.Delete(I);
  end
  else if ItemIndex <> -1 then Items.Delete(ItemIndex);
end;

procedure TsAlphaListBox.DeleteString(Index: Integer);
begin
  SendMessage(Handle, LB_DELETESTRING, Index, 0);
end;

destructor TsAlphaListBox.Destroy;
begin
  if ListSW <> nil then FreeAndNil(ListSW);
  FreeAndNil(FBoundLabel);
  if Assigned(FCommonData) then FreeAndNil(FCommonData);
  inherited Destroy;
  FCanvas.Free;
  FItems.Free;
  FSaveItems.Free;
end;

procedure TsAlphaListBox.DestroyWnd;
begin
  if (FItems.Count > 0) then begin
    if (Style in [lbVirtual, lbVirtualOwnerDraw]) then
      FOldCount := FItems.Count
    else begin
      FSaveItems := TStringList.Create;
      FSaveItems.Assign(FItems);
    end;
    FSaveTopIndex := GetTopIndex;
    FSaveItemIndex := GetItemIndex;
  end;
  inherited DestroyWnd;
end;

function TsAlphaListBox.DoFindData(const Data: String): Integer;
begin
  if Assigned(FOnDataFind) then Result := FOnDataFind(Self, Data) else Result := -1;
end;

function TsAlphaListBox.DoGetData(const Index: Integer): String;
begin
  if Assigned(FOnData) then FOnData(Self, Index, Result);
end;

function TsAlphaListBox.DoGetDataObject(const Index: Integer): TObject;
begin
  if Assigned(FOnDataObject) then FOnDataObject(Self, Index, Result);
end;

procedure TsAlphaListBox.DragCanceled;
var
  M: TWMMouse;
  MousePos: TPoint;
begin
  with M do begin
    Msg := WM_LBUTTONDOWN;
    GetCursorPos(MousePos);
    Pos := PointToSmallPoint(ScreenToClient(MousePos));
    Keys := 0;
    Result := 0;
  end;
  DefaultHandler(M);
  M.Msg := WM_LBUTTONUP;
  DefaultHandler(M);
end;

procedure TsAlphaListBox.DrawItem(Index: Integer; Rect: TRect; State: TOwnerDrawState);
var
  Flags: Longint;
//  TempBmp : Graphics.TBitmap;
//  R : TRect;
//  CI : TCacheInfo;
  Data : string;
begin
  if Index < 0 then Exit;
(*  if FCommonData.Skinned then begin
//    if FCommonData.BGChanged then PrepareCache;
{    if FCommonData.Skinned then if Self.ClientHeight = Height then begin
      Perform(CM_RECREATEWND, 0, 0); // Fixing of error in CalcSize..
      Perform(CM_INVALIDATE, 0, 0);
      Exit;
    end;}
    TempBmp := Graphics.TBitmap.Create;
    TempBmp.PixelFormat := pf24Bit;
    TempBmp.Width := WidthOf(Rect);
    TempBmp.Height := HeightOf(Rect);
    TempBmp.Canvas.Font.Assign(Font);
    try
      R := Classes.Rect(0, 0, TempBmp.Width, TempBmp.Height);
      if (odSelected in State) or ((Index = ItemIndex) and not Focused) then begin
        TempBmp.Canvas.Brush.Color := clHighlight;
        TempBmp.Canvas.Brush.Style := bsSolid;
        TempBmp.Canvas.FillRect(R);
        TempBmp.Canvas.Font.Color := clHighlightText;
      end
      else begin
        BitBlt(TempBmp.Canvas.Handle, 0, 0, TempBmp.Width, TempBmp.Height, SkinData.FCacheBmp.Canvas.Handle, Rect.Left + 3, Rect.Top + 3, SRCCOPY);
        State := [];
        TempBmp.Canvas.Brush.Color := clWhite;
        TempBmp.Canvas.Brush.Style := bsClear;
        TempBmp.Canvas.Font.Color := Font.Color;
      end;
      if not Assigned(FOnDrawItem) then {FOnDrawItem(Self, Index, Rect, State) else }begin
        R.Left := 2;
        if (Style in [lbVirtual, lbVirtualOwnerDraw]) then Data := DoGetData(Index) else Data := Items[Index];
        if (odSelected in State) or ((Index = ItemIndex) and not Focused) then begin
          WriteText(TempBmp.Canvas, PChar(Data), True, R, DT_SINGLELINE or DT_VCENTER or DT_NOPREFIX);
        end
        else begin
          DrawText(TempBmp.Canvas.Handle, PChar(Data), Length(Data), R, DT_SINGLELINE or DT_VCENTER or DT_NOPREFIX);
        end;
        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 := SkinData.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);
      if Assigned(FOnDrawItem) then FOnDrawItem(Self, Index, Rect, State);
    finally
      FreeAndNil(TempBmp);
    end;
  end
  else*) begin
    if not ((Style in [lbOwnerDrawFixed, lbOwnerDrawVariable, lbVirtualOwnerDraw]) and Assigned(OnDrawItem)) then FCanvas.FillRect(Rect);
    if Assigned(FOnDrawItem) then begin
      FCanvas.FillRect(Rect);
      FOnDrawItem(Self, Index, Rect, State);
      if odFocused in State then FCanvas.DrawFocusRect(Rect);
    end
    else 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);
      if (Style in [lbVirtual, lbVirtualOwnerDraw]) then Data := DoGetData(Index) else Data := Items[Index];
      DrawText(FCanvas.Handle, PChar(Data), Length(Data), Rect, Flags);
      if not UseRightToLeftAlignment then Dec(Rect.Left, 2) else Inc(Rect.Right, 2);
      if odFocused in State then DrawFocusRect(FCanvas.Handle, Rect);
    end;
  end;
end;

function TsAlphaListBox.GetCount: Integer;
begin
  if Style in [lbVirtual, lbVirtualOwnerDraw] then Result := FCount else Result := Items.Count;
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 MultiSelect
    then Result := SendMessage(Handle, LB_GETCARETINDEX, 0, 0)
    else Result := SendMessage(Handle, LB_GETCURSEL, 0, 0);
end;

function TsAlphaListBox.GetScrollWidth: Integer;
begin
  Result := SendMessage(Handle, LB_GETHORIZONTALEXTENT, 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
  R := SendMessage(Handle, LB_GETSEL, Index, 0);
  Result := LongBool(R);
end;

function TsAlphaListBox.GetTopIndex: Integer;
begin
  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 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
  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;

procedure TsAlphaListBox.KeyPress(var Key: Char);            
  procedure FindString;
  var
    Idx: Integer;
  begin
    if Style in [lbVirtual, lbVirtualOwnerDraw]
      then Idx := DoFindData(FFilter)
      else Idx := SendMessage(Handle, LB_FINDSTRING, -1, LongInt(PChar(FFilter)));
    if Idx <> LB_ERR then begin
      if MultiSelect then begin
        ClearSelection;
        SendMessage(Handle, LB_SELITEMRANGE, 1, MakeLParam(Idx, Idx))
      end;
      ItemIndex := Idx;
      Click;
    end;
    if not (Ord(Key) in [VK_RETURN, VK_BACK, VK_ESCAPE]) then Key := #0;  // Clear so that the listbox's default search mechanism is disabled
  end;
var
  Msg: TMsg;
begin
  inherited KeyPress(Key);
  if not FAutoComplete then exit;
//  if GetTickCount - FLastTime >= 500 then FFilter := '';
  if GetTickCount - FLastTime >= FAutoCompleteDelay then FFilter := '';
  FLastTime := GetTickCount;

  if Ord(Key) <> VK_BACK then begin
    if Key in LeadBytes then  begin
      if PeekMessage(Msg, Handle, WM_CHAR, WM_CHAR, PM_REMOVE) then begin
        FFilter := FFilter + Key + Chr(Msg.wParam);
        Key := #0;
      end;
    end