?? tflatchecklistboxunit.pas
字號:
// Draw the down arrow
y := ClientRect.Bottom - 7;
if (firstItem + maxItems + 1 <= FItems.Count) and Enabled then
begin
canvas.Brush.Color := FArrowColor;
canvas.Pen.Color := FArrowColor;
canvas.Polygon([Point(X + 4, Y), Point(X + 8, Y), Point(X + 6, Y + 2)]);
end
else
begin
canvas.Brush.Color := clWhite;
canvas.Pen.Color := clWhite;
Inc(x); Inc(y);
canvas.Polygon([Point(X + 4, Y), Point(X + 8, Y), Point(X + 6, Y + 2)]);
Dec(x); Dec(y);
canvas.Brush.Color := clGray;
canvas.Pen.Color := clGray;
canvas.Polygon([Point(X + 4, Y), Point(X + 8, Y), Point(X + 6, Y + 2)]);
end;
end;
procedure TFlatCheckListBox.DrawCheckRect (canvas: TCanvas; start: TPoint; checked: Boolean);
var
CheckboxRect: TRect;
begin
{$IFDEF DFS_COMPILER_4_UP}
if BidiMode = bdRightToLeft then
CheckboxRect := Rect(start.x - 14, start.y + 3, start.x - 3, start.y + 14)
else
CheckboxRect := Rect(start.x + 3, start.y + 3, start.x + 14, start.y + 14);
{$ELSE}
CheckboxRect := Rect(start.x + 3, start.y + 3, start.x + 14, start.y + 14);
{$ENDIF}
canvas.pen.style := psSolid;
canvas.pen.width := 1;
// Background
canvas.brush.color := FItemsRectColor;
canvas.pen.color := FItemsRectColor;
canvas.FillRect(CheckboxRect);
// Tick
if Checked then
begin
canvas.pen.color := FCheckColor;
canvas.penpos := Point(CheckboxRect.left+2, CheckboxRect.top+4);
canvas.lineto(CheckboxRect.left+6, CheckboxRect.top+8);
canvas.penpos := Point(CheckboxRect.left+2, CheckboxRect.top+5);
canvas.lineto(CheckboxRect.left+5, CheckboxRect.top+8);
canvas.penpos := Point(CheckboxRect.left+2, CheckboxRect.top+6);
canvas.lineto(CheckboxRect.left+5, CheckboxRect.top+9);
canvas.penpos := Point(CheckboxRect.left+8, CheckboxRect.top+2);
canvas.lineto(CheckboxRect.left+4, CheckboxRect.top+6);
canvas.penpos := Point(CheckboxRect.left+8, CheckboxRect.top+3);
canvas.lineto(CheckboxRect.left+4, CheckboxRect.top+7);
canvas.penpos := Point(CheckboxRect.left+8, CheckboxRect.top+4);
canvas.lineto(CheckboxRect.left+5, CheckboxRect.top+7);
end;
// Border
canvas.brush.color := FBorderColor;
canvas.FrameRect(CheckboxRect);
end;
procedure TFlatCheckListBox.Paint;
var
memoryBitmap: TBitmap;
counterRect, counterItem: Integer;
itemRect: ^TRect;
Format: UINT;
begin
{$IFDEF DFS_COMPILER_4_UP}
if BidiMode = bdRightToLeft then
Format := DT_RIGHT or DT_VCENTER or DT_SINGLELINE or DT_NOPREFIX
else
Format := DT_LEFT or DT_VCENTER or DT_SINGLELINE or DT_NOPREFIX;
{$ELSE}
Format := DT_LEFT or DT_VCENTER or DT_SINGLELINE or DT_NOPREFIX;
{$ENDIF}
// create memory-bitmap to draw flicker-free
memoryBitmap := TBitmap.Create;
try
memoryBitmap.Height := ClientRect.Bottom;
memoryBitmap.Width := ClientRect.Right;
memoryBitmap.Canvas.Font.Assign(Self.Font);
// Clear Background
case FTransparent of
tmAlways:
DrawParentImage(Self, memoryBitmap.Canvas);
tmNone:
begin
memoryBitmap.canvas.Brush.Color := FItemsRectColor;
memoryBitmap.canvas.FillRect(ClientRect);
end;
tmNotFocused:
if Focused then
begin
memoryBitmap.canvas.Brush.Color := FItemsRectColor;
memoryBitmap.canvas.FillRect(ClientRect);
end
else
DrawParentImage(Self, memoryBitmap.Canvas);
end;
// Draw Border
memoryBitmap.canvas.Brush.Color := FBorderColor;
memoryBitmap.canvas.FrameRect(ClientRect);
// Draw ScrollBars
if ScrollBars then
DrawScrollBar(memoryBitmap.canvas);
// Initialize the counter for the Items
counterItem := firstItem;
// Draw Items
for counterRect := 0 to maxItems - 1 do
begin
itemRect := FItemsRect.Items[counterRect];
if (counterItem <= FItems.Count - 1) then
begin
// Item is selected
if counterItem = FSelected then
begin
// Fill ItemRect
memoryBitmap.canvas.brush.color := FItemsSelectColor;
memoryBitmap.canvas.FillRect(itemRect^);
// Draw ItemBorder
memoryBitmap.canvas.brush.color := FBorderColor;
memoryBitmap.canvas.FrameRect(itemRect^);
end;
if counterItem in FChecked then
{$IFDEF DFS_COMPILER_4_UP}
if BidiMode = bdRightToLeft then
DrawCheckRect(memoryBitmap.canvas, Point(itemRect^.Right, itemRect^.top), true)
else
DrawCheckRect(memoryBitmap.canvas, Point(itemRect^.left, itemRect^.top), true)
{$ELSE}
DrawCheckRect(memoryBitmap.canvas, Point(itemRect^.left, itemRect^.top), true)
{$ENDIF}
else
{$IFDEF DFS_COMPILER_4_UP}
if BidiMode = bdRightToLeft then
DrawCheckRect(memoryBitmap.canvas, Point(itemRect^.Right, itemRect^.top), false)
else
DrawCheckRect(memoryBitmap.canvas, Point(itemRect^.left, itemRect^.top), false);
{$ELSE}
DrawCheckRect(memoryBitmap.canvas, Point(itemRect^.left, itemRect^.top), false);
{$ENDIF}
// Draw ItemText
memoryBitmap.canvas.brush.style := bsClear;
InflateRect(itemRect^, -19, 0);
if Enabled then
DrawText(memoryBitmap.canvas.Handle, PChar(FItems[counterItem]), Length(FItems[counterItem]), itemRect^, Format)
else
begin
OffsetRect(itemRect^, 1, 1);
memoryBitmap.canvas.Font.Color := clBtnHighlight;
DrawText(memoryBitmap.canvas.Handle, PChar(FItems[counterItem]), Length(FItems[counterItem]), itemRect^, Format);
OffsetRect(itemRect^, -1, -1);
memoryBitmap.canvas.Font.Color := clBtnShadow;
DrawText(memoryBitmap.canvas.Handle, PChar(FItems[counterItem]), Length(FItems[counterItem]), itemRect^, Format);
end;
InflateRect(itemRect^, 19, 0);
Inc(counterItem);
end;
end;
// Copy bitmap to screen
canvas.CopyRect(ClientRect, memoryBitmap.canvas, ClientRect);
finally
// delete the memory bitmap
memoryBitmap.free;
end;
end;
procedure TFlatCheckListBox.MouseDown (Button: TMouseButton; Shift: TShiftState; X, Y: Integer);
var
cursorPos: TPoint;
counterRect: Integer;
currentRect: ^TRect;
checkRect: TRect;
begin
GetCursorPos(cursorPos);
cursorPos := ScreenToClient(cursorPos);
if (FItems.Count > 0) and (Button = mbLeft) then
begin
for counterRect := 0 to FItemsRect.Count - 1 do
begin
currentRect := FItemsRect.Items[counterRect];
{$IFDEF DFS_COMPILER_4_UP}
if BidiMode = bdRightToLeft then
checkRect := Rect(currentRect.right - 14, currentRect.top + 3, currentRect.right - 3, currentRect.Top + 14)
else
checkRect := Rect(currentRect.left + 3, currentRect.top + 3, currentRect.left + 14, currentRect.Top + 14);
{$ELSE}
checkRect := Rect(currentRect.left + 3, currentRect.top + 3, currentRect.left + 14, currentRect.Top + 14);
{$ENDIF}
if PtInRect(checkRect, cursorPos) then
begin
if (firstItem + counterRect) in FChecked then
Exclude(FChecked, firstItem + counterRect)
else
Include(FChecked, firstItem + counterRect);
SetFocus;
if Assigned(FOnClickCheck) then
FOnClickCheck(Self);
Invalidate;
Exit;
end
else
if PtInRect(currentRect^, cursorPos) then
begin
FSelected := firstItem + counterRect;
SetFocus;
Invalidate;
Exit;
end;
end;
end;
if ScrollBars then
begin
if PtInRect(Rect(ClientRect.Left, ClientRect.Top, ClientRect.Right, ClientRect.Top + 11), cursorPos) then
begin
if (firstItem - 1) < 0 then
firstItem := 0
else
Dec(firstItem);
SetFocus;
Invalidate;
scrollType := up;
if ScrollTimer.Enabled then
ScrollTimer.Enabled := False;
ScrollTimer.OnTimer := ScrollTimerHandler;
ScrollTimer.Enabled := True;
end;
if PtInRect(Rect(ClientRect.Left, ClientRect.Bottom - 11, ClientRect.Right, ClientRect.Bottom), cursorPos) then
begin
if firstItem + maxItems + 1 <= FItems.Count then
Inc(firstItem);
SetFocus;
Invalidate;
scrollType := down;
if ScrollTimer.Enabled then
ScrollTimer.Enabled := False;
ScrollTimer.OnTimer := ScrollTimerHandler;
ScrollTimer.Enabled := True;
end;
end;
Inherited;
end;
procedure TFlatCheckListBox.MouseUp (Button: TMouseButton; Shift: TShiftState; X, Y: Integer);
begin
ScrollTimer.Enabled := False;
ScrollTimer.Interval := FTimerInterval;
inherited MouseUp(Button, Shift, X, Y);
end;
procedure TFlatCheckListBox.ScrollTimerHandler (Sender: TObject);
begin
ScrollTimer.Interval := FScrollSpeed;
if scrollType = up then
if (firstItem - 1) < 0 then
begin
firstItem := 0;
ScrollTimer.Enabled := False;
end
else
Dec(firstItem)
else
if firstItem + maxItems + 1 <= FItems.Count then
Inc(firstItem)
else
ScrollTimer.Enabled := False;
Invalidate;
end;
procedure TFlatCheckListBox.Loaded;
begin
inherited;
SetItemsRect;
end;
procedure TFlatCheckListBox.WMSize (var Message: TWMSize);
begin
inherited;
// Calculate the maximum items to draw
if ScrollBars then
maxItems := (Height - 24) div (FItemsHeight + 2)
else
maxItems := (Height - 4) div (FItemsHeight + 2);
// Set the new Bounds
if ScrollBars then
SetBounds(Left, Top, Width, maxItems * (FItemsHeight + 2) + 24)
else
SetBounds(Left, Top, Width, maxItems * (FItemsHeight + 2) + 4);
// Recalculate the itemRects
SetItemsRect;
if not (FTransparent = tmNone) then
Invalidate;
end;
procedure TFlatCheckListBox.WMMove (var Message: TWMMove);
begin
inherited;
if not (FTransparent = tmNone) then
Invalidate;
end;
procedure TFlatCheckListBox.CMEnabledChanged (var Message: TMessage);
begin
inherited;
Invalidate;
end;
procedure TFlatCheckListBox.CMSysColorChange (var Message: TMessage);
begin
if FUseAdvColors then
begin
ParentColor := True;
CalcAdvColors;
end;
Invalidate;
end;
procedure TFlatCheckListBox.CMParentColorChanged (var Message: TWMNoParams);
begin
inherited;
if FUseAdvColors then
begin
ParentColor := True;
CalcAdvColors;
end;
Invalidate;
end;
procedure TFlatCheckListBox.Clear;
begin
FItems.Clear;
FChecked := FChecked - [0..High(Byte)];
FSelected := -1;
Invalidate;
end;
procedure TFlatCheckListBox.SetTransparent (const Value: TTransparentMode);
begin
FTransparent := Value;
Invalidate;
end;
procedure TFlatCheckListBox.WMKillFocus (var Message: TWMKillFocus);
begin
inherited;
FSelected := -1;
Invalidate;
end;
procedure TFlatCheckListBox.WMSetFocus (var Message: TWMSetFocus);
begin
inherited;
if not (FTransparent = tmNone) then
Invalidate;
end;
procedure TFlatCheckListBox.CNKeyDown (var Message: TWMKeyDown);
begin
case Message.CharCode of
VK_UP:
if (firstItem - 1) < 0 then
firstItem := 0
else
Dec(firstItem);
VK_DOWN:
if firstItem + maxItems + 1 <= FItems.Count then
Inc(firstItem);
VK_PRIOR:
if (firstItem - maxItems) < 0 then
firstItem := 0
else
Dec(firstItem, maxItems);
VK_NEXT:
if firstItem + (maxItems * 2) <= FItems.Count then
Inc(firstItem, maxItems)
else
firstItem := FItems.Count - maxItems;
VK_SPACE:
if FSelected in FChecked then
Exclude(FChecked, FSelected)
else
Include(FChecked, FSelected);
else
inherited;
end;
Invalidate;
end;
function TFlatCheckListBox.GetItemIndex: Integer;
begin
Result := FSelected;
end;
procedure TFlatCheckListBox.SetItemIndex(Value: Integer);
begin
if GetItemIndex <> Value then
begin
FSelected := Value;
Invalidate;
end;
end;
end.
?? 快捷鍵說明
復制代碼
Ctrl + C
搜索代碼
Ctrl + F
全屏模式
F11
切換主題
Ctrl + Shift + D
顯示快捷鍵
?
增大字號
Ctrl + =
減小字號
Ctrl + -