Chip 2001 October/Chip_2001-10_cd1.bin/zkuste/delphi/kolekce/d456/DCSLIB25.ZIP/DCCombo.pas

Pascal/Delphi Source File | 2001-01-20 | 17KB | 616 lines

{
 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.