salphalistbox.pas

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

  end;
end;

procedure TsAlphaListBox.SetTabWidth(Value: Integer);
begin
  if Value < 0 then Value := 0;
  if FTabWidth <> Value then begin
    FTabWidth := Value;
    RecreateWnd;
  end;
end;

procedure TsAlphaListBox.SetTopIndex(Value: Integer);
begin
  if FCommonData.Skinned then begin
    if Value = -1 then Value := 0;
    if FTopIndex <> Value then begin
      FTopIndex := Value;
      if not Scrolling then begin
        FCommonData.BGChanged := True;
        Perform(CM_INVALIDATE, 0, 0);
        if Assigned(VSBar) then VSBar.Position := TopIndex;
      end;
    end;
  end
  else if GetTopIndex <> Value then SendMessage(Handle, LB_SETTOPINDEX, Value, 0);
end;

procedure TsAlphaListBox.UpdateListBox;
var
  MinTop, MaxTop : integer;
begin
  Mintop := ItemIndex - VisibleRows;
  Maxtop := ItemIndex + VisibleRows - 1;
  if FTopIndex > ItemIndex then begin
    TopIndex := ItemIndex;
  end
  else if TopIndex < MinTop then begin
    TopIndex := MinTop;
  end
  else if TopIndex > MaxTop then begin
    TopIndex := MaxTop;
  end;
  if ItemRect(ItemIndex - TopIndex).Bottom > Height - 3 then begin
    TopIndex := TopIndex + 1;
  end;
end;

function TsAlphaListBox.VisibleRows: integer;
begin
  Result := (Height - 6) div ItemHeight;
end;

procedure TsAlphaListBox.WMEraseBkgnd(var Message: TWMPaint);
var
  DC, SavedDC : hdc;
  PS : TPaintStruct;
begin
  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); 
  end;
  if (csDestroying in ComponentState) or (csLoading in ComponentState) then Exit;
  if FCommonData.Skinned then begin
    Message.Result := 1;

    if Scrolling then Exit;
    DC := Message.DC;
    if DC = 0 then DC := BeginPaint(Handle, PS);
    SavedDC := SaveDC(DC);
    Canvas.Lock;
    Canvas.Handle := DC;
    try;
      Paint;
      Canvas.Handle := 0;
    finally
      Canvas.Unlock;
      RestoreDC(DC, SavedDC);
    end;
  end else inherited;
end;

procedure TsAlphaListBox.WMKeyDown(var Message: TWMKeyDown);
begin
  if CommonData.Skinned then begin
    case Message.CharCode of
      VK_UP, VK_LEFT : ItemIndex := ItemIndex - 1;
      VK_DOWN, VK_RIGHT : ItemIndex := ItemIndex + 1;
      VK_HOME : ItemIndex := 0;
      VK_END : ItemIndex := Items.Count - 1;
      VK_PRIOR : ItemIndex := max(0, ItemIndex - VisibleRows);
      VK_NEXT : ItemIndex := min(Items.Count - 1, ItemIndex + VisibleRows)
      else inherited;
    end;
  end
  else inherited;
end;

procedure TsAlphaListBox.WMLButtonDown(var Message: TWMLButtonDown);
var
  ItemNo : Integer;
  ShiftState: TShiftState;
  p : TPoint;
  Value{, OldValue} : integer;
begin
  if FCommonData.Skinned then begin
    if not Focused then SetFocus;
    p := Point(Message.XPos, Message.YPos);
    Value := ItemAtPos(p, False);
    if (ItemIndex <> Value) and (Value < Items.Count) then begin
      ItemIndex := Value;
    end;
  end
  else begin
    ShiftState := KeysToShiftState(Message.Keys);
    if (DragMode = dmAutomatic) and FMultiSelect then begin
      if not (ssShift in ShiftState) or (ssCtrl in ShiftState) then begin
        ItemNo := ItemAtPos(SmallPointToPoint(Message.Pos), True);
        if (ItemNo >= 0) and (Selected[ItemNo]) then begin
          BeginDrag (False);
          Exit;
        end;
      end;
    end;
    inherited;
    if (DragMode = dmAutomatic) and not (FMultiSelect and ((ssCtrl in ShiftState) or (ssShift in ShiftState))) then BeginDrag(False);
  end;
end;

procedure TsAlphaListBox.WMNCCalcSize(var Message: TWMNCCalcSize);
begin
  inherited;
  if FCommonData.Skinned then begin
    if ((BorderStyle = bsNone) or (csCreating in ControlState))
      then InflateRect(Message.CalcSize_Params^.rgrc[0], -3, -3)
      else InflateRect(Message.CalcSize_Params^.rgrc[0], -1, -1)
  end;
end;

procedure TsAlphaListBox.WMNCPaint(var Message: TWMPaint);
const
  BW = 3;
var
  DC, SavedDC : hdc;
begin
  if FCommonData.Skinned then begin
    if (csDestroying in ComponentState) or (csLoading in ComponentState) then Exit;
    if CommonData.BGChanged then begin
      PrepareCache;
    end;
    DC := GetWindowDC(Handle);
    SavedDC := SaveDC(DC);
    try
      BitBlt(DC, 0, 0, Width, BW, CommonData.FCacheBmp.Canvas.Handle, 0, 0, SRCCOPY);
      // Left border update
      BitBlt(DC, 0, BW, BW, CommonData.FCacheBmp.Height - BW, CommonData.FCacheBmp.Canvas.Handle, 0, BW, SRCCOPY);
      // Bottom border update
      BitBlt(DC, BW,
                 Height - BW,
                 Width,// - BW * 2,
                 BW,
                 CommonData.FCacheBmp.Canvas.Handle,
                 BW,
                 Height - BW,
             SRCCOPY);
      // Right border update
      BitBlt(DC, CommonData.FCacheBmp.Width - BW, BW, BW, CommonData.FCacheBmp.Height - BW * 2, CommonData.FCacheBmp.Canvas.Handle, Width - BW, BW, SRCCOPY);

    finally
      RestoreDC(DC, SavedDC);
    end;
    if not (csDesigning in ComponentState) and Assigned(VSBar) then VSBar.Repaint;
  end
  else inherited;
end;

procedure TsAlphaListBox.WMPaint(var Message: TWMPaint);
  procedure PaintListBox;
  var
    DrawItemMsg: TWMDrawItem;
    MeasureItemMsg: TWMMeasureItem;
    DrawItemStruct: TDrawItemStruct;
    MeasureItemStruct: TMeasureItemStruct;
    R: TRect;
    Y, I, H, W: Integer;
  begin
    { Initialize drawing records }
    DrawItemMsg.Msg := CN_DRAWITEM;
    DrawItemMsg.DrawItemStruct := @DrawItemStruct;
    DrawItemMsg.Ctl := Handle;
    DrawItemStruct.CtlType := ODT_LISTBOX;
    DrawItemStruct.itemAction := ODA_DRAWENTIRE;
    DrawItemStruct.itemState := 0;
    DrawItemStruct.hDC := Message.DC;
    DrawItemStruct.CtlID := Handle;
    DrawItemStruct.hwndItem := Handle;

    { Intialize measure records }
    MeasureItemMsg.Msg := CN_MEASUREITEM;
    MeasureItemMsg.IDCtl := Handle;
    MeasureItemMsg.MeasureItemStruct := @MeasureItemStruct;
    MeasureItemStruct.CtlType := ODT_LISTBOX;
    MeasureItemStruct.CtlID := Handle;

    { Draw the listbox }
    Y := 0;
    I := TopIndex;
    GetClipBox(Message.DC, R);
    H := Height;
    W := Width;
    while Y < H do begin
      MeasureItemStruct.itemID := I;
      if I < Items.Count then
        MeasureItemStruct.itemData := Longint(Pointer(Items.Objects[I]));
      MeasureItemStruct.itemWidth := W;
      MeasureItemStruct.itemHeight := FItemHeight;
      DrawItemStruct.itemData := MeasureItemStruct.itemData;
      DrawItemStruct.itemID := I;
      Dispatch(MeasureItemMsg);
      DrawItemStruct.rcItem := Rect(0, Y, MeasureItemStruct.itemWidth,
        Y + Integer(MeasureItemStruct.itemHeight));
      Dispatch(DrawItemMsg);
      Inc(Y, MeasureItemStruct.itemHeight);
      Inc(I);
      if I >= Items.Count then break;
    end;
  end;

begin
  if Items.Count < 1 then Perform(WM_ERASEBKGND, 0, 0); 
  if (Message.DC <> 0) then
    { Listboxes don't allow paint "sub-classing" like the other windows controls
      so we have to do it ourselves. }
    PaintListBox
  else inherited;
  if (csDesigning in ComponentState) and Assigned(VSBar) then VSBar.Repaint;
end;

procedure TsAlphaListBox.WMSize(var Message: TWMSize);
begin
  inherited;
  SetColumnWidth;
end;

procedure TsAlphaListBox.WndProc(var Message: TMessage);
begin
  case Message.Msg of
    SM_SETNEWSKIN : begin
      SavedIndex := ItemIndex;
    end;
  end;
  if Assigned(CommonData) then CommonData.WndProc(Message);
  {for auto drag mode, let listbox handle itself, instead of TControl}
  if not (csDesigning in ComponentState) and ((Message.Msg = WM_LBUTTONDOWN) or
                            (Message.Msg = WM_LBUTTONDBLCLK)) and not Dragging then begin
    if DragMode = dmAutomatic then begin
      if IsControlMouseMsg(TWMMouse(Message)) then Exit;
      ControlState := ControlState + [csLButtonDown];
      Dispatch(Message);
      Exit;
    end;
  end;

  if Assigned(CommonData) and FCommonData.Skinned then begin
    case Message.Msg of
      CM_VISIBLECHANGED, WM_SIZE, CM_ENABLEDCHANGED, WM_MOUSEWHEEL, WM_MOVE : if FCommonData.Skinned then begin
        FCommonData.BGChanged := True;
        Repaint;
        SendMessage(Handle, WM_NCPAINT, 0, 0);
        RefreshScrolls;
      end;
      WM_SETFOCUS, CM_ENTER, WM_KILLFOCUS, CM_EXIT: if FCommonData.Skinned then begin
        FCommonData.FFocused := (Message.Msg = CM_ENTER) or (Message.Msg = WM_SETFOCUS);
        FCommonData.FMouseAbove := False;
        FCommonData.BGChanged := True;
        Repaint;
        SendMessage(Handle, WM_NCPAINT, 0, 0);
        if Assigned(VSBar) then VSBar.Repaint;
      end;
      WM_VSCROLL : begin
        exit;
      end;
      CM_MOUSELEAVE, CM_MOUSEENTER : begin
        if not FCommonData.FFocused and not(csDesigning in ComponentState) then begin
          FCommonData.FMouseAbove := Message.Msg = CM_MOUSEENTER;
          FCommonData.BGChanged := True;
          SendMessage(Handle, WM_NCPAINT, 0, 0);
          Repaint;
          if Assigned(VSBar) then VSBar.Repaint;
        end;
      end;
    end;
  end;
  if Message.Result <> 1 then inherited WndProc(Message);
  case Message.Msg of
    SM_SETNEWSKIN : begin
      UpdateListBox;
      if Assigned(VSBar) then VSBar.Position := TopIndex;
    end;
    SM_REMOVESKIN : if not (csDestroying in ComponentState) then begin
      ItemIndex := SavedIndex;
      Repaint;
      SendMessage(Handle, WM_NCPAINT, 0, 0);
      RefreshScrolls;
    end;
    SM_REFRESH : begin
      Application.ProcessMessages; // Waiting for background repainting
      FCommonData.Invalidate;
      RefreshScrolls;
      if Assigned(VSBar) then VSBar.Position := TopIndex;
      if Assigned(VSBar) then VSBar.Repaint;
    end;
  end;
end;

{ TListBoxStrings }

function TListBoxStrings.GetCount: Integer;
begin
  Result := SendMessage(ListBox.Handle, LB_GETCOUNT, 0, 0);
end;

function TListBoxStrings.Get(Index: Integer): string;
var
  Len: Integer;
  Text: array[0..4095] of Char;
begin
  Len := SendMessage(ListBox.Handle, LB_GETTEXT, Index, Longint(@Text));
  if Len < 0 then Error(SListIndexError, Index);
  SetString(Result, Text, Len);
end;

function TListBoxStrings.GetObject(Index: Integer): TObject;
begin
  Result := TObject(ListBox.GetItemData(Index));
  if Longint(Result) = LB_ERR then Error(SListIndexError, Index);
end;

procedure TListBoxStrings.Put(Index: Integer; const S: string);
var
  I: Integer;
  TempData: Longint;
begin
  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;

procedure TListBoxStrings.PutObject(Index: Integer; AObject: TObject);
begin
  ListBox.SetItemData(Index, LongInt(AObject));
end;

function TListBoxStrings.Add(const S: string): Integer;
begin
  Result := SendMessage(ListBox.Handle, LB_ADDSTRING, 0, Longint(PChar(S)));
  if Result < 0 then raise EOutOfResources.Create(SInsertLineError);
//  if not Updating then Update;
end;

procedure TListBoxStrings.Insert(Index: Integer; const S: string);
begin
  if SendMessage(ListBox.Handle, LB_INSERTSTRING, Index,
    Longint(PChar(S))) < 0 then
    raise EOutOfResources.Create(SInsertLineError);
//  if not Updating then Update;
end;

procedure TListBoxStrings.Delete(Index: Integer);
begin
  ListBox.DeleteString(Index);
//  if not Updating then Update;
end;

procedure TListBoxStrings.Exchange(Index1, Index2: Integer);
var
  TempData: Longint;
  TempString: string;
begin
  BeginUpdate;
  try
    TempString := Strings[Index1];
    TempData := ListBox.InternalGetItemData(Index1);
    Strings[Index1] := Strings[Index2];
    ListBox.InternalSetItemData(Index1, ListBox.InternalGetItemData(Index2));
    Strings[Index2] := TempString;
    ListBox.InternalSetItemData(Index2, TempData);
    if ListBox.ItemIndex = Index1 then
      ListBox.ItemIndex := Index2
    else if ListBox.ItemIndex = Index2 then
      ListBox.ItemIndex := Index1;  
  finally
    EndUpdate;
  end;
end;

procedure TListBoxStrings.Clear;
begin
  ListBox.ResetContent;
//  if not Updating then Update;
end;

procedure TListBoxStrings.SetUpdateState(Updating: Boolean);
begin
  SendMessage(ListBox.Handle, WM_SETREDRAW, Ord(not Updating), 0);
  if not Updating then begin ListBox.Refresh; Update; end;
end;

function TListBoxStrings.IndexOf(const S: string): Integer;
begin
  Result := SendMessage(ListBox.Handle, LB_FINDSTRINGEXACT, -1, LongInt(PChar(S)));
end;

procedure TListBoxStrings.Move(CurIndex, NewIndex: Integer);
var
  TempData: Longint;
  TempString: string;
begin
  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;

procedure TListBoxStrings.Update;
begin
  if Assigned(ListBox) then ListBox.RefreshScrolls;
end;

end.