home *** CD-ROM | disk | FTP | other *** search
- {
- BUSINESS CONSULTING
- s a i n t - p e t e r s b u r g
-
- Components Library for Borland Delphi 4.x, 5.x
- Copyright (c) 1998-2000 Alex'EM
-
- }
- unit DCCombo;
-
- interface
-
- uses
- Windows, Messages, Classes, Graphics, Controls, ComCtrls, StdCtrls,
- SysUtils, DCEditTools, DCChoice, DCEditButton, DCConst;
-
- const
- CountValues = 41;
- CountStdColors = 16;
-
- ColorValues: array[0..CountValues-1] of TColor =
- (clBlack, clMaroon, clGreen, clOlive, clNavy, clPurple, clTeal, clGray,
- clSilver, clRed, clLime, clYellow, clBlue, clFuchsia, clAqua, clWhite,
- clScrollBar, clBackground, clActiveCaption, clInactiveCaption, clMenu,
- clWindow, clWindowFrame, clMenuText, clWindowText, clCaptionText,
- clActiveBorder, clInactiveBorder, clAppWorkSpace, clHighlight,
- clHighlightText, clBtnFace, clBtnShadow, clGrayText, clBtnText,
- clInactiveCaptionText, clBtnHighlight, cl3DDkShadow, cl3DLight,
- clInfoText ,clInfoBk);
-
-
- type
- TDropDownStyle = (clsDropDown, clsDropDownList);
- TFontOption = (foTrueTypeOnly, foFixedPitchOnly);
- TFontOptions = set of TFontOption;
-
- TFontTypeImages = array[0..2] of TBitmap;
-
- TDCColorComboBox = class(TDCCustomComboBox)
- private
- FDropDownStyle: TDropDownStyle;
- FColorValue: TColor;
- FColorWidth: integer;
- FInButtonArea: boolean;
- FShowOnlyColor: boolean;
- procedure SetDropDownWidth;
- procedure InitItems(OnlyStandartColor: boolean);
- procedure SetDropDownStyle(const Value: TDropDownStyle);
- procedure SetColorValue(const Value: TColor);
- procedure SetColorWidth(const Value: integer);
- procedure DrawItem(Control: TWinControl; Index: Integer; Rect: TRect;
- State: TOwnerDrawState);
- procedure DrawColorBitmap(Control: TWinControl; R: TRect;
- Index: Integer; Bitmap: TBitmap);
- procedure DrawColorItem(ACanvas:TCanvas; R: TRect; AColor: TColor;
- Text: string; Tag: integer = 0);
- procedure DrawColor(ACanvas:TCanvas; ARect: TRect; AColor: TColor;
- ATransparent: boolean = False);
- procedure FormatColor(AColor: integer);
- procedure SetShowOnlyColor(const Value: boolean);
- procedure DoDrawText(ACanvas: TCanvas; Control: TWinControl; Index: Integer;
- Rect: TRect; State: TOwnerDrawState);
- protected
- procedure WMPaint (var Message: TWMPaint); message WM_PAINT;
- procedure WMSize(var Message: TWMSize); message WM_SIZE;
- procedure WMNCHitTest(var Message: TWMNCHitTest); message WM_NCHITTEST;
- procedure WMLButtonDblClk(var Message: TWMLButtonDown); message WM_LBUTTONDBLCLK;
- procedure CMFontChanged(var Message: TMessage); message CM_FONTCHANGED;
- procedure Change; override;
- procedure GetHintOnError; override;
- public
- constructor Create(AOwner: TComponent); override;
- procedure KillFocus(var Value: boolean); override;
- published
- property DropDownStyle: TDropDownStyle read FDropDownStyle write SetDropDownStyle;
- property ColorValue: TColor read FColorValue write SetColorValue;
- property ColorWidth: integer read FColorWidth write SetColorWidth;
- property DrawStyle;
- property OnlyStdColors: boolean read FShowOnlyColor write SetShowOnlyColor;
- property OnIndexChange;
- end;
-
- TDCFontComboBox = class(TDCCustomComboBox)
- private
- FDropDownStyle: TDropDownStyle;
- FOptions: TFontOptions;
- FFontTypeImages: TFontTypeImages;
- procedure SetDropDownWidth;
- procedure InitItems;
- function GetFontName: string;
- procedure SetDropDownStyle(const Value: TDropDownStyle);
- procedure SetFontName(const Value: string);
- procedure SetOptions(const Value: TFontOptions);
- procedure DrawItem(Control: TWinControl; Index: Integer; Rect: TRect;
- State: TOwnerDrawState);
- procedure DrawFontItem(ACanvas:TCanvas; R: TRect; FontType: integer;
- Text: string; Tag: integer = 0);
- procedure DrawFont(ACanvas:TCanvas; ARect: TRect; FontType: integer);
- protected
- procedure CMFontChanged(var Message: TMessage); message CM_FONTCHANGED;
- procedure WMSize(var Message: TWMSize); message WM_SIZE;
- public
- constructor Create(AOwner: TComponent); override;
- destructor Destroy; override;
- published
- property FontName: string read GetFontName write SetFontName;
- property DropDownStyle: TDropDownStyle read FDropDownStyle write SetDropDownStyle;
- property Options: TFontOptions read FOptions write SetOptions;
- property DrawStyle;
- property OnIndexChange;
- end;
-
- implementation
- uses Printers, Dialogs;
-
- {$R DCCombo.RES}
-
- { TDCColorComboBox }
-
- procedure TDCColorComboBox.Change;
- begin
- if Parent <> nil then
- begin
- DrawBitmap(ItemIndex);
- RedrawBorder(False, 0);
- end;
- inherited;
- end;
-
- procedure TDCColorComboBox.CMFontChanged(var Message: TMessage);
- begin
- inherited;
- SetDropDownWidth;
- end;
-
- constructor TDCColorComboBox.Create(AOwner: TComponent);
- begin
- inherited;
-
- FShowOnlyColor:= False;
- DropDownStyle := clsDropDown;
- ColorWidth := 20;
-
- OnDrawItem := DrawItem;
- OnDrawBitmap := DrawColorBitmap;
- OnDrawText := DoDrawText;
-
- InitItems(FShowOnlyColor);
- SetDropDownWidth;
-
- ColorValue := clBlack;
- end;
-
- procedure TDCColorComboBox.DrawColor(ACanvas: TCanvas; ARect: TRect;
- AColor: TColor; ATransparent: boolean = False);
- var
- SColor: TColor;
- begin
- with ACanvas do
- begin
- SColor := Brush.Color;
- if ATransparent then
- begin
- Brush.Color:= clWhite;
- FillRect(ARect);
- end;
- InflateRect(ARect, -1, -1);
- Pen.Color := clBtnShadow;
- Brush.Color := AColor;
- Rectangle(ARect.Left, ARect.Top, ARect.Right, ARect.Bottom);
- Brush.Color := SColor;
- end;
- end;
-
- procedure TDCColorComboBox.DrawColorBitmap(Control: TWinControl; R: TRect;
- Index: Integer; Bitmap: TBitmap);
- var
- AColor: TColor;
- i:integer;
- begin
- if Index <> -1 then
- AColor := StringToColor(Items.Strings[Index])
- else
- begin
- i := StrToInt64Def(Text, clWhite);
- AColor := TColor(i);
- end;
-
- with Bitmap do
- begin
- Height := ClientHeight;
- R.Bottom := Height;
- DrawColor(Canvas, R, AColor, True);
- end;
- FColorValue := AColor;
- end;
-
- procedure TDCColorComboBox.DrawColorItem(ACanvas:TCanvas; R: TRect;
- AColor: TColor; Text: string; Tag: integer = 0);
- var
- ARect: TRect;
- AOffsetX: integer;
- begin
- case DrawStyle of
- fsNone: AOffsetX := 0;
- fsFlat: AOffsetX := 1;
- else AOffsetX := 2;
- end;
- if Tag = 1 then Dec(AOffsetX, 1);
-
- if FShowOnlyColor and (FDropDownStyle = clsDropDownList) then
- DrawColor(ACanvas, R, AColor)
- else begin
- ACanvas.FillRect(R);
- ARect := Classes.Rect(R.Left+AOffsetX, R.Top, R.Left+AOffsetX+FColorWidth,
- R.Bottom);
- DrawColor(ACanvas, ARect, AColor);
- R.Left := R.Left +4+ FColorWidth;
- Windows.DrawText(ACanvas.Handle, PChar(Text), Length(Text), R, 0);
- end;
- end;
-
- procedure TDCColorComboBox.DrawItem(Control: TWinControl; Index: Integer;
- Rect: TRect; State: TOwnerDrawState);
- begin
- if Index <> -1 then
- DrawColorItem(Canvas, Rect, StringToColor(Items.Strings[Index]),
- Items.Strings[Index])
- end;
-
- procedure TDCColorComboBox.InitItems(OnlyStandartColor: boolean);
- var
- i: integer;
- begin
- Items.Clear;
- if not OnlyStandartColor then
- for i := 0 to CountValues-1 do
- Items.Add(ColorToString(ColorValues[i]))
- else
- for i := 0 to CountStdColors-1 do
- Items.Add(ColorToString(ColorValues[i]))
- end;
-
- procedure TDCColorComboBox.SetDropDownStyle(const Value: TDropDownStyle);
- begin
- FDropDownStyle := Value;
- case FDropDownStyle of
- clsDropDown :
- begin
- Style := csDropDown;
- ShowCheckBox := True;
- OnDrawBitmap := DrawColorBitmap;
- end;
- clsDropDownList:
- begin
- Style := csDropDownList;
- ShowCheckBox := False;
- OnDrawBitmap := nil;
- Text := ColorToString(ColorValue);
- end;
- end;
- end;
-
- procedure TDCColorComboBox.SetColorValue(const Value: TColor);
- var
- i: integer;
- begin
- ItemIndex := -1;
- FColorValue := Value;
- for i := 0 to Items.Count-1 do
- if StringToColor(Items.Strings[i]) = Value then
- begin
- ItemIndex := i;
- Break;
- end;
- if (ItemIndex = -1) then FormatColor(FColorValue);
- end;
-
- procedure TDCColorComboBox.SetColorWidth(const Value: integer);
- begin
- FColorWidth := Value;
- CheckGlyph.Width := FColorWidth;
- SetDropDownWidth;
- Invalidate;
- end;
-
- procedure TDCColorComboBox.SetDropDownWidth;
- begin
- DropDownWidth := GetDCTextWidth(Font, 'clInactiveCaptionText') +
- GetSystemMetrics(SM_CXVSCROLL) + 8;
- case FDropDownStyle of
- clsDropDown : DropDownWidth := DropDownWidth + FColorWidth + 2;
- clsDropDownList: if OnlyStdColors then DropDownWidth := 0;
- end;
- if DropDownWidth < Width then DropDownWidth := 0;
- end;
-
- procedure TDCColorComboBox.WMPaint(var Message: TWMPaint);
- begin
- inherited;
- end;
-
- procedure TDCColorComboBox.WMSize(var Message: TWMSize);
- begin
- inherited;
- if DropDownWidth < Width then DropDownWidth := 0;
- end;
-
- procedure TDCColorComboBox.KillFocus(var Value: boolean);
- var
- i, j: integer;
- begin
- if not Value then begin
- if ItemIndex = -1 then
- begin
- i := StrToInt64Def(Text, -1);
- if i = -1 then
- begin
- Value := True;
- ErrorCode := ERR_EDIT_INCORRECTDEC;
- end
- else begin
- for j := Low(ColorValues) to High(ColorValues) do
- begin
- if ColorToRGB(ColorValues[j]) = i then
- begin
- ItemIndex := j;
- Exit;
- end;
- end;
- FormatColor(i);
- end;
- end;
- end;
- inherited;
- end;
-
- procedure TDCColorComboBox.GetHintOnError;
- begin
- case ErrorCode of
- ERR_EDIT_INCORRECTDEC: ErrorHint := LoadStr(RES_EDIT_ERR_DEC);
- else
- ErrorHint := '';
- end;
- end;
-
- procedure TDCColorComboBox.WMLButtonDblClk(var Message: TWMLButtonDown);
- begin
- if not FInButtonArea and not(FDropDownStyle = clsDropDownList) then
- begin
- Message.Result := $AE;
- inherited WMLButtonDblClk(Message);
-
- with TColorDialog.Create(Self) do
- begin
- Color := ColorValue;
- Execute;
- ColorValue := Color;
- Free;
- end;
- end
- else begin
- Message.Result := $AE;
- inherited WMLButtonDblClk(Message);
- end;
- end;
-
- procedure TDCColorComboBox.WMNCHitTest(var Message: TWMNCHitTest);
- var
- P: TPoint;
- begin
- inherited;
- P := Self.ScreenToClient(Point(Message.XPos, Message.YPos));
-
- if BtnChoiceAssigned and (P.X >= (Width - ButtonWidth - 2)) then
- FInButtonArea := True
- else
- FInButtonArea := False;
-
- inherited;
- end;
-
- procedure TDCColorComboBox.FormatColor(AColor: Integer);
- var
- j, i: integer;
- begin
- Text := Format('%x', [AColor]);
- if Length(Text) < 8 then
- begin
- j := Length(Text);
- for i := 1 to 8 - j do Text := '0' + Text;
- end;
- Text := '$' + Text;
- end;
-
- procedure TDCColorComboBox.SetShowOnlyColor(const Value: boolean);
- begin
- FShowOnlyColor := Value;
- InitItems(FShowOnlyColor);
- SetDropDownWidth;
- end;
-
- procedure TDCColorComboBox.DoDrawText(ACanvas: TCanvas; Control: TWinControl;
- Index: Integer; Rect: TRect; State: TOwnerDrawState);
- begin
- Rect.Bottom := Rect.Bottom + 1;
- DrawColorItem(ACanvas, Rect, StringToColor(Items.Strings[Index]),
- Items.Strings[Index])
- end;
-
- { TDCFontComboBox }
-
- function RequestedFont(Data: Pointer; LogFont: TLogFont; FontType: Integer): boolean;
- var
- FontCombo: TDCFontComboBox;
- begin
- Result := True;
- FontCombo := TDCFontComboBox(Data);
- if foTrueTypeOnly in FontCombo.Options then
- Result := Result and (FontType and TRUETYPE_FONTTYPE = TRUETYPE_FONTTYPE);
- if foFixedPitchOnly in FontCombo.Options then
- Result := Result and (LogFont.lfPitchAndFamily and FIXED_PITCH = FIXED_PITCH);
- end;
-
- function EnumFontsProc(var LogFont: TLogFont; var TextMetric: TTextMetric;
- FontType: Integer; Data: Pointer): Integer; stdcall;
- var
- S: TStrings;
- FaceName: string;
- begin
- S := TDCFontComboBox(Data).Items;
- FaceName := LogFont.lfFaceName;
- if (S.IndexOf(FaceName) < 0) and RequestedFont(Data, LogFont,FontType) then
- S.AddObject(FaceName, TObject(FontType));
- Result := 1;
- end;
-
- procedure TDCFontComboBox.CMFontChanged(var Message: TMessage);
- begin
- inherited;
- SetDropDownWidth
- end;
-
- constructor TDCFontComboBox.Create(AOwner: TComponent);
- begin
- inherited;
- InitItems;
- DropDownStyle := clsDropDown;
-
- OnDrawItem := DrawItem;
-
- FFontTypeImages[0] := TBitmap.Create;
- FFontTypeImages[1] := TBitmap.Create;
- FFontTypeImages[2] := TBitmap.Create;
-
- FFontTypeImages[0].LoadFromResourceName(HInstance, 'DC_RASTER_FONT');
- FFontTypeImages[1].LoadFromResourceName(HInstance, 'DC_DEVICE_FONT');
- FFontTypeImages[2].LoadFromResourceName(HInstance, 'DC_TRUETYPE_FONT');
-
- TStringList(Items).Sorted := True;
- CheckGlyph.Width := FFontTypeImages[0].Width;
-
- SetDropDownWidth;
- end;
-
- destructor TDCFontComboBox.Destroy;
- begin
- FFontTypeImages[0].Free;
- FFontTypeImages[1].Free;
- FFontTypeImages[2].Free;
- inherited;
- end;
-
- procedure TDCFontComboBox.DrawFont(ACanvas: TCanvas; ARect: TRect;
- FontType: integer);
- var
- Bitmap: TBitmap;
- begin
- with ACanvas do
- begin
- Bitmap := nil;
- if FontType <> -1 then
- begin
- if FontType and RASTER_FONTTYPE = RASTER_FONTTYPE then
- Bitmap := FFontTypeImages[0];
- if FontType and DEVICE_FONTTYPE = DEVICE_FONTTYPE then
- Bitmap := FFontTypeImages[1];
- if FontType and TRUETYPE_FONTTYPE = TRUETYPE_FONTTYPE then
- Bitmap := FFontTypeImages[2];
- end;
- if Bitmap <> nil then
- BrushCopy(Bounds(ARect.Left, ARect.Top, Bitmap.Width, Bitmap.Height),
- Bitmap, Bounds(0, 0, Bitmap.Width, Bitmap.Height),
- Bitmap.Canvas.Pixels[0,0])
- else
- FillRect(ARect);
- end;
- end;
-
- procedure TDCFontComboBox.DrawFontItem(ACanvas: TCanvas; R: TRect;
- FontType: integer; Text: string; Tag: integer);
- var
- ARect: TRect;
- AOffsetX: integer;
- begin
- case DrawStyle of
- fsNone: AOffsetX := 0;
- fsFlat: AOffsetX := 1;
- else AOffsetX := 2;
- end;
- if Tag = 1 then Dec(AOffsetX, 1);
-
- ACanvas.FillRect(R);
- ARect := Classes.Rect(R.Left+AOffsetX, R.Top,
- R.Left+AOffsetX+FFontTypeImages[0].Width, R.Bottom);
- DrawFont(ACanvas, ARect, FontType);
- R.Left := R.Left +4+ FFontTypeImages[0].Width;
- Windows.DrawText(ACanvas.Handle, PChar(Text), Length(Text), R, 0);
- end;
-
- procedure TDCFontComboBox.DrawItem(Control: TWinControl; Index: Integer;
- Rect: TRect; State: TOwnerDrawState);
- begin
- DrawFontItem(Canvas, Rect, Integer(Items.Objects[Index]),
- Items.Strings[Index])
- end;
-
- function TDCFontComboBox.GetFontName: string;
- begin
- if ItemIndex > 0 then Result := Items.Strings[ItemIndex];
- end;
-
- procedure TDCFontComboBox.InitItems;
- var
- DC: HDC;
- LFont: TLogFont;
- begin
- Items.Clear;
- DC := GetDC(0);
- try
- if Lo(GetVersion) >= 4 then
- begin
- FillChar(LFont, sizeof(LFont), 0);
- LFont.lfCharset := DEFAULT_CHARSET;
- EnumFontFamiliesEx({Printer.Handle}DC, LFont, @EnumFontsProc, LongInt(Self), 0);
- end
- else
- EnumFonts(DC, nil, @EnumFontsProc, Pointer(Items));
- finally
- ReleaseDC(0, DC);
- end;
- end;
-
- procedure TDCFontComboBox.SetDropDownStyle(const Value: TDropDownStyle);
- begin
- FDropDownStyle := Value;
- case FDropDownStyle of
- clsDropDown :
- begin
- Style := csDropDown;
- ShowCheckBox := True;
- end;
- clsDropDownList:
- begin
- Style := csDropDownList;
- ShowCheckBox := False;
- Text := FontName;
- end;
- end;
- end;
-
- procedure TDCFontComboBox.SetDropDownWidth;
- var
- i, MaxWidth, CurWidth: integer;
- ACanvas: TCanvas;
- begin
- MaxWidth := Width;
- ACanvas := TControlCanvas.Create;
- ACanvas.Handle := GetDC(0);
- ACanvas.Font := Font;
- try
- for i:= 0 to Items.Count - 1 do
- begin
- CurWidth := GetTextWidth(ACanvas.Handle, Items.Strings[i]) +
- FFontTypeImages[0].Width + 8 + GetSystemMetrics(SM_CXVSCROLL);
- if CurWidth > MaxWidth then MaxWidth := CurWidth;
- end;
- DropDownWidth := MaxWidth;
- finally
- ReleaseDC(0, ACanvas.Handle);
- ACanvas.Free;
- end
- end;
-
- procedure TDCFontComboBox.SetFontName(const Value: string);
- begin
- if FontName <> Value then
- begin
- ItemIndex := Items.IndexOf(Value);
- end;
- end;
-
- procedure TDCFontComboBox.SetOptions(const Value: TFontOptions);
- begin
- FOptions := Value;
- InitItems;
- end;
-
- procedure TDCFontComboBox.WMSize(var Message: TWMSize);
- begin
- inherited;
- if DropDownWidth < Width then DropDownWidth := 0;
- end;
-
- end.
-