rxcombos.pas

RX Library contains a large number of components, objects and routines for Borland Delphi with full

procedure TColorComboBox.SetDisplayNames(Value: Boolean);
begin
  if DisplayNames <> Value then begin
    FDisplayNames := Value;
    Invalidate;
  end;
end;

{$IFDEF RX_D3}
procedure TColorComboBox.SetOptions(Value: TColorComboOptions);
begin
  if FOptions <> Value then begin
    FOptions := Value;
    if HandleAllocated then RecreateWnd;
  end;
end;
{$ENDIF}

function TColorComboBox.GetColorValue: TColor;
var
  I: Integer;
begin
  Result := FColorValue;
  if (Style <> csDropDownList) and (ItemIndex < 0) then begin
    I := Items.IndexOf(inherited Text);
    if I >= 0 then Result := TColor(Items.Objects[I])
    else begin
      Val(inherited Text, Result, I);
      if I <> 0 then Result := FColorValue;
    end;
  end;
end;

procedure TColorComboBox.SetColorValue(NewValue: TColor);
var
  Item: Integer;
  CurrentColor: TColor;
  S: string;
begin
  if (ItemIndex < 0) or (NewValue <> FColorValue) then begin
    FColorValue := NewValue;
    { change selected item }
    for Item := 0 to Pred(Items.Count) do begin
      CurrentColor := TColor(Items.Objects[Item]);
      if CurrentColor = NewValue then begin
        if ItemIndex <> Item then ItemIndex := Item;
        DoChange;
        Exit;
      end;
    end;
    if Style = csDropDownList then
      ItemIndex := -1
    else begin
      S := ColorToString(NewValue);
      if Pos('cl', S) = 1 then System.Delete(S, 1, 2);
      inherited Text := S;
    end;
    DoChange;
  end;
end;

procedure TColorComboBox.DrawItem(Index: Integer; Rect: TRect;
  State: TOwnerDrawState);

  function ColorToBorderColor(AColor: TColor): TColor;
  type
    TColorQuad = record
      Red, Green, Blue, Alpha: Byte;
    end;
  begin
    if (TColorQuad(AColor).Red > 192) or (TColorQuad(AColor).Green > 192) or
       (TColorQuad(AColor).Blue > 192) then
      Result := clBlack
    else if (odSelected in State) then
      Result := clWhite
    else
      Result := AColor;
  end;

const
  ColorWidth = 22;
var
  ARect: TRect;
  Text: array[0..255] of Char;
  Safer: TColor;
begin
  ARect := Rect;
  Inc(ARect.Top, 2);
  Inc(ARect.Left, 2);
  Dec(ARect.Bottom, 2);
  if FDisplayNames then ARect.Right := ARect.Left + ColorWidth
  else Dec(ARect.Right, 3);
  with Canvas do begin
    FillRect(Rect);
    Safer := Brush.Color;
    Pen.Color := ColorToBorderColor(ColorToRGB(TColor(Items.Objects[Index])));
    Rectangle(ARect.Left, ARect.Top, ARect.Right, ARect.Bottom);
    Brush.Color := TColor(Items.Objects[Index]);
    try
      InflateRect(ARect, -1, -1);
      FillRect(ARect);
    finally
      Brush.Color := Safer;
    end;
    if FDisplayNames then begin
      StrPCopy(Text, Items[Index]);
      Rect.Left := Rect.Left + ColorWidth + 6;
      DrawText(Canvas.Handle, Text, StrLen(Text), Rect,
{$IFDEF RX_D4}
        DrawTextBiDiModeFlags(DT_SINGLELINE or DT_VCENTER or DT_NOPREFIX));
{$ELSE}
        DT_SINGLELINE or DT_VCENTER or DT_NOPREFIX);
{$ENDIF}
    end;
  end;
end;

procedure TColorComboBox.Change;
var
  AColor: TColor;
begin
  inherited Change;
  AColor := GetColorValue;
  if FColorValue <> AColor then begin
    FColorValue := AColor;
    DoChange;
  end;
end;

procedure TColorComboBox.Click;
begin
  if ItemIndex >= 0 then ColorValue := TColor(Items.Objects[ItemIndex]);
  inherited Click;
end;

procedure TColorComboBox.DoChange;
begin
  if not (csReading in ComponentState) then
    if Assigned(FOnChange) then FOnChange(Self);
end;

{ TFontComboBox }

const
  WRITABLE_FONTTYPE = 256;

function IsValidFont(Box: TFontComboBox; 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;

{$IFDEF WIN32}

function EnumFontsProc(var EnumLogFont: TEnumLogFont;
  var TextMetric: TNewTextMetric; FontType: Integer; Data: LPARAM): Integer;
  export; stdcall;
var
  FaceName: string;
begin
  FaceName := StrPas(EnumLogFont.elfLogFont.lfFaceName);
  with TFontComboBox(Data) do
    if (Items.IndexOf(FaceName) < 0) and
      IsValidFont(TFontComboBox(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;

{$ELSE}

function EnumFontsProc(var LogFont: TLogFont; var TextMetric: TTextMetric;
  FontType: Integer; Data: Pointer): Integer; export;
begin
  with TFontComboBox(Data) do
    if (Items.IndexOf(StrPas(LogFont.lfFaceName)) < 0) and
      IsValidFont(TFontComboBox(Data), LogFont, FontType) then
    begin
      if LogFont.lfCharSet = SYMBOL_CHARSET then
        FontType := FontType or WRITABLE_FONTTYPE;
      Items.AddObject(StrPas(LogFont.lfFaceName), TObject(FontType));
    end;
  Result := 1;
end;

{$ENDIF WIN32}

constructor TFontComboBox.Create(AOwner: TComponent);
begin
  inherited Create(AOwner);
  FTrueTypeBMP := CreateBitmap('TRUETYPE_FNT');
  FDeviceBMP := CreateBitmap('DEVICE_FNT');
  FDevice := fdScreen;
  Sorted := True;
  inherited ItemHeight := MinItemHeight;
end;

destructor TFontComboBox.Destroy;
begin
  FTrueTypeBMP.Free;
  FDeviceBMP.Free;
  inherited Destroy;
end;

procedure TFontComboBox.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;

procedure TFontComboBox.PopulateList;
var
  DC: HDC;
{$IFNDEF WIN32}
  Proc: TFarProc;
{$ENDIF}
begin
  if not HandleAllocated then Exit;
  Items.BeginUpdate;
  try
    Clear;
    DC := GetDC(0);
    try
{$IFDEF WIN32}
      if (FDevice = fdScreen) or (FDevice = fdBoth) then
        EnumFontFamilies(DC, nil, @EnumFontsProc, Longint(Self));
      if (FDevice = fdPrinter) or (FDevice = fdBoth) then
      try
        EnumFontFamilies(Printer.Handle, nil, @EnumFontsProc, Longint(Self));
      except
        { skip any errors }
      end;
{$ELSE}
      Proc := MakeProcInstance(@EnumFontsProc, HInstance);
      try
        if (FDevice = fdScreen) or (FDevice = fdBoth) then
          EnumFonts(DC, nil, Proc, PChar(Self));
        if (FDevice = fdPrinter) or (FDevice = fdBoth) then
          try
            EnumFonts(Printer.Handle, nil, Proc, PChar(Self));
          except
            { skip any errors }
          end;
      finally
        FreeProcInstance(Proc);
      end;
{$ENDIF}
    finally
      ReleaseDC(0, DC);
    end;
  finally
    Items.EndUpdate;
  end;
end;

procedure TFontComboBox.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;
          DoChange;
          Exit;
        end;
      if Style = csDropDownList then ItemIndex := -1
      else inherited Text := NewFontName;
    end
    else inherited Text := NewFontName;
    DoChange;
  end;
end;

function TFontComboBox.GetFontName: TFontName;
begin
  Result := inherited Text;
end;

function TFontComboBox.GetTrueTypeOnly: Boolean;
begin
  Result := foTrueTypeOnly in FOptions;
end;

procedure TFontComboBox.SetOptions(Value: TFontListOptions);
begin
  if Value <> Options then begin
    FOptions := Value;
    Reset;
  end;
end;

procedure TFontComboBox.SetTrueTypeOnly(Value: Boolean);
begin
  if Value <> TrueTypeOnly then begin
    if Value then FOptions := FOptions + [foTrueTypeOnly]
    else FOptions := FOptions - [foTrueTypeOnly];
    Reset;
  end;
end;

procedure TFontComboBox.SetDevice(Value: TFontDevice);
begin
  if Value <> FDevice then begin
    FDevice := Value;
    Reset;
  end;
end;

procedure TFontComboBox.SetUseFonts(Value: Boolean);
begin
  if Value <> FUseFonts then begin
    FUseFonts := Value;
    Invalidate;
  end;
end;

procedure TFontComboBox.DrawItem(Index: Integer; Rect: TRect;
  State: TOwnerDrawState);
var
  Bitmap: TBitmap;
  BmpWidth: Integer;
  Text: array[0..255] of Char;
begin
  with Canvas do begin
    FillRect(Rect);
    BmpWidth  := 20;
    if (Integer(Items.Objects[Index]) and TRUETYPE_FONTTYPE) <> 0 then
      Bitmap := FTrueTypeBMP
    else if (Integer(Items.Objects[Index]) and DEVICE_FONTTYPE) <> 0 then
      Bitmap := FDeviceBMP
    else Bitmap := nil;
    if Bitmap <> nil then begin
      BmpWidth := Bitmap.Width;
      BrushCopy(Bounds(Rect.Left + 2, (Rect.Top + Rect.Bottom - Bitmap.Height)
        div 2, Bitmap.Width, Bitmap.Height), Bitmap, Bounds(0, 0, Bitmap.Width,
        Bitmap.Height), Bitmap.TransparentColor);
    end;
    { uses DrawText instead of TextOut in order to get clipping against
      the combo box button }
    {TextOut(Rect.Left + bmpWidth + 6, Rect.Top, Items[Index])}
    StrPCopy(Text, Items[Index]);
    Rect.Left := Rect.Left + BmpWidth + 6;
    if FUseFonts and (Integer(Items.Objects[Index]) and WRITABLE_FONTTYPE <> 0) then
      Font.Name := Items[Index];
    DrawText(Handle, Text, StrLen(Text), Rect,
{$IFDEF RX_D4}
      DrawTextBiDiModeFlags(DT_SINGLELINE or DT_VCENTER or DT_NOPREFIX));
{$ELSE}
      DT_SINGLELINE or DT_VCENTER or DT_NOPREFIX);
{$ENDIF}
  end;
end;

procedure TFontComboBox.WMFontChange(var Message: TMessage);
begin
  inherited;
  Reset;
end;

function TFontComboBox.MinItemHeight: Integer;
begin
  Result := inherited MinItemHeight;
  if Result < FTrueTypeBMP.Height - 1 then
    Result := FTrueTypeBMP.Height - 1;
end;

procedure TFontComboBox.Change;
var
  I: Integer;
begin
  inherited Change;
  if Style <> csDropDownList then begin
    I := Items.IndexOf(inherited Text);
    if (I >= 0) and (I <> ItemIndex) then begin
      ItemIndex := I;
      DoChange;
    end;
  end;
end;

procedure TFontComboBox.Click;
begin
  inherited Click;
  DoChange;
end;

procedure TFontComboBox.DoChange;
begin
  if not (csReading in ComponentState) then
    if not FUpdate and Assigned(FOnChange) then FOnChange(Self);
end;

procedure TFontComboBox.Reset;
var
  SaveName: TFontName;
begin
  if HandleAllocated then begin
    FUpdate := True;
    try
      SaveName := FontName;
      PopulateList;
      FontName := SaveName;
    finally
      FUpdate := False;
      if FontName <> SaveName then DoChange;
    end;
  end;
end;

end.