Delphi控件源码

开发平台：

Delphi

bsSkinBoxCtrls.pas：源码内容

then
begin
Button.MouseIn := True;
RePaint;
end
else
if not PtInRect(Button.R, Point(X, Y)) and Button.MouseIn
then
begin
Button.MouseIn := False;
RePaint;
end;
end;
procedure TbsSkinCustomComboBox.CloseUp;
begin
if not FListBox.Visible then Exit;
FListBox.Hide;
if (FListBox.ItemIndex >= 0) and
(FListBox.ItemIndex < FListBox.Items.Count) and Value
then
begin
if FEdit <> nil
then
FEdit.Text := FListBox.Items[FListBox.ItemIndex]
else
begin
Text := FListBox.Items[FListBox.ItemIndex];
RePaint;
end;
if Assigned(FOnClick) then FOnClick(Self);
Change;
end
else
FListBox.ItemIndex := FOldItemIndex;
if Value
then
if Assigned(FOnCloseUp) then FOnCloseUp(Self);
end;
procedure TbsSkinCustomComboBox.DropDown;
var
P: TPoint;
WorkArea: TRect;
begin
if Items.Count = 0 then Exit;
FListBox.Width := Width;
if Items.Count < DropDownCount
then
FListBox.RowCount := Items.Count
else
FListBox.RowCount := DropDownCount;
P := Point(Left, Top + Height);
P := Parent.ClientToScreen (P);
SystemParametersInfo(SPI_GETWORKAREA, 0, @WorkArea, 0);
if P.Y + FListBox.Height > WorkArea.Bottom
then
P.Y := P.Y - Height - FListBox.Height;
if FEdit <> nil then FEdit.SetFocus;
FOldItemIndex := FListBox.ItemIndex;
if (FListBox.ItemIndex = 0) and (FListBox.Items.Count > 1)
then
begin
FListBox.ItemIndex := 1;
FListBox.ItemIndex := 0;
end;
FListBox.TopIndex := FListBox.ItemIndex;
FListBox.Show(P);
end;
procedure TbsSkinCustomComboBox.EditPageUp1(AChange: Boolean);
var
Index: Integer;
begin
Index := FListBox.ItemIndex - DropDownCount - 1;
if Index < 0 then Index := 0;
if AChange
then
ItemIndex := Index
else
FListBox.ItemIndex := Index;
end;
procedure TbsSkinCustomComboBox.EditPageDown1(AChange: Boolean);
var
Index: Integer;
begin
Index := FListBox.ItemIndex + DropDownCount - 1;
if Index > FListBox.Items.Count - 1
then
Index := FListBox.Items.Count - 1;
if AChange
then
ItemIndex := Index
else
FListBox.ItemIndex := Index;
end;
procedure TbsSkinCustomComboBox.EditUp1;
begin
if FListBox.ItemIndex > 0
then
begin
if AChange
then
ItemIndex := ItemIndex - 1
else
FListBox.ItemIndex := FListBox.ItemIndex - 1;
end;
end;
procedure TbsSkinCustomComboBox.EditDown1;
begin
if FListBox.ItemIndex < FListBox.Items.Count - 1
then
begin
if AChange
then
ItemIndex := ItemIndex + 1
else
FListBox.ItemIndex := FListBox.ItemIndex + 1;
end;
end;
procedure TbsSkinCustomComboBox.EditUp;
begin
if ItemIndex > 0
then
begin
ItemIndex := ItemIndex - 1;
if AChange
then
begin
Text := Items[ItemIndex];
if Assigned(FOnClick) then FOnClick(Self);
end;
end;
end;
procedure TbsSkinCustomComboBox.EditDown;
begin
if ItemIndex < Items.Count - 1
then
begin
FListBox.ItemIndex := FListBox.ItemIndex + 1;
if AChange
then
begin
Text := FListBox.Items[FListBox.ItemIndex];
if Assigned(FOnClick) then FOnClick(Self);
end;
end;
end;
procedure TbsSkinCustomComboBox.EditChange(Sender: TObject);
begin
FromEdit := True;
Text := FEdit.Text;
FromEdit := False;
end;
procedure TbsSkinCustomComboBox.ShowEditor;
begin
FEdit := TbsCustomEdit.Create(Self);
FEdit.Parent := Self;
FEdit.AutoSize := False;
FEdit.Visible := True;
FEdit.EditTransparent := False;
FEdit.OnChange := EditChange;
FEditWindowProc := FEdit.WindowProc;
FEdit.WindowProc := EditWindowProcHook;
FEdit.OnEditCancelMode := EditCancelMode;
//
if FIndex <> -1
then
with FEdit.Font do
begin
Style := FontStyle;
Color := FontColor;
Height := FontHeight;
Name := FontName;
end
else
with FEdit.Font do
begin
Name := Self.Font.Name;
Style := Self.Font.Style;
Color := Self.Font.Color;
Height := Self.Font.Height;
end;
if FIndex <> -1
then FEdit.EditTransparent := True
else FEdit.EditTransparent := False;
//
CalcRects;
end;
procedure TbsSkinCustomComboBox.HideEditor;
begin
FEdit.Visible := False;
FEdit.Free;
FEdit := nil;
end;
procedure TbsSkinCustomComboBox.CMTextChanged;
begin
inherited;
if (FEdit <> nil) and not FromEdit then FEdit.Text := Text;
if Assigned(FOnChange) then FOnChange(Self);
if FromEdit then Change;
end;
procedure TbsSkinCustomComboBox.WMSIZE;
begin
inherited;
CalcRects;
end;
procedure TbsSkinCustomComboBox.DrawButton;
var
ArrowColor: TColor;
R1: TRect;
begin
if FIndex = -1
then
with Button do
begin
R1 := R;
if Down and MouseIn
then
begin
Frame3D(C, R1, BS_XP_BTNFRAMECOLOR, BS_XP_BTNFRAMECOLOR, 1);
C.Brush.Color := BS_XP_BTNDOWNCOLOR;
C.FillRect(R1);
end
else
if MouseIn
then
begin
Frame3D(C, R1, BS_XP_BTNFRAMECOLOR, BS_XP_BTNFRAMECOLOR, 1);
C.Brush.Color := BS_XP_BTNACTIVECOLOR;
C.FillRect(R1);
end
else
begin
Frame3D(C, R1, clBtnShadow, clBtnShadow, 1);
C.Brush.Color := clBtnFace;
C.FillRect(R1);
end;
if Enabled
then
ArrowColor := clBlack
else
ArrowColor := clBtnShadow;
DrawArrowImage(C, R, ArrowColor, 4);
end
else
with Button do
begin
R1 := NullRect;
if not Enabled and not IsNullRect(UnEnabledButtonRect)
then
R1 := UnEnabledButtonRect
else
if Down and MouseIn
then R1 := DownButtonRect
else if MouseIn then R1 := ActiveButtonRect;
if not IsNullRect(R1)
then
C.CopyRect(R, Picture.Canvas, R1);
end;
end;
procedure TbsSkinCustomComboBox.DrawDefaultItem;
var
Buffer: TBitMap;
R, R1: TRect;
Index, IIndex, IX, IY: Integer;
begin
if RectWidth(CBItem.R) <=0 then Exit;
Buffer := TBitMap.Create;
Buffer.Width := RectWidth(CBItem.R);
Buffer.Height := RectHeight(CBItem.R);
R := Rect(0, 0, Buffer.Width, Buffer.Height);
with Buffer.Canvas do
begin
Font.Name := Self.Font.Name;
Font.Style := Self.Font.Style;
Font.Height := Self.Font.Height;
if Focused
then
begin
Brush.Color := clHighLight;
Font.Color := clHighLightText;
end
else
begin
Brush.Color := clWindow;
Font.Color := clWindowText;
end;
FillRect(R);
end;
if FListBox.Visible
then Index := FOldItemIndex
else Index := FListBox.ItemIndex;
CBItem.State := [];
if Focused then CBItem.State := [odFocused];
R1 := Rect(R.Left + 2, R.Top, R.Right - 2, R.Bottom);
if (Index > -1) and (Index < FListBox.Items.Count)
then
if Assigned(FOnComboBoxDrawItem)
then
FOnComboBoxDrawItem(Buffer.Canvas, Index, Buffer.Width, Buffer.Height,
R1, CBItem.State)
else
begin
if Images <> nil
then
begin
if ImageIndex > -1
then IIndex := ImageIndex
else IIndex := Index;
if IIndex < Images.Count
then
begin
IX := R1.Left;
IY := R1.Top + RectHeight(R1) div 2 - Images.Height div 2;
Images.Draw(Buffer.Canvas, IX, IY, IIndex);
end;
Inc(R1.Left, Images.Width + 2);
end;
SPDrawText2(Buffer.Canvas, FListBox.Items[Index], R1);
end;
if Focused then DrawFocusRect(Buffer.Canvas.Handle, R);
Cnvs.Draw(CBItem.R.Left, CBItem.R.Top, Buffer);
Buffer.Free;
end;
procedure TbsSkinCustomComboBox.DrawSkinItem;
var
Buffer: TBitMap;
R, R2: TRect;
W, H: Integer;
Index, IIndex, IX, IY: Integer;
begin
W := RectWidth(CBItem.R);
if W <= 0 then Exit;
H := RectHeight(SItemRect);
if H = 0 then H := RectHeight(FocusItemRect);
if H = 0 then H := RectWidth(CBItem.R);
Buffer := TBitMap.Create;
if Focused
then
begin
if not IsNullRect(FocusItemRect)
then
CreateHSkinImage(ItemLeftOffset, ItemRightOffset, Buffer, Picture,
FocusItemRect, W, H)
else
begin
Buffer.Width := W;
BUffer.Height := H;
Buffer.Canvas.CopyRect(Rect(0, 0, W, H), Cnvs, CBItem.R);
end;
end
else
begin
if not IsNullRect(SItemRect)
then
CreateHSkinImage(ItemLeftOffset, ItemRightOffset, Buffer, Picture,
SItemRect, W, H)
else
begin
Buffer.Width := W;
BUffer.Height := H;
Buffer.Canvas.CopyRect(Rect(0, 0, W, H), Cnvs, CBItem.R);
end;
end;
R := ItemTextRect;
if not IsNullRect(SItemRect)
then
Inc(R.Right, W - RectWidth(SItemRect))
else
Inc(R.Right, W - RectWidth(ClRect));
with Buffer.Canvas do
begin
if FUseSkinFont
then
begin
Font.Name := FontName;
Font.Style := FontStyle;
Font.Height := FontHeight;
Font.CharSet := FDefaultFont.CharSet;
end
else
Font.Assign(FDefaultFont);
if Focused
then
Font.Color := FocusFontColor
else
Font.Color := FontColor;
Brush.Style := bsClear;
end;
if FListBox.Visible
then Index := FOldItemIndex
else Index := FListBox.ItemIndex;
if (Index > -1) and (Index < FListBox.Items.Count)
then
if Assigned(FOnComboBoxDrawItem)
then
FOnComboBoxDrawItem(Buffer.Canvas, Index, Buffer.Width, Buffer.Height,
R, CBItem.State)
else
begin
if Images <> nil
then
begin
if ImageIndex > -1
then IIndex := ImageIndex
else IIndex := Index;
if IIndex < Images.Count
then
begin
IX := R.Left;
IY := R.Top + RectHeight(R) div 2 - Images.Height div 2;
Images.Draw(Buffer.Canvas, IX, IY, IIndex);
end;
Inc(R.Left, Images.Width + 2);
end;
SPDrawText2(Buffer.Canvas, FListBox.Items[Index], R);
end;
Cnvs.Draw(CBItem.R.Left, CBItem.R.Top, Buffer);
Buffer.Free;
end;
procedure TbsSkinCustomComboBox.CalcRects;
const
ButtonW = 17;
var
OX: Integer;
begin
if FIndex = -1
then
begin
Button.R := Rect(Width - ButtonW - 2, 2, Width - 2, Height - 2);
CBItem.R := Rect(2, 2, Button.R.Left - 1 , Height - 2);
end
else
begin
OX := Width - RectWidth(SkinRect);
Button.R := ButtonRect;
if ButtonRect.Left >= RectWidth(SkinRect) - RTPt.X
then
OffsetRect(Button.R, OX, 0);
CBItem.R := ClRect;
Inc(CBItem.R.Right, OX);
end;
if FEdit <> nil
then
begin
FEdit.Left := CBItem.R.Left;
FEdit.Top := CBItem.R.Top;
FEdit.Width := RectWidth(CBItem.R);
FEdit.Height := RectHeight(CBItem.R);
end;
end;
procedure TbsSkinCustomComboBox.ChangeSkinData;
begin
inherited;
CalcRects;
if FEdit <> nil
then
begin
if FIndex <> -1
then
with FEdit.Font do
begin
Style := FontStyle;
Color := FontColor;
Height := FontHeight;
Name := FontName;
CharSet := FDefaultFont.CharSet;
end
else
FEdit.Font.Assign(FDefaultFont);
if FIndex <> -1
then FEdit.EditTransparent := True
else FEdit.EditTransparent := False;
end;
RePaint;
if FIndex = -1
then
begin
FListBox.SkinDataName := '';
end
else
FListBox.SkinDataName := ListBoxName;
FListBox.SkinData := SkinData;
FListBox.UpDateScrollBar;
//
end;
procedure TbsSkinCustomComboBox.CreateControlDefaultImage;
var
R: TRect;
begin
with B.Canvas do
begin
Brush.Color := clBtnFace;
R := ClientRect;
FillRect(R);
end;
Frame3D(B.Canvas, R, clbtnShadow, clbtnShadow, 1);
DrawButton(B.Canvas);
if FEdit = nil then DrawDefaultItem(B.Canvas);
end;
procedure TbsSkinCustomComboBox.CreateControlSkinImage;
begin
inherited;
DrawButton(B.Canvas);
if FEdit = nil then DrawSkinItem(B.Canvas);
end;
// ==================== TbsSkinFontComboBox ======================= //
const
WRITABLE_FONTTYPE = 256;
function IsValidFont(Box: TbsSkinFontComboBox; LogFont: TLogFont;
FontType: Integer): Boolean;
begin
Result := True;
if (foAnsiOnly in Box.Options) then
Result := Result and (LogFont.lfCharSet = ANSI_CHARSET);
if (foTrueTypeOnly in Box.Options) then
Result := Result and (FontType and TRUETYPE_FONTTYPE = TRUETYPE_FONTTYPE);
if (foFixedPitchOnly in Box.Options) then
Result := Result and (LogFont.lfPitchAndFamily and FIXED_PITCH = FIXED_PITCH);
if (foOEMFontsOnly in Box.Options) then
Result := Result and (LogFont.lfCharSet = OEM_CHARSET);
if (foNoOEMFonts in Box.Options) then
Result := Result and (LogFont.lfCharSet <> OEM_CHARSET);
if (foNoSymbolFonts in Box.Options) then
Result := Result and (LogFont.lfCharSet <> SYMBOL_CHARSET);
if (foScalableOnly in Box.Options) then
Result := Result and (FontType and RASTER_FONTTYPE = 0);
end;
function EnumFonTbsroc(var EnumLogFont: TEnumLogFont;
var TextMetric: TNewTextMetric; FontType: Integer; Data: LPARAM): Integer;
export; stdcall;
var
FaceName: string;
begin
FaceName := StrPas(EnumLogFont.elfLogFont.lfFaceName);
with TbsSkinFontComboBox(Data) do
if (Items.IndexOf(FaceName) < 0) and
IsValidFont(TbsSkinFontComboBox(Data), EnumLogFont.elfLogFont, FontType) then
begin
if EnumLogFont.elfLogFont.lfCharSet <> SYMBOL_CHARSET then
FontType := FontType or WRITABLE_FONTTYPE;
Items.AddObject(FaceName, TObject(FontType));
end;
Result := 1;
end;
constructor TbsSkinFontComboBox.Create(AOwner: TComponent);
begin
inherited Create(AOwner);
OnListBoxDrawItem := DrawLBFontItem;
OnComboBoxDrawItem := DrawCBFontItem;
FDevice := fdScreen;
Sorted := True;
end;
procedure TbsSkinFontComboBox.DrawTT;
begin
with Cnvs do
begin
Pen.Color := C;
MoveTo(X, Y);
LineTo(X + 7, Y);
LineTo(X + 7, Y + 3);
MoveTo(X, Y);
LineTo(X, Y + 3);
MoveTo(X + 1, Y);
LineTo(X + 1, Y + 1);
MoveTo(X + 6, Y);
LineTo(X + 6, Y + 1);
MoveTo(X + 3, Y);
LineTo(X + 3, Y + 8);
MoveTo(X + 4, Y);
LineTo(X + 4, Y + 8);
MoveTo(X + 2, Y + 8);
LineTo(X + 6, Y + 8);
end;
end;
procedure TbsSkinFontComboBox.Reset;
var
SaveName: TFontName;
begin
if HandleAllocated then begin
FUpdate := True;
try
SaveName := FontName;
PopulateList;
FontName := SaveName;
finally
FUpdate := False;
if FontName <> SaveName
then
begin
if not (csReading in ComponentState) then
if not FUpdate and Assigned(FOnChange) then FOnChange(Self);
end;
end;
end;
end;
procedure TbsSkinFontComboBox.WMFontChange(var Message: TMessage);
begin
inherited;
Reset;
end;
procedure TbsSkinFontComboBox.SetFontName(const NewFontName: TFontName);
var
Item: Integer;
begin
if FontName <> NewFontName then begin
if not (csLoading in ComponentState) then begin
HandleNeeded;
{ change selected item }
for Item := 0 to Items.Count - 1 do
if AnsiCompareText(Items[Item], NewFontName) = 0 then begin
ItemIndex := Item;
//
if not (csReading in ComponentState) then
if not FUpdate and Assigned(FOnChange) then FOnChange(Self);
//
Exit;
end;
if Style = bscbFixedStyle then ItemIndex := -1
else Text := NewFontName;
end
else inherited Text := NewFontName;
//
if not (csReading in ComponentState) then
if not FUpdate and Assigned(FOnChange) then FOnChange(Self);
//
end;
end;
function TbsSkinFontComboBox.GetFontName: TFontName;
begin
Result := inherited Text;
end;
function TbsSkinFontComboBox.GetTrueTypeOnly: Boolean;
begin
Result := foTrueTypeOnly in FOptions;
end;
procedure TbsSkinFontComboBox.SetOptions;
begin
if Value <> Options then begin
FOptions := Value;
Reset;
end;
end;
procedure TbsSkinFontComboBox.SetTrueTypeOnly(Value: Boolean);
begin
if Value <> TrueTypeOnly then begin
if Value then FOptions := FOptions + [foTrueTypeOnly]
else FOptions := FOptions - [foTrueTypeOnly];
Reset;
end;
end;
procedure TbsSkinFontComboBox.SetDevice;
begin
if Value <> FDevice then begin
FDevice := Value;
Reset;
end;
end;
procedure TbsSkinFontComboBox.SetUseFonts(Value: Boolean);
begin
if Value <> FUseFonts then begin
FUseFonts := Value;
Invalidate;
end;
end;
procedure TbsSkinFontComboBox.DrawCBFontItem;
var
FName: array[0..255] of Char;
R: TRect;
begin
R := TextRect;
R.Left := R.Left + 2;
with Cnvs do
begin
StrPCopy(FName, Items[Index]);
SPDrawText2(Cnvs, FName, R);
end;
end;
procedure TbsSkinFontComboBox.DrawLBFontItem;
var
FName: array[0..255] of Char;
R: TRect;
X, Y: Integer;
begin
R := TextRect;
if (Integer(Items.Objects[Index]) and TRUETYPE_FONTTYPE) <> 0
then
begin
X := TextRect.Left;
Y := TextRect.Top + RectHeight(TextRect) div 2 - 7;
DrawTT(Cnvs, X, Y, clGray);
DrawTT(Cnvs, X + 4, Y + 4, clBlack);
end;
Inc(R.Left, 15);
with Cnvs do
begin
Font.Name := Items[Index];
Font.Style := [];
StrPCopy(FName, Items[Index]);
SPDrawText2(Cnvs, Items[Index], R);
end;
end;
procedure TbsSkinFontComboBox.PopulateList;
var
DC: HDC;
Proc: TFarProc;
OldItemIndex: Integer;
begin
if not HandleAllocated then Exit;
OldItemIndex := ItemIndex;
Items.BeginUpdate;
try
Items.Clear;
DC := GetDC(0);
try
if (FDevice = fdScreen) or (FDevice = fdBoth) then
EnumFontFamilies(DC, nil, @EnumFonTbsroc, Longint(Self));
if (FDevice = fdPrinter) or (FDevice = fdBoth) then
try
EnumFontFamilies(Printer.Handle, nil, @EnumFonTbsroc, Longint(Self));
except
{ skip any errors }
end;
finally
ReleaseDC(0, DC);
end;
finally
Items.EndUpdate;
end;
ItemIndex := OldItemIndex;
end;
procedure TbsSkinFontComboBox.CreateWnd;
var
OldFont: TFontName;
begin
OldFont := FontName;
inherited CreateWnd;
FUpdate := True;
try
PopulateList;
inherited Text := '';
SetFontName(OldFont);
finally
FUpdate := False;
end;
// if AnsiCompareText(FontName, OldFont) <> 0 then DoChange;
end;
// ==================== TbsSkinColorComboBox ======================= //
const
SColorBoxCustomCaption = 'Custom...';
NoColorSelected = TColor($FF000000);
StandardColorsCount = 16;
ExtendedColorsCount = 4;
constructor TbsSkinColorComboBox.Create(AOwner: TComponent);
begin
inherited Create(AOwner);
Style := bscbFixedStyle;
FExStyle := [bscbStandardColors, bscbExtendedColors, bscbSystemColors];
FSelectedColor := clBlack;
FDefaultColorColor := clBlack;
FNoneColorColor := clBlack;
OnListBoxDrawItem := DrawColorItem;
OnComboBoxDrawItem := DrawColorItem;
OnCloseUp := OnLBCloseUp;
FShowNames := True;
end;
procedure TbsSkinColorComboBox.SetShowNames(Value: Boolean);
begin
FShowNames := Value;
RePaint;
end;
procedure TbsSkinColorComboBox.DrawColorItem;
var
R: TRect;
MarkerRect: TRect;
begin
if FShowNames
then
MarkerRect := Rect(TextRect.Left + 1, TextRect.Top + 1,
TextRect.Left + RectHeight(TextRect) - 1, TextRect.Bottom - 1)
else
MarkerRect := Rect(TextRect.Left + 1, TextRect.Top + 1,
TextRect.Right - 1, TextRect.Bottom - 1);
with Cnvs do
begin
Brush.Style := bsSolid;
Brush.Color := Colors[Index];
FillRect(MarkerRect);
Brush.Style := bsClear;
end;
if FShowNames
then
begin
R := TextRect;
R := Rect(R.Left + 5 + RectWidth(MarkerRect), R.Top, R.Right - 2, R.Bottom);
SPDrawText2(Cnvs, FListBox.Items[Index], R);
end;
end;
procedure TbsSkinColorComboBox.OnLBCloseUp;
begin
if (bscbCustomColor in ExStyle) and (ItemIndex = 0) then
PickCustomColor;
end;
function TbsSkinColorComboBox.PickCustomColor: Boolean;
var
LColor: TColor;
begin
with TColorDialog.Create(nil) do
try
LColor := ColorToRGB(TColor(Items.Objects[0]));
Color := LColor;
CustomColors.Text := Format('ColorA=%.8x', [LColor]);
Result := Execute;
if Result then
begin
Items.Objects[0] := TObject(Color);
Self.Invalidate;
if Assigned(FOnClick) then FOnClick(Self);
if Assigned(FOnChange) then FOnChange(Self);
end;
finally
Free;
end;
end;
procedure TbsSkinColorComboBox.KeyDown;
begin
if (bscbCustomColor in ExStyle) and (Key = VK_RETURN) and (ItemIndex = 0)
then
begin
PickCustomColor;
Key := 0;
end;
inherited;
end;
procedure TbsSkinColorComboBox.CreateWnd;
begin
inherited;
PopulateList;
end;
procedure TbsSkinColorComboBox.SetDefaultColorColor(const Value: TColor);
begin
if Value <> FDefaultColorColor then
begin
FDefaultColorColor := Value;
Invalidate;
end;
end;
procedure TbsSkinColorComboBox.SetNoneColorColor(const Value: TColor);
begin
if Value <> FNoneColorColor then
begin
FNoneColorColor := Value;
Invalidate;
end;
end;
procedure TbsSkinColorComboBox.ColorCallBack(const AName: String);
var
I, LStart: Integer;
LColor: TColor;
LName: string;
begin
LColor := StringToColor(AName);
if bscbPrettyNames in ExStyle then
begin
if Copy(AName, 1, 2) = 'cl' then
LStart := 3
else
LStart := 1;
LName := '';
for I := LStart to Length(AName) do
begin
case AName[I] of
'A'..'Z':
if LName <> '' then
LName := LName + ' ';
end;
LName := LName + AName[I];
end;
end
else
LName := AName;
Items.AddObject(LName, TObject(LColor));
end;
procedure TbsSkinColorComboBox.SetSelected(const AColor: TColor);
var
I: Integer;
begin
if HandleAllocated and (FListBox <> nil) then
begin
I := FListBox.Items.IndexOfObject(TObject(AColor));
if (I = -1) and (bscbCustomColor in ExStyle) and (AColor <> NoColorSelected) then
begin
Items.Objects[0] := TObject(AColor);
I := 0;
end;
ItemIndex := I;
end;
FSelectedColor := AColor;
end;
procedure TbsSkinColorComboBox.PopulateList;
procedure DeleteRange(const AMin, AMax: Integer);
var
I: Integer;
begin
for I := AMax downto AMin do
Items.Delete(I);
end;
procedure DeleteColor(const AColor: TColor);
var
I: Integer;
begin
I := Items.IndexOfObject(TObject(AColor));
if I <> -1 then
Items.Delete(I);
end;
var
LSelectedColor, LCustomColor: TColor;
begin
if HandleAllocated then
begin
Items.BeginUpdate;
try
LCustomColor := clBlack;
if (bscbCustomColor in ExStyle) and (Items.Count > 0) then
LCustomColor := TColor(Items.Objects[0]);
LSelectedColor := FSelectedColor;
Items.Clear;
GetColorValues(ColorCallBack);
if not (bscbIncludeNone in ExStyle) then
DeleteColor(clNone);
if not (bscbIncludeDefault in ExStyle) then
DeleteColor(clDefault);
if not (bscbSystemColors in ExStyle) then
DeleteRange(StandardColorsCount + ExtendedColorsCount, Items.Count - 1);
if not (bscbExtendedColors in ExStyle) then
DeleteRange(StandardColorsCount, StandardColorsCount + ExtendedColorsCount - 1);
if not (bscbStandardColors in ExStyle) then
DeleteRange(0, StandardColorsCount - 1);
if bscbCustomColor in ExStyle then
Items.InsertObject(0, SColorBoxCustomCaption, TObject(LCustomColor));
Self.Selected := LSelectedColor;
finally
Items.EndUpdate;
FNeedToPopulate := False;
end;
end
else
FNeedToPopulate := True;
end;
procedure TbsSkinColorComboBox.SetExStyle(AStyle: TbsColorBoxStyle);
begin
FExStyle := AStyle;
Enabled := ([bscbStandardColors, bscbExtendedColors, bscbSystemColors, bscbCustomColor] * FExStyle) <> [];
PopulateList;
if (Items.Count > 0) and (ItemIndex = -1) then ItemIndex := 0;
end;
function TbsSkinColorComboBox.GetColor(Index: Integer): TColor;
begin
Result := TColor(Items.Objects[Index]);
end;
function TbsSkinColorComboBox.GetColorName(Index: Integer): string;
begin
Result := Items[Index];
end;
function TbsSkinColorComboBox.GetSelected: TColor;
begin
if HandleAllocated then
if ItemIndex <> -1 then
Result := Colors[ItemIndex]
else
Result := NoColorSelected
else
Result := FSelectedColor;
end;
//================= check listbox ===================//
type
TbsCheckListBoxDataWrapper = class
private
FData: LongInt;
FState: TCheckBoxState;
procedure SetChecked(Check: Boolean);
function GetChecked: Boolean;
public
class function GetDefaultState: TCheckBoxState;
property Checked: Boolean read GetChecked write SetChecked;
property State: TCheckBoxState read FState write FState;
end;
procedure TbsCheckListBoxDataWrapper.SetChecked(Check: Boolean);
begin
if Check then FState := cbChecked else FState := cbUnchecked;
end;
function TbsCheckListBoxDataWrapper.GetChecked: Boolean;
begin
Result := FState = cbChecked;
end;
class function TbsCheckListBoxDataWrapper.GetDefaultState: TCheckBoxState;
begin
Result := cbUnchecked;
end;
constructor TbsCheckListBox.Create;
begin
inherited;
SkinListBox := nil;
Ctl3D := False;
BorderStyle := bsNone;
ControlStyle := [csCaptureMouse, csOpaque, csDoubleClicks];
end;
destructor TbsCheckListBox.Destroy;
begin
inherited;
end;
procedure TbsCheckListBox.WMNCCALCSIZE;
begin
end;
procedure TbsCheckListBox.CMEnter;
begin
if SkinListBox <> nil then SkinListBox.ListBoxEnter;
inherited;
end;
procedure TbsCheckListBox.CMExit;
begin
if SkinListBox <> nil then SkinListBox.ListBoxExit;
inherited;
end;
procedure TbsCheckListBox.MouseUp(Button: TMouseButton; Shift: TShiftState;
X, Y: Integer);
begin
if SkinListBox <> nil then SkinListBox.ListBoxMouseUp(Button, Shift, X, Y);
inherited;
end;
procedure TbsCheckListBox.MouseMove(Shift: TShiftState; X, Y: Integer);
begin
if SkinListBox <> nil then SkinListBox.ListBoxMouseMove(Shift, X, Y);
inherited;
end;
procedure TbsCheckListBox.KeyDown(var Key: Word; Shift: TShiftState);
begin
if SkinListBox <> nil then SkinListBox.ListBoxKeyDown(Key, Shift);
inherited;
end;
procedure TbsCheckListBox.Click;
begin
if SkinListBox <> nil then SkinListBox.ListBoxClick;
inherited;
end;
procedure TbsCheckListBox.PaintBGWH;
var
X, Y, XCnt, YCnt, XO, YO, w, h, w1, h1: Integer;
Buffer: TBitMap;
begin
w1 := AW;
h1 := AH;
Buffer := TBitMap.Create;
Buffer.Width := w1;
Buffer.Height := h1;
with Buffer.Canvas, SkinListBox do
begin
w := RectWidth(ClRect);
h := RectHeight(ClRect);
XCnt := w1 div w;
YCnt := h1 div h;
for X := 0 to XCnt do
for Y := 0 to YCnt do
begin
if X * w + w > w1 then XO := X * w + w - w1 else XO := 0;
if Y * h + h > h1 then YO := Y * h + h - h1 else YO := 0;
CopyRect(Rect(X * w, Y * h, X * w + w - XO, Y * h + h - YO),
Picture.Canvas,
Rect(SkinRect.Left + ClRect.Left, SkinRect.Top + ClRect.Top,
SkinRect.Left + ClRect.Right - XO,
SkinRect.Top + ClRect.Bottom - YO));
end;
end;
Cnvs.Draw(AX, AY, Buffer);
Buffer.Free;
end;
function TbsCheckListBox.GetItemData(Index: Integer): LongInt;
begin
Result := 0;
if HaveWrapper(Index) then
Result := TbsCheckListBoxDataWrapper(GetWrapper(Index)).FData;
end;
procedure TbsCheckListBox.SetItemData(Index: Integer; AData: LongInt);
var
Wrapper: TbsCheckListBoxDataWrapper;
begin
Wrapper := TbsCheckListBoxDataWrapper(GetWrapper(Index));
Wrapper.FData := AData;
if FSaveStates <> nil then
if FSaveStates.Count > 0 then
begin
Wrapper.FState := TCheckBoxState(FSaveStates[0]);
FSaveStates.Delete(0);
end;
end;
procedure TbsCheckListBox.ResetContent;
var
I: Integer;
begin
for I := 0 to Items.Count - 1 do
if HaveWrapper(I) then
GetWrapper(I).Free;
inherited;
end;
procedure TbsCheckListBox.CreateWnd;
begin
inherited CreateWnd;
if FSaveStates <> nil then
begin
FSaveStates.Free;
FSaveStates := nil;
end;
end;
procedure TbsCheckListBox.DestroyWnd;
var
I: Integer;
begin
if Items.Count > 0 then
begin
FSaveStates := TList.Create;
for I := 0 to Items.Count -1 do
FSaveStates.Add(TObject(State[I]));
end;
inherited DestroyWnd;
end;
procedure TbsCheckListBox.WMDestroy(var Msg: TWMDestroy);
var
i: Integer;
begin
for i := 0 to Items.Count -1 do
ExtractWrapper(i).Free;
inherited;
end;
procedure TbsCheckListBox.DeleteString(Index: Integer);
begin
if HaveWrapper(Index) then
GetWrapper(Index).Free;
inherited;
end;
procedure TbsCheckListBox.KeyPress(var Key: Char);
begin
inherited;
if (Key = ' ') then ToggleClickCheck(ItemIndex);
if SkinListBox <> nil then SkinListBox.ListBoxKeyPress(Key);
end;
procedure TbsCheckListBox.MouseDown(Button: TMouseButton; Shift: TShiftState;
X, Y: Integer);
function InCheckArea(IR: TRect): Boolean;
var
R, R1: TRect;
OX: Integer;
begin
R := SkinListBox.ItemTextRect;
OX := RectWidth(IR) - RectWidth(SkinListBox.SItemRect);
Inc(R.Right, OX);
R1 := SkinListBox.ItemCheckRect;
if R1.Left >= SkinListBox.ItemTextRect.Right
then OffsetRect(R1, OX, 0);
OffsetRect(R1, IR.Left, IR.Top);
Result := PtInRect(R1, Point(X, Y));
end;
var
Index: Integer;
begin
inherited;
Index := ItemAtPos(Point(X,Y),True);
if (Index <> -1)
then
if (SkinListBox <> nil) and (SkinListBox.FIndex <> -1)
then
begin
if InCheckArea(ItemRect(Index)) then ToggleClickCheck(Index);
end
else
begin
if X - ItemRect(Index).Left < 20 then ToggleClickCheck(Index);
end;
if SkinListBox <> nil then SkinListBox.ListBoxMouseDown(Button, Shift, X, Y);
end;
procedure TbsCheckListBox.ToggleClickCheck;
var
State: TCheckBoxState;
begin
if (Index >= 0) and (Index < Items.Count) then
begin
State := Self.State[Index];
case State of
cbUnchecked: State := cbChecked;
cbChecked: State := cbUnchecked;
end;
Self.State[Index] := State;
if Assigned(FOnClickCheck) then FOnClickCheck(Self);
end;
end;
procedure TbsCheckListBox.InvalidateCheck(Index: Integer);
var
R: TRect;
begin
R := ItemRect(Index);
InvalidateRect(Handle, @R, not (csOpaque in ControlStyle));
UpdateWindow(Handle);
end;
function TbsCheckListBox.GetWrapper(Index: Integer): TObject;
begin
Result := ExtractWrapper(Index);
if Result = nil then
Result := CreateWrapper(Index);
end;
function TbsCheckListBox.ExtractWrapper(Index: Integer): TObject;
begin
Result := TbsCheckListBoxDataWrapper(inherited GetItemData(Index));
if LB_ERR = Integer(Result) then
raise EListError.CreateFmt('List index out of bounds (%d)', [Index]);
if (Result <> nil) and (not (Result is TbsCheckListBoxDataWrapper)) then
Result := nil;
end;
function TbsCheckListBox.CreateWrapper(Index: Integer): TObject;
begin
Result := TbsCheckListBoxDataWrapper.Create;
inherited SetItemData(Index, LongInt(Result));
end;
function TbsCheckListBox.HaveWrapper(Index: Integer): Boolean;
begin
Result := ExtractWrapper(Index) <> nil;
end;
procedure TbsCheckListBox.SetChecked(Index: Integer; Checked: Boolean);
begin
if Checked <> GetChecked(Index) then
begin
TbsCheckListBoxDataWrapper(GetWrapper(Index)).SetChecked(Checked);
InvalidateCheck(Index);
end;
end;
procedure TbsCheckListBox.SetState(Index: Integer; AState: TCheckBoxState);
begin
if AState <> GetState(Index) then
begin
TbsCheckListBoxDataWrapper(GetWrapper(Index)).State := AState;
InvalidateCheck(Index);
end;
end;
function TbsCheckListBox.GetChecked(Index: Integer): Boolean;
begin
if HaveWrapper(Index) then
Result := TbsCheckListBoxDataWrapper(GetWrapper(Index)).GetChecked
else
Result := False;
end;
function TbsCheckListBox.GetState(Index: Integer): TCheckBoxState;
begin
if HaveWrapper(Index) then
Result := TbsCheckListBoxDataWrapper(GetWrapper(Index)).State
else
Result := TbsCheckListBoxDataWrapper.GetDefaultState;
end;
function TbsCheckListBox.GetState1;
begin
Result := [];
if AItemID = ItemIndex
then
begin
Result := Result + [odSelected];
if Focused then Result := Result + [odFocused];
end
else
if SelCount > 0
then
if Selected[AItemID] then Result := Result + [odSelected];
end;
procedure TbsCheckListBox.PaintBG(DC: HDC);
var
C: TControlCanvas;
begin
C := TControlCanvas.Create;
C.Handle := DC;
SkinListBox.GetSkinData;
if SkinListBox.FIndex <> -1
then
PaintBGWH(C, Width, Height, 0, 0)
else
with C do
begin
C.Brush.Color := clWindow;
FillRect(Rect(0, 0, Width, Height));
end;
C.Handle := 0;
C.Free;
end;
procedure TbsCheckListBox.PaintColumnsList(DC: HDC);
var
C: TCanvas;
i, j, DrawCount: Integer;
IR: TRect;
begin
C := TCanvas.Create;
C.Handle := DC;
DrawCount := (Height div ItemHeight) * Columns;
i := TopIndex;
j := i + DrawCount;
if j > Items.Count - 1 then j := Items.Count - 1;
if Items.Count > 0
then
for i := TopIndex to j do
begin
IR := ItemRect(i);
if SkinListBox.FIndex <> -1
then
DrawSkinItem(C, i, IR, GetState1(i))
else
DrawDefaultItem(C, i, IR, GetState1(i));
end;
C.Free;
end;
procedure TbsCheckListBox.PaintList(DC: HDC);
var
C: TCanvas;
i, j, k, DrawCount: Integer;
IR: TRect;
begin
C := TCanvas.Create;
C.Handle := DC;
DrawCount := Height div ItemHeight;
i := TopIndex;
j := i + DrawCount;
if j > Items.Count - 1 then j := Items.Count - 1;
k := 0;
if Items.Count > 0
then
for i := TopIndex to j do
begin
IR := ItemRect(i);
if SkinListBox.FIndex <> -1
then
DrawSkinItem(C, i, IR, GetState1(i))
else
DrawDefaultItem(C, i, IR, GetState1(i));
k := IR.Bottom;
end;
if k < Height
then
begin
SkinListBox.GetSkinData;
if SkinListBox.FIndex <> -1
then
PaintBGWH(C, Width, Height - k, 0, k)
else
with C do
begin
C.Brush.Color := clWindow;
FillRect(Rect(0, k, Width, Height));
end;
end;
C.Free;
end;
procedure TbsCheckListBox.PaintWindow;
var
SaveIndex: Integer;
begin
if (Width <= 0) or (Height <=0) then Exit;
SaveIndex := SaveDC(DC);
try
if Columns > 0
then
PaintColumnsList(DC)
else
PaintList(DC);
finally
RestoreDC(DC, SaveIndex);
end;
end;
procedure TbsCheckListBox.WMPaint;
begin
PaintHandler(Msg);
end;
procedure TbsCheckListBox.WMEraseBkgnd;
begin
PaintBG(Message.DC);
Message.Result := 1;
end;
procedure TbsCheckListBox.DrawDefaultItem;
var
Buffer: TBitMap;
R, R1, CR: TRect;
AState: TCheckBoxState;
IIndex, IX, IY: Integer;
begin
if (ItemID < 0) or (ItemID > Items.Count - 1) then Exit;
AState := GetState(itemID);
Buffer := TBitMap.Create;
Buffer.Width := RectWidth(rcItem);
Buffer.Height := RectHeight(rcItem);
R := Rect(20, 0, Buffer.Width, Buffer.Height);
with Buffer.Canvas do
begin
Font.Name := SkinListBox.Font.Name;
Font.Style := SkinListBox.Font.Style;
Font.Height := SkinListBox.Font.Height;
if odSelected in State1
then
begin
Brush.Color := clHighLight;
Font.Color := clHighLightText;
end
else
begin
Brush.Color := clWindow;
Font.Color := SkinListBox.Font.Color;
end;
FillRect(R);
end;
R1 := Rect(R.Left + 2, R.Top, R.Right - 2, R.Bottom);
CR := Rect(3, Buffer.Height div 2 - 6, 16, Buffer.Height div 2 + 7);
Frame3D(Buffer.Canvas, CR, clBtnShadow, clBtnShadow, 1);
if AState = cbChecked
then
DrawCheckImage(Buffer.Canvas, 6, Buffer.Height div 2 - 4, clWindowText);
if Assigned(SkinListBox.FOnDrawItem)
then
SkinListBox.FOnDrawItem(Buffer.Canvas, ItemID, Buffer.Width, Buffer.Height,
R1, State1)
else
begin
if (SkinListBox.Images <> nil)
then
begin
if SkinListBox.ImageIndex > -1
then IIndex := SkinListBox.FImageIndex
else IIndex := itemID;
if IIndex < SkinListBox.Images.Count
then
begin
IX := R1.Left;
IY := R1.Top + RectHeight(R1) div 2 - SkinListBox.Images.Height div 2;
SkinListBox.Images.Draw(Buffer.Canvas, IX, IY, IIndex);
end;
Inc(R1.Left, SkinListBox.Images.Width + 2);
end;
SPDrawText2(Buffer.Canvas, Items[ItemID], R1);
end;
if odFocused in State1 then DrawFocusRect(Buffer.Canvas.Handle, R);
Cnvs.Draw(rcItem.Left, rcItem.Top, Buffer);
Buffer.Free;
end;
procedure TbsCheckListBox.SkinDrawCheckImage(X, Y: Integer; Cnvs: TCanvas; IR: TRect; DestCnvs: TCanvas);
var
B: TBitMap;
begin
B := TBitMap.Create;
B.Width := RectWidth(IR);
B.Height := RectHeight(IR);
B.Canvas.CopyRect(Rect(0, 0, B.Width, B.Height), Cnvs, IR);
B.Transparent := True;
DestCnvs.Draw(X, Y, B);
B.Free;
end;
procedure TbsCheckListBox.DrawSkinItem;
var
Buffer: TBitMap;
R, R1: TRect;
W, H: Integer;
OX: Integer;
AState: TCheckBoxState;
cw, ch, cx, cy: Integer;
IIndex, IX, IY: Integer;
begin
if (SkinListBox.Picture = nil) or (ItemID < 0) or (ItemID > Items.Count - 1) then Exit;
AState := GetState(itemID);
Buffer := TBitMap.Create;
with SkinListBox do
begin
W := RectWidth(rcItem);
H := RectHeight(SItemRect);
Buffer.Width := W;
Buffer.Height := H;
if odFocused in State1
then
CreateHSkinImage(ItemLeftOffset, ItemRightOffset, Buffer, Picture,
FocusItemRect, W, H)
else
if odSelected in State1
then
CreateHSkinImage(ItemLeftOffset, ItemRightOffset, Buffer, Picture,
ActiveItemRect, W, H)
else
CreateHSkinImage(ItemLeftOffset, ItemRightOffset, Buffer, Picture,
SItemRect, W, H);
R := ItemTextRect;
OX := W - RectWidth(SItemRect);
Inc(R.Right, OX);
R1 := ItemCheckRect;
if R1.Left >= ItemTextRect.Right then OffsetRect(R1, OX, 0);
cw := RectWidth(CheckImageRect);
ch := RectHeight(CheckImageRect);
cx := R1.Left + RectWidth(R1) div 2;
cy := R1.Top + RectHeight(R1) div 2;
R1 := Rect(cx - cw div 2, cy - ch div 2,
cx - cw div 2 + cw, cy - ch div 2 + ch);
if AState = cbChecked
then
SkinDrawCheckImage(R1.Left, R1.Top, Picture.Canvas, CheckImageRect, Buffer.Canvas)
else
SkinDrawCheckImage(R1.Left, R1.Top, Picture.Canvas, UnCheckImageRect, Buffer.Canvas);
end;
with Buffer.Canvas do
begin
if SkinListBox.UseSkinFont
then
begin
Font.Name := SkinListBox.FontName;
Font.Style := SkinListBox.FontStyle;
Font.Height := SkinListBox.FontHeight;
Font.CharSet := SkinListBox.DefaultFont.CharSet;
end
else
Font.Assign(SkinListBox.DefaultFont);
if odFocused in State1
then
Font.Color := SkinListBox.FocusFontColor
else
if odSelected in State1
then
Font.Color := SkinListBox.ActiveFontColor
else
Font.Color := SkinListBox.FontColor;
Brush.Style := bsClear;
end;
if Assigned(SkinListBox.FOnDrawItem)
then
SkinListBox.FOnDrawItem(Buffer.Canvas, ItemID, Buffer.Width, Buffer.Height,
R, State1)
else
begin
if (SkinListBox.Images <> nil)
then
begin
if SkinListBox.ImageIndex > -1
then IIndex := SkinListBox.FImageIndex
else IIndex := itemID;
if IIndex < SkinListBox.Images.Count
then
begin
IX := R.Left;
IY := R.Top + RectHeight(R) div 2 - SkinListBox.Images.Height div 2;
SkinListBox.Images.Draw(Buffer.Canvas, IX, IY, IIndex);
end;
Inc(R.Left, SkinListBox.Images.Width + 2);
end;
SPDrawText2(Buffer.Canvas, Items[ItemID], R);
end;
Cnvs.Draw(rcItem.Left, rcItem.Top, Buffer);
Buffer.Free;
end;
procedure TbsCheckListBox.CreateParams;
begin
inherited CreateParams(Params);
with Params do
begin
Style := Style and not WS_BORDER;
ExStyle := ExStyle and not WS_EX_CLIENTEDGE;
WindowClass.style := CS_DBLCLKS;
Style := Style or WS_TABSTOP;
end;
end;
procedure TbsCheckListBox.CNDrawItem;
var
State: TOwnerDrawState;
begin
with Message.DrawItemStruct^ do
begin
{$IFDEF VER120}
State := TOwnerDrawState(WordRec(LongRec(itemState).Lo).Lo);
{$ELSE}
{$IFDEF VER125}
State := TOwnerDrawState(WordRec(LongRec(itemState).Lo).Lo);
{$ELSE}
State := TOwnerDrawState(LongRec(itemState).Lo);
{$ENDIF}
{$ENDIF}
Canvas.Handle := hDC;
Canvas.Font := Font;
Canvas.Brush := Brush;
if SkinListBox.FIndex <> -1
then
DrawSkinItem(Canvas, itemID, rcItem, State)
else
DrawDefaultItem(Canvas, itemID, rcItem, State);
Canvas.Handle := 0;
end;
end;
procedure TbsCheckListBox.WndProc;
var
LParam, WParam: Integer;
begin
inherited;
case Message.Msg of
WM_LBUTTONDBLCLK:
begin
if SkinListBox <> nil then SkinListBox.ListBoxDblClick;
end;
WM_MOUSEWHEEL:
if (SkinListBox <> nil) and (SkinListBox.ScrollBar <> nil)
then
begin
LParam := 0;
if Message.WParam > 0
then
WParam := MakeWParam(SB_LINEUP, 0)
else
WParam := MakeWParam(SB_LINEDOWN, 0);
SendMessage(Handle, WM_VSCROLL, WParam, LParam);
SkinListBox.UpDateScrollBar;
end;
WM_ERASEBKGND:
SkinListBox.UpDateScrollBar;
LB_ADDSTRING, LB_INSERTSTRING,
LB_DELETESTRING:
begin
if SkinListBox <> nil
then
SkinListBox.UpDateScrollBar;
end;
end;
end;
constructor TbsSkinCheckListBox.Create;
begin
inherited;
ControlStyle := [csCaptureMouse, csClickEvents,
csOpaque, csDoubleClicks, csReplicatable];
ControlStyle := ControlStyle + [csAcceptsControls];
FRowCount := 0;
FGlyph := TBitMap.Create;
FNumGlyphs := 1;
FSpacing := 2;
FImageIndex := -1;
FDefaultCaptionFont := TFont.Create;
FDefaultCaptionFont.OnChange := OnDefaultCaptionFontChange;
FDefaultCaptionFont.Name := 'Arial';
FDefaultCaptionFont.Height := 14;
FDefaultCaptionHeight := 20;
ActiveButton := -1;
OldActiveButton := -1;
CaptureButton := -1;
FCaptionMode := False;
FDefaultItemHeight := 20;
TimerMode := 0;
WaitMode := False;
Font.Name := 'Arial';
Font.Height := 14;
Font.Color := clWindowText;
Font.Style := [];
ScrollBar := nil;
ListBox := TbsCheckListBox.Create(Self);
ListBox.SkinListBox := Self;
ListBox.Style := lbOwnerDrawFixed;
ListBox.ItemHeight := FDefaultItemHeight;
ListBox.Parent := Self;
ListBox.Visible := True;
Height := 120;
Width := 120;
FSkinDataName := 'checklistbox';
end;
procedure TbsSkinCheckListBox.SetOnClickCheck(const Value: TNotifyEvent);
begin
FOnClickCheck := Value;
Listbox.OnClickCheck := Value;
end;
function TbsSkinCheckListBox.GetListBoxDragMode: TDragMode;
begin
Result := ListBox.DragMode;
end;
procedure TbsSkinCheckListBox.SetListBoxDragMode(Value: TDragMode);
begin
ListBox.DragMode := Value;
end;
function TbsSkinCheckListBox.GetListBoxDragKind: TDragKind;
begin
Result := ListBox.DragKind;
end;
procedure TbsSkinCheckListBox.SetListBoxDragKind(Value: TDragKind);
begin
ListBox.DragKind := Value;
end;
function TbsSkinCheckListBox.GetListBoxDragCursor: TCursor;
begin
Result := ListBox.DragCursor;
end;
procedure TbsSkinCheckListBox.SetListBoxDragCursor(Value: TCursor);
begin
ListBox.DragCursor := Value;
end;
function TbsSkinCheckListBox.GetColumns;
begin
Result := ListBox.Columns;
end;
procedure TbsSkinCheckListBox.SetColumns;
begin
ListBox.Columns := Value;
UpDateScrollBar;
end;
procedure TbsSkinCheckListBox.SetRowCount;
begin
FRowCount := Value;
if FRowCount <> 0
then
Height := Self.CalcHeight(FRowCount);
end;
procedure TbsSkinCheckListBox.SetImages(Value: TCustomImageList);
begin
FImages := Value;
ListBox.RePaint;
end;
procedure TbsSkinCheckListBox.SetImageIndex(Value: Integer);
begin
FImageIndex := Value;
ListBox.RePaint;
end;
procedure TbsSkinCheckListBox.SetNumGlyphs;
begin
FNumGlyphs := Value;
RePaint;
end;
procedure TbsSkinCheckListBox.SetGlyph;
begin
FGlyph.Assign(Value);
RePaint;
end;
procedure TbsSkinCheckListBox.SetSpacing;
begin
FSpacing := Value;
RePaint;
end;
procedure TbsSkinCheckListBox.Notification(AComponent: TComponent;
Operation: TOperation);
begin
inherited Notification(AComponent, Operation);
if (Operation = opRemove) and (AComponent = Images) then
Images := nil;
end;
procedure TbsSkinCheckListBox.OnDefaultCaptionFontChange;
begin
if (FIndex = -1) and FCaptionMode then RePaint;
end;
procedure TbsSkinCheckListBox.SetDefaultCaptionHeight;
begin
FDefaultCaptionHeight := Value;
if (FIndex = -1) and FCaptionMode
then
begin
CalcRects;
RePaint;
end;
end;
procedure TbsSkinCheckListBox.SetDefaultCaptionFont;
begin
FDefaultCaptionFont.Assign(Value);
end;
procedure TbsSkinCheckListBox.StartTimer;
begin
KillTimer(Handle, 1);
SetTimer(Handle, 1, 100, nil);
end;
procedure TbsSkinCheckListBox.SetDefaultItemHeight;
begin
FDefaultItemHeight := Value;
if FIndex = -1
then
ListBox.ItemHeight := FDefaultItemHeight;
end;
procedure TbsSkinCheckListBox.StopTimer;
begin
KillTimer(Handle, 1);
TimerMode := 0;
end;
procedure TbsSkinCheckListBox.WMTimer;
begin
inherited;
if WaitMode
then
begin
WaitMode := False;
StartTimer;
Exit;
end;
case TimerMode of
1: if ItemIndex > 0 then ItemIndex := ItemIndex - 1;
2: ItemIndex := ItemIndex + 1;
end;
end;
procedure TbsSkinCheckListBox.CreateControlSkinImage;
var
GX, GY, GlyphNum, TX, TY, i, OffX, OffY: Integer;
function GetGlyphTextWidth: Integer;
begin
Result := B.Canvas.TextWidth(Caption);
if not FGlyph.Empty then Result := Result + FGlyph.Width div FNumGlyphs + FSpacing;
end;
function CalcBRect(BR: TRect): TRect;
var
R: TRect;
begin
R := BR;
if BR.Top <= LTPt.Y
then
begin
if BR.Left > RTPt.X then OffsetRect(R, OffX, 0);
end
else
begin
OffsetRect(R, 0, OffY);
if BR.Left > RBPt.X then OffsetRect(R, OffX, 0);
end;
Result := R;
end;
begin
inherited;
// calc rects
OffX := Width - RectWidth(SkinRect);
OffY := Height - RectHeight(SkinRect);
NewClRect := ClRect;
Inc(NewClRect.Right, OffX);
Inc(NewClRect.Bottom, OffY);
if FCaptionMode
then
begin
NewCaptionRect := CaptionRect;
if CaptionRect.Right >= RTPt.X
then
Inc(NewCaptionRect.Right, OffX);
Buttons[0].R := CalcBRect(UpButtonRect);
Buttons[1].R := CalcBRect(DownButtonRect);
Buttons[2].R := CalcBRect(CheckButtonRect);
end;
// paint caption
if not IsNullRect(CaptionRect)
then
with B.Canvas do
begin
Font.Name := CaptionFontName;
Font.Height := CaptionFontHeight;
Font.Color := CaptionFontColor;
Font.Style := CaptionFontStyle;
Font.CharSet := DefaultCaptionFont.CharSet;
TY := NewCaptionRect.Top + RectHeight(NewCaptionRect) div 2 -
TextHeight(Caption) div 2;
TX := NewCaptionRect.Left + 2;
case Alignment of
taCenter: TX := TX + RectWidth(NewCaptionRect) div 2 - GetGlyphTextWidth div 2;
taRightJustify: TX := NewCaptionRect.Right - GetGlyphTextWidth - 2;
end;
Brush.Style := bsClear;
if not FGlyph.Empty
then
begin
GY := NewCaptionRect.Top + RectHeight(NewCaptionRect) div 2 - FGlyph.Height div 2;
GX := TX;
TX := GX + FGlyph.Width div FNumGlyphs + FSpacing;
GlyphNum := 1;
if not Enabled and (NumGlyphs = 2) then GlyphNum := 2;
end;
TextRect(NewCaptionRect, TX, TY, Caption);
if not FGlyph.Empty
then DrawGlyph(B.Canvas, GX, GY, FGlyph, NumGlyphs, GlyphNum);
end;
// paint buttons
for i := 0 to 2 do DrawButton(B.Canvas, i);
end;
procedure TbsSkinCheckListBox.CreateControlDefaultImage;
function GetGlyphTextWidth: Integer;
begin
Result := B.Canvas.TextWidth(Caption);
if not FGlyph.Empty then Result := Result + FGlyph.Width div FNumGlyphs + FSpacing;
end;
var
BW, i, TX, TY: Integer;
R: TRect;
GX, GY: Integer;
GlyphNum: Integer;
begin
inherited;
if FCaptionMode
then
begin
BW := 17;
if BW > FDefaultCaptionHeight - 3 then BW := FDefaultCaptionHeight - 3;
Buttons[0].R := Rect(Width - BW - 2, 2, Width - 2, 1 + BW);
Buttons[1].R := Rect(Buttons[0].R.Left - BW, 2, Buttons[0].R.Left, 1 + BW);
Buttons[2].R := Rect(Buttons[1].R.Left - BW, 2, Buttons[1].R.Left, 1 + BW);
end;
R := ClientRect;
Frame3D(B.Canvas, R, clBtnShadow, clBtnShadow, 1);
if FCaptionMode
then
with B.Canvas do
begin
R := Rect(3, 2, Width - BW * 3 - 3, FDefaultCaptionHeight - 2);
Font.Assign(FDefaultCaptionFont);
case Alignment of
taLeftJustify: TX := R.Left;
taCenter: TX := R.Left + RectWidth(R) div 2 - GetGlyphTextWidth div 2;
taRightJustify: TX := R.Right - GetGlyphTextWidth;
end;
TY := (FDefaultCaptionHeight - 2) div 2 - TextHeight(Caption) div 2;
if not FGlyph.Empty
then
begin
GY := R.Top + RectHeight(R) div 2 - FGlyph.Height div 2 - 1;
GX := TX;
if FNumGlyphs = 0 then FNumGlyphs := 1;
TX := GX + FGlyph.Width div FNumGlyphs + FSpacing;
GlyphNum := 1;
if not Enabled and (NumGlyphs = 2) then GlyphNum := 2;
end;
TextRect(R, TX, TY, Caption);
if not FGlyph.Empty
then DrawGlyph(B.Canvas, GX, GY, FGlyph, NumGlyphs, GlyphNum);
Pen.Color := clBtnShadow;
MoveTo(1, FDefaultCaptionHeight - 1); LineTo(Width - 1, FDefaultCaptionHeight - 1);
for i := 0 to 2 do DrawButton(B.Canvas, i);
end;
end;
procedure TbsSkinCheckListBox.CMMouseEnter;
begin
inherited;
if FCaptionMode
then
TestActive(-1, -1);
end;
procedure TbsSkinCheckListBox.CMMouseLeave;
var
i: Integer;
begin
inherited;
if FCaptionMode
then
for i := 0 to 1 do
if Buttons[i].MouseIn
then
begin
Buttons[i].MouseIn := False;
RePaint;
end;
end;
procedure TbsSkinCheckListBox.MouseDown;
begin
if FCaptionMode
then
begin
TestActive(X, Y);
if ActiveButton <> -1
then
begin
CaptureButton := ActiveButton;
ButtonDown(ActiveButton, X, Y);
end;
end;
inherited;
end;
procedure TbsSkinCheckListBox.MouseUp;
begin
if FCaptionMode
then
begin
if CaptureButton <> -1
then ButtonUp(CaptureButton, X, Y);
CaptureButton := -1;
end;
inherited;
end;
procedure TbsSkinCheckListBox.MouseMove;
begin
inherited;
if FCaptionMode then TestActive(X, Y);
end;
procedure TbsSkinCheckListBox.TestActive(X, Y: Integer);
var
i, j: Integer;
begin
if (FIndex <> -1) and IsNullRect(UpButtonRect) and IsNullRect(DownButtonRect)
then Exit;
j := -1;
OldActiveButton := ActiveButton;
for i := 0 to 2 do
begin
if PtInRect(Buttons[i].R, Point(X, Y))
then
begin
j := i;
Break;
end;
end;
ActiveButton := j;
if (CaptureButton <> -1) and
(ActiveButton <> CaptureButton) and (ActiveButton <> -1)
then
ActiveButton := -1;
if (OldActiveButton <> ActiveButton)
then
begin
if OldActiveButton <> - 1
then
ButtonLeave(OldActiveButton);
if ActiveButton <> -1
then
ButtonEnter(ActiveButton);
end;
end;
procedure TbsSkinCheckListBox.ButtonDown;
begin
Buttons[i].MouseIn := True;
Buttons[i].Down := True;
DrawButton(Canvas, i);
case i of
0: if Assigned(FOnUpButtonClick) then Exit;
1: if Assigned(FOnDownButtonClick) then Exit;
2: if Assigned(FOnCheckButtonClick) then Exit;
end;
TimerMode := 0;
case i of
0: TimerMode := 1;
1: TimerMode := 2;
end;
if TimerMode <> 0
then
begin
WaitMode := True;
SetTimer(Handle, 1, 500, nil);
end;
end;
procedure TbsSkinCheckListBox.ButtonUp;
begin
Buttons[i].Down := False;
if ActiveButton <> i then Buttons[i].MouseIn := False;
DrawButton(Canvas, i);
if Buttons[i].MouseIn
then
case i of
0:
if Assigned(FOnUpButtonClick)
then
begin
FOnUpButtonClick(Self);
Exit;
end;
1:
if Assigned(FOnDownButtonClick)
then
begin
FOnDownButtonClick(Self);
Exit;
end;
2:
if Assigned(FOnCheckButtonClick)
then
begin
FOnCheckButtonClick(Self);
Exit;
end;
end;
case i of
1: ItemIndex := ItemIndex + 1;
0: if ItemIndex > 0 then ItemIndex := ItemIndex - 1;
2: if ItemIndex > -1
then
begin
Checked[ItemIndex] := not Checked[ListBox.ItemIndex];
ListBoxOnClickCheck(Self);
end;
end;
if TimerMode <> 0 then StopTimer;
end;
procedure TbsSkinCheckListBox.ButtonEnter(I: Integer);
begin
Buttons[i].MouseIn := True;
DrawButton(Canvas, i);
if (TimerMode <> 0) and Buttons[i].Down
then SetTimer(Handle, 1, 50, nil);
end;
procedure TbsSkinCheckListBox.ButtonLeave(I: Integer);
begin
Buttons[i].MouseIn := False;
DrawButton(Canvas, i);
if (TimerMode <> 0) and Buttons[i].Down
then KillTimer(Handle, 1);
end;
procedure TbsSkinCheckListBox.CMTextChanged;
begin
inherited;
if FCaptionMode then RePaint;
end;
procedure TbsSkinCheckListBox.SetAlignment(Value: TAlignment);
begin
if FAlignment <> Value
then
begin
FAlignment := Value;
if FCaptionMode then RePaint;
end;
end;
procedure TbsSkinCheckListBox.DrawButton;
var
C: TColor;
kf: Double;
R1: TRect;
begin
if FIndex = -1
then
with Buttons[i] do
begin
R1 := R;
if Down and MouseIn
then
begin
Frame3D(Cnvs, R1, BS_XP_BTNFRAMECOLOR, BS_XP_BTNFRAMECOLOR, 1);
Cnvs.Brush.Color := BS_XP_BTNDOWNCOLOR;
Cnvs.FillRect(R1);
end
else
if MouseIn
then
begin
Frame3D(Cnvs, R1, BS_XP_BTNFRAMECOLOR, BS_XP_BTNFRAMECOLOR, 1);
Cnvs.Brush.Color := BS_XP_BTNACTIVECOLOR;
Cnvs.FillRect(R1);
end
else
begin
Cnvs.Brush.Color := clBtnFace;
Cnvs.FillRect(R1);
end;
C := clBlack;
case i of
0: DrawArrowImage(Cnvs, R, C, 3);
1: DrawArrowImage(Cnvs, R, C, 4);
2: DrawCheckImage(Cnvs, R.Left + 4, R.Top + 4, C);
end;
end
else
with Buttons[i] do
if not IsNullRect(R) then
begin
R1 := NullRect;
case I of
0:
begin
if Down and MouseIn
then R1 := DownUpButtonRect
else if MouseIn then R1 := ActiveUpButtonRect;
end;
1:
begin
if Down and MouseIn
then R1 := DownDownButtonRect
else if MouseIn then R1 := ActiveDownButtonRect;
end;
2: begin
if Down and MouseIn
then R1 := DownCheckButtonRect
else if MouseIn then R1 := ActiveCheckButtonRect;
end;
end;
if not IsNullRect(R1)
then
Cnvs.CopyRect(R, Picture.Canvas, R1)
else
begin
case I of
0: R1 := UpButtonRect;
1: R1 := DownButtonRect;
2: R1 := CheckButtonRect;
end;
OffsetRect(R1, SkinRect.Left, SkinRect.Top);
Cnvs.CopyRect(R, Picture.Canvas, R1);
end;
end;
end;
procedure TbsSkinCheckListBox.SetCaptionMode;
begin
FCaptionMode := Value;
if FIndex = -1
then
begin
CalcRects;
RePaint;
end;
end;
procedure TbsSkinCheckListBox.ListBoxOnClickCheck(Sender: TObject);
begin
if Assigned(FOnClickCheck) then FOnClickCheck(Self);
end;
procedure TbsSkinCheckListBox.SetChecked;
begin
ListBox.Checked[Index] := Checked;
end;
function TbsSkinCheckListBox.GetChecked;
begin
Result := ListBox.Checked[Index];
end;
procedure TbsSkinCheckListBox.SetState;
begin
ListBox.State[Index] := AState;
end;
function TbsSkinCheckListBox.GetState;
begin
Result := ListBox.State[Index];
end;
function TbsSkinCheckListBox.CalcHeight;
begin
if FIndex = -1
then
Result := AitemsCount * ListBox.ItemHeight + 4
else
Result := ClRect.Top + AitemsCount * ListBox.ItemHeight +
RectHeight(SkinRect) - ClRect.Bottom;
end;
procedure TbsSkinCheckListBox.Clear;
begin
ListBox.Clear;
end;
function TbsSkinCheckListBox.ItemAtPos(Pos: TPoint; Existing: Boolean): Integer;
begin
Result := ListBox.ItemAtPos(Pos, Existing);
end;
function TbsSkinCheckListBox.ItemRect(Item: Integer): TRect;
begin
Result := ListBox.ItemRect(Item);
end;
function TbsSkinCheckListBox.GetListBoxPopupMenu;
begin
Result := ListBox.PopupMenu;
end;
procedure TbsSkinCheckListBox.SetListBoxPopupMenu;
begin
ListBox.PopupMenu := Value;
end;
function TbsSkinCheckListBox.GetCanvas: TCanvas;
begin
Result := ListBox.Canvas;
end;
function TbsSkinCheckListBox.GetExtandedSelect: Boolean;
begin
Result := ListBox.ExtendedSelect;
end;
procedure TbsSkinCheckListBox.SetExtandedSelect(Value: Boolean);
begin
ListBox.ExtendedSelect := Value;
end;
function TbsSkinCheckListBox.GetSelCount: Integer;
begin
Result := ListBox.SelCount;
end;
function TbsSkinCheckListBox.GetSelected(Index: Integer): Boolean;
begin
Result := ListBox.Selected[Index];
end;
procedure TbsSkinCheckListBox.SetSelected(Index: Integer; Value: Boolean);
begin
ListBox.Selected[Index] := Value;
end;
function TbsSkinCheckListBox.GetSorted: Boolean;
begin
Result := ListBox.Sorted;
end;
procedure TbsSkinCheckListBox.SetSorted(Value: Boolean);
begin
ListBox.Sorted := Value;
end;
function TbsSkinCheckListBox.GetTopIndex: Integer;
begin
Result := ListBox.TopIndex;
end;
procedure TbsSkinCheckListBox.SetTopIndex(Value: Integer);
begin
ListBox.TopIndex := Value;
end;
function TbsSkinCheckListBox.GetMultiSelect: Boolean;
begin
Result := ListBox.MultiSelect;
end;
procedure TbsSkinCheckListBox.SetMultiSelect(Value: Boolean);
begin
ListBox.MultiSelect := Value;
end;
function TbsSkinCheckListBox.GetListBoxFont: TFont;
begin
Result := ListBox.Font;
end;
procedure TbsSkinCheckListBox.SetListBoxFont(Value: TFont);
begin
ListBox.Font.Assign(Value);
end;
function TbsSkinCheckListBox.GetListBoxTabOrder: TTabOrder;
begin
Result := ListBox.TabOrder;
end;
procedure TbsSkinCheckListBox.SetListBoxTabOrder(Value: TTabOrder);
begin
ListBox.TabOrder := Value;
end;
function TbsSkinCheckListBox.GetListBoxTabStop: Boolean;
begin
Result := ListBox.TabStop;
end;
procedure TbsSkinCheckListBox.SetListBoxTabStop(Value: Boolean);
begin
ListBox.TabStop := Value;
end;
procedure TbsSkinCheckListBox.ShowScrollBar;
begin
ScrollBar := TbsSkinScrollBar.Create(Self);
with ScrollBar do
begin
if Columns > 0
then
Kind := sbHorizontal
else
Kind := sbVertical;
Height := 100;
Width := 20;
Parent := Self;
PageSize := 0;
Min := 0;
Position := 0;
OnChange := SBChange;
if Self.FIndex = -1
then
SkinDataName := ''
else
if Columns > 0
then
SkinDataName := HScrollBarName
else
SkinDataName := VScrollBarName;
SkinData := Self.SkinData;
CalcRects;
Parent := Self;
Visible := True;
end;
RePaint;
end;
procedure TbsSkinCheckListBox.ListBoxEnter;
begin
end;
procedure TbsSkinCheckListBox.ListBoxExit;
begin
end;
procedure TbsSkinCheckListBox.ListBoxKeyDown;
begin
if Assigned(FOnListBoxKeyDown) then FOnListBoxKeyDown(Self, Key, Shift);
end;
procedure TbsSkinCheckListBox.ListBoxKeyUp;
begin
if Assigned(FOnListBoxKeyUp) then FOnListBoxKeyUp(Self, Key, Shift);
end;
procedure TbsSkinCheckListBox.ListBoxKeyPress;
begin
if Assigned(FOnListBoxKeyPress) then FOnListBoxKeyPress(Self, Key);
end;
procedure TbsSkinCheckListBox.ListBoxDblClick;
begin
if Assigned(FOnListBoxDblClick) then FOnListBoxDblClick(Self);
end;
procedure TbsSkinCheckListBox.ListBoxClick;
begin
if Assigned(FOnListBoxClick) then FOnListBoxClick(Self);
end;
procedure TbsSkinCheckListBox.ListBoxMouseDown;
begin
if Assigned(FOnListBoxMouseDown) then FOnListBoxMouseDown(Self, Button, Shift, X, Y);
end;
procedure TbsSkinCheckListBox.ListBoxMouseMove;
begin
if Assigned(FOnListBoxMouseMove) then FOnListBoxMouseMove(Self, Shift, X, Y);
end;
procedure TbsSkinCheckListBox.ListBoxMouseUp;
begin
if Assigned(FOnListBoxMouseUp) then FOnListBoxMouseUp(Self, Button, Shift, X, Y);
end;
procedure TbsSkinCheckListBox.HideScrollBar;
begin
ScrollBar.Visible := False;
ScrollBar.Free;
ScrollBar := nil;
CalcRects;
end;
procedure TbsSkinCheckListBox.CreateParams(var Params: TCreateParams);
begin
inherited CreateParams(Params);
with Params do
begin
WindowClass.style := WindowClass.style and not (CS_HREDRAW or CS_VREDRAW);
end;
end;
procedure TbsSkinCheckListBox.SBChange;
var
LParam, WParam: Integer;
begin
LParam := 0;
WParam := MakeWParam(SB_THUMBPOSITION, ScrollBar.Position);
if Columns > 0
then
SendMessage(ListBox.Handle, WM_HSCROLL, WParam, LParam)
else
SendMessage(ListBox.Handle, WM_VSCROLL, WParam, LParam);
end;
function TbsSkinCheckListBox.GetItemIndex;
begin
Result := ListBox.ItemIndex;
end;
procedure TbsSkinCheckListBox.SetItemIndex;
begin
ListBox.ItemIndex := Value;
end;
procedure TbsSkinCheckListBox.SetItems;
begin
ListBox.Items.Assign(Value);
UpDateScrollBar;
end;
function TbsSkinCheckListBox.GetItems;
begin
Result := ListBox.Items;
end;
destructor TbsSkinCheckListBox.Destroy;
begin
if ScrollBar <> nil then ScrollBar.Free;
if ListBox <> nil then ListBox.Free;
FDefaultCaptionFont.Free;
FGlyph.Free;
inherited;
end;
procedure TbsSkinCheckListBox.CalcRects;
var
LTop: Integer;
OffX, OffY: Integer;
begin
if FIndex <> -1
then
begin
OffX := Width - RectWidth(SkinRect);
OffY := Height - RectHeight(SkinRect);
NewClRect := ClRect;
Inc(NewClRect.Right, OffX);
Inc(NewClRect.Bottom, OffY);
end
else
if FCaptionMode
then
LTop := FDefaultCaptionHeight
else
LTop := 1;
if (ScrollBar <> nil) and ScrollBar.Visible
then
begin
if FIndex = -1
then
begin
if Columns > 0
then
begin
ScrollBar.SetBounds(1, Height - 20, Width - 2, 19);
ListRect := Rect(2, LTop + 1, Width - 2, ScrollBar.Top);
end
else
begin
ScrollBar.SetBounds(Width - 20, LTop, 19, Height - 1 - LTop);
ListRect := Rect(2, LTop + 1, ScrollBar.Left, Height - 2);
end;
end
else
begin
if Columns > 0
then
begin
ScrollBar.SetBounds(NewClRect.Left,
NewClRect.Bottom - ScrollBar.Height,
RectWidth(NewClRect), ScrollBar.Height);
ListRect := NewClRect;
Dec(ListRect.Bottom, ScrollBar.Height);
end
else
begin
ScrollBar.SetBounds(NewClRect.Right - ScrollBar.Width,
NewClRect.Top, ScrollBar.Width, RectHeight(NewClRect));
ListRect := NewClRect;
Dec(ListRect.Right, ScrollBar.Width);
end;
end;
end
else
begin
if FIndex = -1
then
ListRect := Rect(2, LTop + 1, Width - 2, Height - 2)
else
ListRect := NewClRect;
end;
if ListBox <> nil
then
ListBox.SetBounds(ListRect.Left, ListRect.Top,
RectWidth(ListRect), RectHeight(ListRect));
end;
procedure TbsSkinCheckListBox.GetSkinData;
begin
inherited;
if FIndex <> -1
then
if TbsDataSkinControl(FSD.CtrlList.Items[FIndex]) is TbsDataSkinListBox
then
with TbsDataSkinCheckListBox(FSD.CtrlList.Items[FIndex]) do
begin
Self.FontName := FontName;
Self.FontStyle := FontStyle;
Self.FontHeight := FontHeight;
Self.SItemRect := SItemRect;
Self.ActiveItemRect := ActiveItemRect;
if isNullRect(ActiveItemRect)
then
Self.ActiveItemRect := SItemRect;
Self.FocusItemRect := FocusItemRect;
if isNullRect(FocusItemRect)
then
Self.FocusItemRect := SItemRect;
Self.UnCheckImageRect := UnCheckImageRect;
Self.CheckImageRect := CheckImageRect;
Self.ItemLeftOffset := ItemLeftOffset;
Self.ItemRightOffset := ItemRightOffset;
Self.ItemTextRect := ItemTextRect;
Self.ItemCheckRect := ItemCheckRect;
Self.FontColor := FontColor;
Self.ActiveFontColor := ActiveFontColor;
Self.FocusFontColor := FocusFontColor;
Self.VScrollBarName := VScrollBarName;
Self.HScrollBarName := HScrollBarName;
Self.CaptionRect := CaptionRect;
Self.CaptionFontName := CaptionFontName;
Self.CaptionFontStyle := CaptionFontStyle;
Self.CaptionFontHeight := CaptionFontHeight;
Self.CaptionFontColor := CaptionFontColor;
Self.UpButtonRect := UpButtonRect;
Self.ActiveUpButtonRect := ActiveUpButtonRect;
Self.DownUpButtonRect := DownUpButtonRect;
if IsNullRect(Self.DownUpButtonRect)
then Self.DownUpButtonRect := Self.ActiveUpButtonRect;
Self.DownButtonRect := DownButtonRect;
Self.ActiveDownButtonRect := ActiveDownButtonRect;
Self.DownDownButtonRect := DownDownButtonRect;
if IsNullRect(Self.DownDownButtonRect)
then Self.DownDownButtonRect := Self.ActiveDownButtonRect;
Self.CheckButtonRect := CheckButtonRect;
Self.ActiveCheckButtonRect := ActiveCheckButtonRect;
Self.DownCheckButtonRect := DownCheckButtonRect;
if IsNullRect(Self.DownCheckButtonRect)
then Self.DownCheckButtonRect := Self.ActiveCheckButtonRect;
end;
end;
procedure TbsSkinCheckListBox.ChangeSkinData;
begin
inherited;
//
if FIndex <> -1
then
ListBox.ItemHeight := RectHeight(sItemRect)
else
begin
ListBox.ItemHeight := FDefaultItemHeight;
Font.Assign(FDefaultFont);
end;
if ScrollBar <> nil
then
with ScrollBar do
begin
if Self.FIndex = -1
then
SkinDataName := ''
else
if Columns > 0
then
SkinDataName := HScrollBarName
else
SkinDataName := VScrollBarName;
SkinData := Self.SkinData;
end;
if FRowCount <> 0
then
Height := Self.CalcHeight(FRowCount);
CalcRects;
UpDateScrollBar;
ListBox.RePaint;
end;
procedure TbsSkinCheckListBox.WMSIZE;
begin
inherited;
CalcRects;
UpDateScrollBar;
if ScrollBar <> nil then ScrollBar.Repaint;
end;
procedure TbsSkinCheckListBox.SetBounds;
begin
inherited;
if FIndex = -1 then RePaint;
end;
procedure TbsSkinCheckListBox.UpDateScrollBar;
var
Min, Max, Pos, Page: Integer;
begin
if (ListBox = nil) or ((FRowCount > 0) and (RowCount = Items.Count))
then Exit;
if Columns > 0
then
begin
GetScrollRange(ListBox.Handle, SB_HORZ, Min, Max);
Pos := GetScrollPos(ListBox.Handle, SB_HORZ);
Page := ListBox.Columns;
if (Max > Min) and (Pos <= Max) and (Page <= Max)
then
begin
if ScrollBar = nil
then ShowScrollBar;
ScrollBar.SetRange(Min, Max, Pos, Page);
end
else
if (ScrollBar <> nil) and (ScrollBar.Visible) then HideScrollBar;
end
else
begin
if not ((FRowCount > 0) and (RowCount = Items.Count))
then
begin
GetScrollRange(ListBox.Handle, SB_VERT, Min, Max);
Pos := GetScrollPos(ListBox.Handle, SB_VERT);
Page := ListBox.Height div ListBox.ItemHeight;
if (Max > Min) and (Pos <= Max) and (Page < Items.Count)
then
begin
if ScrollBar = nil then ShowScrollBar;
ScrollBar.SetRange(Min, Max, Pos, Page);
end
else
if (ScrollBar <> nil) and ScrollBar.Visible then HideScrollBar;
end
else
if (ScrollBar <> nil) and ScrollBar.Visible then HideScrollBar;
end;
end;
constructor TbsSkinScrollBox.Create(AOwner: TComponent);
begin
inherited;
ControlStyle := ControlStyle + [csAcceptsControls];
FInCheckScrollBars := False;
FVSizeOffset := 0;
FHSizeOffset := 0;
FVScrollBar := nil;
FHScrollBar := nil;
FOldVScrollBarPos := 0;
FOldHScrollBarPos := 0;
FDown := False;
FSkinDataName := 'scrollbox';
BGPictureIndex := -1;
Width := 150;
Height := 150;
end;
destructor TbsSkinScrollBox.Destroy;
begin
inherited;
end;
procedure TbsSkinScrollBox.UpDateScrollRange;
begin
GetHRange;
GetVRange;
end;
procedure TbsSkinScrollBox.CMVisibleChanged;
begin
inherited;
if FVScrollBar <> nil then FVScrollBar.Visible := Self.Visible;
if FHScrollBar <> nil then FHScrollBar.Visible := Self.Visible;
end;
procedure TbsSkinScrollBox.OnHScrollBarChange(Sender: TObject);
begin
HScrollControls(FHScrollBar.Position - FOldHScrollBarPos);
FOldHScrollBarPos := HScrollBar.Position;
end;
procedure TbsSkinScrollBox.OnVScrollBarChange(Sender: TObject);
begin
VScrollControls(FVScrollBar.Position - FOldVScrollBarPos);
FOldVScrollBarPos := VScrollBar.Position;
end;
procedure TbsSkinScrollBox.OnHScrollBarLastChange(Sender: TObject);
begin
Invalidate;
end;
procedure TbsSkinScrollBox.OnVScrollBarLastChange(Sender: TObject);
begin
Invalidate;
end;
procedure TbsSkinScrollBox.ChangeSkinData;
begin
inherited;
ReCreateWnd;
if FVScrollBar <> nil then FVScrollBar.Align := FVScrollBar.Align;
if FHScrollBar <> nil then FHScrollBar.Align := FHScrollBar.Align;
end;
procedure TbsSkinScrollBox.HScroll;
begin
if (FHScrollBar <> nil) and (FHScrollBar.PageSize <> 0)
then
with FHScrollBar do
begin
HScrollControls(APosition - Position);
Position := APosition;
end;
end;
procedure TbsSkinScrollBox.VScroll;
begin
if (FVScrollBar <> nil) and (FVScrollBar.PageSize <> 0)
then
with FVScrollBar do
begin
if APosition > Max - PageSize then APosition := Max - PageSize;
VScrollControls(APosition - Position);
Position := APosition;
end;
end;
procedure TbsSkinScrollBox.SetBorderStyle;
begin
FBorderStyle := Value;
ReCreateWnd;
end;
procedure TbsSkinScrollBox.GetSkinData;
begin
inherited;
BGPictureIndex := -1;
if FIndex <> -1
then
if TbsDataSkinControl(FSD.CtrlList.Items[FIndex]) is TbsDataSkinScrollBoxControl
then
with TbsDataSkinScrollBoxControl(FSD.CtrlList.Items[FIndex]) do
begin
Self.BGPictureIndex := BGPictureIndex;
end;
end;
procedure TbsSkinScrollBox.Notification;
begin
inherited Notification(AComponent, Operation);
if (Operation = opRemove) and (AComponent = FHScrollBar)
then FHScrollBar := nil;
if (Operation = opRemove) and (AComponent = FVScrollBar)
then FVScrollBar := nil;
end;
procedure TbsSkinScrollBox.SetVScrollBar;
begin
FVScrollBar := Value;
if FVScrollBar <> nil
then
with FVScrollBar do
begin
CanFocused := False;
OnChange := OnVScrollBarChange;
OnLastChange := OnVScrollBarLastChange;
Enabled := True;
Visible := False;
end;
GetVRange;
end;
procedure TbsSkinScrollBox.SetHScrollBar;
begin
FHScrollBar := Value;
if FHScrollBar <> nil
then
with FHScrollBar do
begin
CanFocused := False;
Enabled := True;
Visible := False;
OnChange := OnHScrollBarChange;
OnLastChange := OnHScrollBarLastChange;
end;
GetHRange;
end;
procedure TbsSkinScrollBox.CreateControlDefaultImage;
var
R: TRect;
begin
with B.Canvas do
begin
Brush.Color := clBtnFace;
R := ClientRect;
FillRect(R);
end;
end;
type
TParentControl = class(TWinControl);
procedure TbsSkinScrollBox.GetVRange;
var
i, MaxBottom, H, Offset: Integer;
FMax: Integer;
VisibleChanged, IsVisible: Boolean;
R: TRect;
begin
if (FVScrollBar = nil) or FInCheckScrollBars or (Parent = nil) then Exit;
VisibleChanged := False;
H := ClientHeight;
MaxBottom := 0;
for i := 0 to ControlCount - 1 do
with Controls[i] do
begin
if Visible
then
if Top + Height > MaxBottom then MaxBottom := Top + Height;
end;
with FVScrollBar do
begin
FMax := MaxBottom + Position;
if FMax > H
then
begin
if not Visible
then
begin
IsVisible := True;
VisibleChanged := True;
end;
if (Position > 0) and (MaxBottom < H) and (FVSizeOffset > 0)
then
begin
if FVSizeOffset > Position then FVSizeOffset := Position;
SetRange(0, FMax - 1, Position - FVSizeOffset, H);
VScrollControls(- FVSizeOffset);
FVSizeOffset := 0;
FOldVScrollBarPos := Position;
end
else
begin
if (FVSizeOffset = 0) and ((FMax - 1) < Max) and (Position > 0) and
(MaxBottom < H)
then
begin
Offset := Max - (FMax - 1);
Offset := Offset + (Max - PageSize + 1) + Position;
if Offset > Position then Offset := Position;
VScrollControls(-Offset);
SetRange(0, FMax - 1, Position - OffSet, H);
end
else
SetRange(0, FMax - 1, Position, H);
FVSizeOffset := 0;
FOldVScrollBarPos := Position;
end;
end
else
begin
if Position > 0
then VScrollControls(-Position);
FVSizeOffset := 0;
FOldVScrollBarPos := 0;
SetRange(0, 0, 0, 0);
if Visible
then
begin
IsVisible := False;
VisibleChanged := True;
end;
end;
end;
if (FVScrollBar <> nil) and (FHScrollBar <> nil)
then
begin
if not FVScrollBar.Visible and FHScrollBar.Both
then
FHScrollBar.Both := False
else
if FVScrollBar.Visible and not FHScrollBar.Both
then
FHScrollBar.Both := True;
end;
if VisibleChanged
then
begin
FInCheckScrollBars := True;
FVScrollBar.Visible := IsVisible;
FInCheckScrollBars := False;
if (Align <> alNone)
then
begin
FInCheckScrollBars := True;
R := Parent.ClientRect;
TParentControl(Parent).AlignControls(nil, R);
FInCheckScrollBars := False;
end;
end;
end;
procedure TbsSkinScrollBox.VScrollControls;
begin
ScrollBy(0, -AOffset);
end;
procedure TbsSkinScrollBox.AdjustClientRect(var Rect: TRect);
var
RLeft, RTop, VMax, HMax: Integer;
begin
if (VScrollbar <> nil) and VScrollbar.Visible
then
begin
RTop := -VScrollbar.Position;
VMax := Max(VScrollBar.Max, ClientHeight);
end
else
begin
RTop := 0;
VMax := ClientHeight;
end;
if (HScrollbar <> nil) and HScrollbar.Visible
then
begin
RLeft := -HScrollbar.Position;
HMax := Max(HScrollBar.Max, ClientWidth);
end
else
begin
RLeft := 0;
HMax := ClientWidth;
end;
Rect := Bounds(RLeft, RTop, HMax, VMax);
inherited AdjustClientRect(Rect);
end;
procedure TbsSkinScrollBox.GetHRange;
var
i, MaxRight, W, Offset: Integer;
FMax: Integer;
VisibleChanged, IsVisible: Boolean;
R: TRect;
begin
if (FHScrollBar = nil) or FInCheckScrollBars or (Parent = nil) then Exit;
VisibleChanged := False;
W := ClientWidth;
MaxRight := 0;
for i := 0 to ControlCount - 1 do
with Controls[i] do
begin
if Visible
then
if Left + Width > MaxRight then MaxRight := left + Width;
end;
with FHScrollBar do
begin
FMax := MaxRight + Position;
if FMax > W
then
begin
if not Visible
then
begin
IsVisible := True;
VisibleChanged := True;
end;
if (Position > 0) and (MaxRight < W) and (FHSizeOffset > 0)
then
begin
if FHSizeOffset > Position
then FHSizeOffset := Position;
SetRange(0, FMax - 1, Position - FHSizeOffset , W);
HScrollControls(-FHSizeOffset);
FOldHScrollBarPos := Position;
end
else
begin
if (FHSizeOffset = 0) and ((FMax - 1) < Max) and (Position > 0) and
(MaxRight < W)
then
begin
Offset := Max - (FMax - 1);
Offset := Offset + (Max - PageSize + 1) + Position;
if Offset > Position then Offset := Position;
HScrollControls(-Offset);
SetRange(0, FMax - 1, Position - Offset, W);
end
else
SetRange(0, FMax - 1, Position, W);
FHSizeOffset := 0;
FOldHScrollBarPos := Position;
end;
end
else
begin
if Position > 0
then HScrollControls(-Position);
FHSizeOffset := 0;
FOldHScrollBarPos := 0;
SetRange(0, 0, 0, 0);
if Visible
then
begin
IsVisible := False;
VisibleChanged := True;
end;
end;
end;
if (FVScrollBar <> nil) and (FHScrollBar <> nil)
then
begin
if not FVScrollBar.Visible and FHScrollBar.Both
then
FHScrollBar.Both := False
else
if FVScrollBar.Visible and not FHScrollBar.Both
then
FHScrollBar.Both := True;
end;
if VisibleChanged
then
begin
FInCheckScrollBars := True;
FHScrollBar.Visible := IsVisible;
FInCheckScrollBars := False;
if (Align <> alNone)
then
begin
R := Parent.ClientRect;
TParentControl(Parent).AlignControls(nil, R);
end;
end;
end;
procedure TbsSkinScrollBox.HScrollControls;
begin
ScrollBy(-AOffset, 0);
end;
procedure TbsSkinScrollBox.SetBounds;
var
OldHeight, OldWidth: Integer;
R: TRect;
begin
OldWidth := Width;
OldHeight := Height;
inherited;
if (OldWidth <> Width)
then
begin
if (OldWidth < Width) and (OldWidth <> 0)
then FHSizeOffset := Width - OldWidth
else FHSizeOffset := 0;
end
else
FHSizeOffset := 0;
if (OldHeight <> Height)
then
begin
if (OldHeight < Height) and (OldHeight <> 0)
then FVSizeOffset := Height - OldHeight
else FVSizeOffset := 0;
end
else
FVSizeOffset := 0;
GetVRange;
GetHRange;
end;
procedure TbsSkinScrollBox.WMNCCALCSIZE;
begin
GetSkinData;
if (FIndex = -1) and (FBorderStyle <> bvNone)
then
with Message.CalcSize_Params^.rgrc[0] do
begin
if FBorderStyle <> bvNone
then
begin
Inc(Left, 1);
Inc(Top, 1);
Dec(Right, 1);
Dec(Bottom, 1);
end;
end
else
if (BGPictureIndex = -1) and (FBorderStyle <> bvNone) then
with Message.CalcSize_Params^.rgrc[0] do
begin
Inc(Left, ClRect.Left);
Inc(Top, ClRect.Top);
Dec(Right, RectWidth(SkinRect) - ClRect.Right);
Dec(Bottom, RectHeight(SkinRect) - ClRect.Bottom);
end;
end;
procedure TbsSkinScrollBox.WMNCPAINT;
var
DC: HDC;
C: TCanvas;
R: TRect;
begin
if (BGPictureIndex <> -1) or (FBorderStyle = bvNone) then Exit;
DC := GetWindowDC(Handle);
C := TControlCanvas.Create;
C.Handle := DC;
try
PaintFrame(C);
finally
C.Free;
ReleaseDC(Handle, DC);
end;
end;
procedure TbsSkinScrollBox.PaintFrame;
var
NewLTPoint, NewRTPoint, NewLBPoint, NewRBPoint: TPoint;
R, NewClRect: TRect;
LeftB, TopB, RightB, BottomB: TBitMap;
OffX, OffY: Integer;
AW, AH: Integer;
begin
GetSkinData;
if (FIndex = -1)
then
with C do
begin
if FBorderStyle <> bvNone
then
begin
Brush.Style := bsClear;
R := Rect(0, 0, Width, Height);
case FBorderStyle of
bvLowered: Frame3D(C, R, clBtnHighLight, clBtnShadow, 1);
bvRaised: Frame3D(C, R, clBtnShadow, clBtnHighLight, 1);
bvFrame: Frame3D(C, R, clBtnShadow, clBtnShadow, 1);
end;
end;
Exit;
end;
LeftB := TBitMap.Create;
TopB := TBitMap.Create;
RightB := TBitMap.Create;
BottomB := TBitMap.Create;
OffX := Width - RectWidth(SkinRect);
OffY := Height - RectHeight(SkinRect);
AW := Width;
AH := Height;
NewLTPoint := LTPt;
NewRTPoint := Point(RTPt.X + OffX, RTPt.Y);
NewLBPoint := Point(LBPt.X, LBPt.Y + OffY);
NewRBPoint := Point(RBPt.X + OffX, RBPt.Y + OffY);
NewClRect := Rect(ClRect.Left, ClRect.Top,
ClRect.Right + OffX, ClRect.Bottom + OffY);
CreateSkinBorderImages(LTPt, RTPt, LBPt, RBPt, CLRect,
NewLtPoint, NewRTPoint, NewLBPoint, NewRBPoint, NewCLRect,
LeftB, TopB, RightB, BottomB, Picture, SkinRect, Width, Height);
C.Draw(0, 0, TopB);
C.Draw(0, TopB.Height, LeftB);
C.Draw(Width - RightB.Width, TopB.Height, RightB);
C.Draw(0, Height - BottomB.Height, BottomB);
TopB.Free;
LeftB.Free;
RightB.Free;
BottomB.Free;
end;
procedure TbsSkinScrollBox.Paint;
var
X, Y, XCnt, YCnt, w, h,
rw, rh, XO, YO: Integer;
Buffer: TBitMap;
R: TRect;
begin
GetSkinData;
if FIndex = -1
then
begin
inherited;
Exit;
end;
if (ClientWidth > 0) and (ClientHeight > 0) then
if BGPictureIndex <> -1
then
begin
Buffer := TBitMap(FSD.FActivePictures.Items[BGPictureIndex]);
XCnt := Width div Buffer.Width;
YCnt := Height div Buffer.Height;
for X := 0 to XCnt do
for Y := 0 to YCnt do
Canvas.Draw(X * Buffer.Width, Y * Buffer.Height, Buffer);
end
else
begin
Buffer := TBitMap.Create;
Buffer.Width := ClientWidth;
Buffer.Height := ClientHeight;
w := RectWidth(ClRect);
h := RectHeight(ClRect);
rw := Buffer.Width;
rh := Buffer.Height;
with Buffer.Canvas do
begin
XCnt := rw div w;
YCnt := rh div h;
for X := 0 to XCnt do
for Y := 0 to YCnt do
begin
if X * w + w > rw then XO := X * W + W - rw else XO := 0;
if Y * h + h > rh then YO := Y * h + h - rh else YO := 0;
CopyRect(Rect(X * w, Y * h,X * w + w - XO, Y * h + h - YO),
Picture.Canvas,
Rect(SkinRect.Left + ClRect.Left,
SkinRect.Top + ClRect.Top,
SkinRect.Left + ClRect.Right - XO,
SkinRect.Top + ClRect.Bottom - YO));
end;
Canvas.Draw(0, 0, Buffer);
Buffer.Free;
end;
end;
end;
procedure TbsSkinScrollBox.WMSIZE;
begin
inherited;
SendMessage(Handle, WM_NCPAINT, 0, 0);
end;
procedure TbsSkinScrollBox.CreateParams(var Params: TCreateParams);
begin
inherited CreateParams(Params);
with Params do
begin
WindowClass.style := WindowClass.style and not (CS_HREDRAW or CS_VREDRAW);
end;
end;
constructor TbsSkinTrackEdit.Create(AOwner: TComponent);
begin
inherited;
FTrackBarSkinDataName := 'htrackbar';
ButtonMode := True;
FMinValue := 0;
FMaxValue := 100;
FValue := 0;
StopCheck := True;
Text := '0';
StopCheck := False;
Width := 120;
Height := 20;
FSkinDataName := 'buttonedit';
OnButtonClick := ButtonClick;
FAlphaBlend := False;
FAlphaBlendValue := 0;
FPopupTrackBar := TbsSkinPopupTrackBar.Create(Self);
FPopupTrackBar.Visible := False;
FPopupTrackBar.TrackEdit := Self;
FPopupTrackBar.Parent := Self;
FPopupTrackBar.OnChange := TrackBarChange
end;
destructor TbsSkinTrackEdit.Destroy;
begin
FPopupTrackBar.Free;
inherited;
end;
procedure TbsSkinTrackEdit.CMCancelMode(var Message: TCMCancelMode);
begin
if (Message.Sender <> FPopupTrackBar)
then
CloseUp;
end;
procedure TbsSkinTrackEdit.CloseUp;
begin
if FPopupTrackbar.Visible
then
begin
SetWindowPos(FPopupTrackBar.Handle, 0, 0, 0, 0, 0, SWP_NOZORDER or
SWP_NOMOVE or SWP_NOSIZE or SWP_NOACTIVATE or SWP_HIDEWINDOW);
FPopupTrackBar.Visible := False;
if CheckW2KWXP and FAlphaBlend
then
SetWindowLong(FPopupTrackBar.Handle, GWL_EXSTYLE,
GetWindowLong(Handle, GWL_EXSTYLE) and not WS_EX_LAYERED);
end;
end;
procedure TbsSkinTrackEdit.DropDown;
var
P: TPoint;
I, X, Y: Integer;
begin
with FPopupTrackBar do
begin
Width := Self.Width ;
DefaultHeight := Self.Height;
SkinDataName := FTrackBarSkinDataName;
SkinData := Self.SkinData;
MinValue := Self.MinValue;
MaxValue := Self.MaxValue;
Value := Self.Value;
end;
P := Parent.ClientToScreen(Point(Left, Top));
Y := P.Y + Height;
if Y + FPopupTrackBar.Height > Screen.Height then Y := P.Y - FPopupTrackBar.Height;
//
if CheckW2KWXP and FAlphaBlend
then
begin
SetWindowLong(FPopupTrackBar.Handle, GWL_EXSTYLE,
GetWindowLong(Handle, GWL_EXSTYLE) or WS_EX_LAYERED);
if FAlphaBlendAnimation
then
SetAlphaBlendTransparent(FPopupTrackBar.Handle, 0)
else
SetAlphaBlendTransparent(FPopupTrackBar.Handle, FAlphaBlendValue);
end;
//
SetWindowPos(FPopupTrackBar.Handle, HWND_TOP, P.X, Y, 0, 0,
SWP_NOSIZE or SWP_NOACTIVATE or SWP_SHOWWINDOW);
FPopupTrackBar.Visible := True;
if FAlphaBlendAnimation and FAlphaBlend and CheckW2KWXP
then
begin
Application.ProcessMessages;
I := 0;
repeat
Inc(i, 1);
if i > FAlphaBlendValue then i := FAlphaBlendValue;
SetAlphaBlendTransparent(FPopupTrackBar.Handle, i);
until i >= FAlphaBlendValue;
end;
end;
procedure TbsSkinTrackEdit.ButtonClick(Sender: TObject);
begin
SetFocus;
if not FPopupTrackBar.Visible then DropDown else CloseUp;
end;
function TbsSkinTrackEdit.CheckValue;
begin
Result := NewValue;
if (FMaxValue <> FMinValue)
then
begin
if NewValue < FMinValue then
Result := FMinValue
else if NewValue > FMaxValue then
Result := FMaxValue;
end;
end;
procedure TbsSkinTrackEdit.SetMinValue;
begin
FMinValue := AValue;
end;
procedure TbsSkinTrackEdit.SetMaxValue;
begin
FMaxValue := AValue;
end;
function TbsSkinTrackEdit.IsNumText;
function GetMinus: Boolean;
var
i: Integer;
S: String;
begin
S := AText;
i := Pos('-', S);
if i > 1
then
Result := False
else
begin
Delete(S, i, 1);
Result := Pos('-', S) = 0;
end;
end;
const
EditChars = '01234567890-';
var
i: Integer;
S: String;
begin
S := EditChars;
Result := True;
if (Text = '') or (Text = '-')
then
begin
Result := False;
Exit;
end;
for i := 1 to Length(Text) do
begin
if Pos(Text[i], S) = 0
then
begin
Result := False;
Break;
end;
end;
Result := Result and GetMinus;
end;
procedure TbsSkinTrackEdit.Change;
var
NewValue: Integer;
begin
inherited;
if not StopCheck and IsNumText(Text)
then
begin
NewValue := CheckValue(StrToInt(Text));
if NewValue <> FValue
then
begin
FValue := NewValue;
Change;
end;
if NewValue <> StrToInt(Text)
then
Text := IntToStr(Round(Value));
end;
end;
procedure TbsSkinTrackEdit.CMTextChanged;
var
NewValue: Integer;
begin
inherited;
if not StopCheck and IsNumText(Text)
then
begin
NewValue := CheckValue(StrToInt(Text));
if NewValue <> FValue
then
begin
FValue := NewValue;
StopCheck := True;
Change;
StopCheck := False;
end;
if NewValue <> StrToInt(Text)
then
Text := IntToStr(Round(Value));
end;
end;
procedure TbsSkinTrackEdit.SetValue;
begin
FValue := CheckValue(AValue);
StopCheck := True;
Text := IntToStr(Round(CheckValue(AValue)));
StopCheck := False;
Change;
end;
procedure TbsSkinTrackEdit.KeyPress(var Key: Char);
begin
if Key = Char(VK_ESCAPE)
then
begin
if FPopupTrackBar.Visible then CloseUp;
end
else
if not IsValidChar(Key) then
begin
Key := #0;
MessageBeep(0)
end;
inherited KeyPress(Key);
end;
function TbsSkinTrackEdit.IsValidChar(Key: Char): Boolean;
begin
Result := (Key in ['-', '0'..'9']) or
((Key < #32) and (Key <> Chr(VK_RETURN)));
if ReadOnly and Result and ((Key >= #32) or
(Key = Char(VK_BACK)) or (Key = Char(VK_DELETE)))
then
Result := False;
end;
procedure TbsSkinTrackEdit.WMKillFocus(var Message: TWMKillFocus);
begin
inherited;
CloseUp;
end;
procedure TbsSkinTrackEdit.TrackBarChange(Sender: TObject);
begin
Value := FPopupTrackBar.Value;
end;
constructor TbsSkinPopupTrackBar.Create(AOwner: TComponent);
begin
inherited Create(AOwner);
ControlStyle := ControlStyle + [csNoDesignVisible, csReplicatable];
SkinDataName := 'htrackbar';
end;
procedure TbsSkinPopupTrackBar.CreateParams(var Params: TCreateParams);
begin
inherited CreateParams(Params);
with Params do
begin
Style := WS_POPUP;
ExStyle := WS_EX_TOOLWINDOW;
WindowClass.Style := CS_SAVEBITS;
end;
end;
procedure TbsSkinPopupTrackBar.WMMouseActivate(var Message: TMessage);
begin
Message.Result := MA_NOACTIVATE;
end;
constructor TbsSkinTimeEdit.Create(AOwner: TComponent);
begin
inherited;
fShowMSec := false;
EditMask := '!90:00:00;1; ';
Text := '00:00:00';
OnKeyPress := HandleOnKeyPress;
end;
procedure TbsSkinTimeEdit.CheckSpace(var S: String);
var
i: Integer;
begin
for i := 0 to Length(S) do
begin
if S[i] = ' ' then S[i] := '0';
end;
end;
procedure TbsSkinTimeEdit.HandleOnKeyPress(Sender: TObject; var Key: Char);
var
TimeStr: string;
aHour, aMinute, aSecond, aMillisecond: Word;
aHourSt, aMinuteSt, aSecondSt, aMillisecondSt: string;
begin
if (Key <> #13) and (Key <> #8)
then
begin
TimeStr := Text;
if SelLength > 1 then SelLength := 1;
if IsValidChar(Key)
then
begin
Delete(TimeStr,SelStart + 1, 1);
Insert(string(Key), TimeStr, SelStart + 1);
end;
try
aHourSt := Copy(TimeStr, 1, 2);
CheckSpace(aHourSt);
aMinuteSt := Copy(TimeStr, 4, 2);
CheckSpace(aMinuteSt);
aSecondSt := Copy(TimeStr, 7, 2);
CheckSpace(aSecondSt);
if fShowMSec then begin
aMillisecondSt := Copy(TimeStr, 10, 3);
end else begin
aMillisecondSt := '0';
end;
CheckSpace(aMillisecondSt);
aHour := StrToInt(aHourSt);
aMinute := StrToInt(aMinuteSt);
aSecond := StrToInt(aSecondSt);
aMillisecond := StrToInt(aMillisecondSt);
if not IsValidTime(aHour, aMinute, aSecond, aMillisecond) then begin
Key := #0;
end;
except
Key := #0;
end;
end;
end;
procedure TbsSkinTimeEdit.SetShowMilliseconds(const Value: Boolean);
begin
if fShowMSec <> Value then begin
fShowMSec := Value;
if fShowMSec then begin
EditMask := '!90:00:00.000;1; ';
Text := '00:00:00.000';
end else begin
EditMask := '!90:00:00;1; ';
Text := '00:00:00';
end;
end;
end;
procedure TbsSkinTimeEdit.SetMilliseconds(const Value: integer);
var
aHour, aMinute, aSecond, aMillisecond: integer;
St: string;
begin
aSecond := Value div 1000;
aMillisecond := Value mod 1000;
aMinute := aSecond div 60;
aSecond := aSecond mod 60;
aHour := aMinute div 60;
aMinute := aMinute mod 60;
St := Format('%2.2d:%2.2d:%2.2d.%3.3d', [aHour, aMinute, aSecond, aMillisecond]);
try
Text := St;
except
Text := '00:00:00.000';
end;
end;
function TbsSkinTimeEdit.GetMilliseconds: integer;
var
TimeStr: string;
aHour, aMinute, aSecond, aMillisecond: integer;
aHourSt, aMinuteSt, aSecondSt, aMillisecondSt: string;
begin
TimeStr := Text;
try
aHourSt := Copy(TimeStr, 1, 2);
CheckSpace(aHourSt);
aMinuteSt := Copy(TimeStr, 4, 2);
CheckSpace(aMinuteSt);
aSecondSt := Copy(TimeStr, 7, 2);
CheckSpace(aSecondSt);
aMillisecondSt := Copy(TimeStr, 10, 3);
CheckSpace(aMillisecondSt);
aHour := StrToInt(aHourSt);
aMinute := StrToInt(aMinuteSt);
aSecond := StrToInt(aSecondSt);
aMillisecond := StrToInt(aMillisecondSt);
Result := ((((aHour * 60) + aMinute) * 60) + aSecond) * 1000 + aMillisecond;
except
Result := 0;
end;
end;
procedure TbsSkinTimeEdit.SetTime(const Value: string);
var
TimeStr: string;
aHour, aMinute, aSecond, aMillisecond: integer;
aHourSt, aMinuteSt, aSecondSt, aMillisecondSt: string;
begin
TimeStr := Value;
try
aHourSt := Copy(TimeStr, 1, 2);
CheckSpace(aHourSt);
aMinuteSt := Copy(TimeStr, 4, 2);
CheckSpace(aMinuteSt);
aSecondSt := Copy(TimeStr, 7, 2);
CheckSpace(aSecondSt);
aHour := StrToInt(aHourSt);
aMinute := StrToInt(aMinuteSt);
aSecond := StrToInt(aSecondSt);
if fShowMSec then begin
aMillisecondSt := Copy(TimeStr, 10, 3);
CheckSpace(aMillisecondSt);
aMillisecond := StrToInt(aMillisecondSt);
Text := Format('%2.2d:%2.2d:%2.2d.%3.3d', [aHour, aMinute, aSecond, aMillisecond]);
end else begin
Text := Format('%2.2d:%2.2d:%2.2d', [aHour, aMinute, aSecond]);
end;
except
if fShowMSec then begin
Text := '00:00:00.000';
end else begin
Text := '00:00:00';
end;
end;
end;
function TbsSkinTimeEdit.GetTime: string;
begin
Result := Text;
end;
function TbsSkinTimeEdit.IsValidTime(const AHour, AMinute, ASecond, AMilliSecond: Word): Boolean;
begin
Result := ((AHour < 24) and (AMinute < 60) and
(ASecond < 60) and (AMilliSecond < 1000)) or
((AHour = 24) and (AMinute = 0) and
(ASecond = 0) and (AMilliSecond = 0));
end;
function TbsSkinTimeEdit.IsValidChar(Key: Char): Boolean;
begin
Result := Key in ['0'..'9'];
end;
procedure TbsSkinTimeEdit.DecodeTime(var Hour, Min, Sec, MSec: Word);
var
TimeStr: string;
aHourSt, aMinuteSt, aSecondSt, aMillisecondSt: string;
begin
TimeStr := Text;
aHourSt := Copy(TimeStr, 1, 2);
CheckSpace(aHourSt);
aMinuteSt := Copy(TimeStr, 4, 2);
CheckSpace(aMinuteSt);
aSecondSt := Copy(TimeStr, 7, 2);
CheckSpace(aSecondSt);
Hour := StrToInt(aHourSt);
Min := StrToInt(aMinuteSt);
Sec := StrToInt(aSecondSt);
if fShowMSec
then
aMillisecondSt := Copy(TimeStr, 10, 3)
else
aMillisecondSt := '000';
CheckSpace(aMillisecondSt);
Msec := StrToInt(aMillisecondSt);
end;
procedure TbsSkinTimeEdit.EncodeTime(Hour, Min, Sec, MSec: Word);
begin
if not IsValidTime(Hour, Min, Sec, MSec) then Exit;
try
if fShowMSec
then
Text := Format('%2.2d:%2.2d:%2.2d.%3.3d', [Hour, Min, Sec, MSec])
else
Text := Format('%2.2d:%2.2d:%2.2d', [Hour, Min, Sec]);
except
if fShowMSec
then
Text := '00:00:00.000'
else
Text := '00:00:00';
end;
end;
end.