jvcolorcombo.pas

East make Tray Icon in delphi

  if not HandleAllocated then
    Exit;
  MRUItems := TStringList.Create;
  try
    if FShowMRU then
      for I := 0 to MRUCount - 1 do
        MRUItems.AddObject(Items[I], Items.Objects[I]);
    Clear;
    DC := GetDC(HWND_DESKTOP);
    try
      if FDevice in [fdScreen, fdBoth] then
        EnumFonts(DC, nil, @EnumFontsProc, Pointer(Self));
      if FDevice in [fdPrinter, fdBoth] then
      try
        EnumFonts(Printer.Handle, nil, @EnumFontsProc, Pointer(Self));
      except
        // (p3) exception might be raised if no printer is installed, but ignore it here
      end;
    finally
      ReleaseDC(HWND_DESKTOP, DC);
    end;
    if FShowMRU then
      for I := MRUCount - 1 downto 0 do
      begin
        Items.InsertObject(0, MRUItems[I], MRUItems.Objects[I]);
      end;
  finally
    MRUItems.Free;
  end;
end;

procedure TJvFontComboBox.SetOptions(Value: TJvFontComboOptions);
begin
  if Value <> Options then
  begin
    FOptions := Value;
    if (foPreviewFont in FOptions) then
      Exclude(FOptions, foWysiWyg);
    SetShowMRU(foMRU in FOptions);
    Reset;
  end;
end;

procedure TJvFontComboBox.SetUseImages(Value: Boolean);
begin
  if FUseImages <> Value then
  begin
    FUseImages := Value;
    Invalidate;
  end;
end;

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

procedure TJvFontComboBox.CNDrawItem(var Msg: TWMDrawItem);
var
  State: TOwnerDrawState;
begin
  with Msg.DrawItemStruct^ do
  begin
    State := ItemStateToOwnerDrawState(itemState);
    Canvas.Handle := hDC;
    Canvas.Font := Font;
    Canvas.Brush := Brush;
    if (Integer(itemID) >= 0) and (odSelected in State) then
    begin
      Canvas.Brush.Color := FHiliteColor;
      Canvas.Font.Color := FHiliteText;
    end;
    if Integer(itemID) >= 0 then
      DrawItem(itemID, rcItem, State)
    else
      Canvas.FillRect(rcItem);
    Canvas.Handle := 0;
  end;
end;

function TJvFontComboBox.DoDrawPreview(const AFontName: string;
  var APreviewText: string; ATextWidth: Integer): Boolean;
begin
  Result := ATextWidth < ClientWidth;
  if Assigned(FOnDrawPreviewEvent) then
    FOnDrawPreviewEvent(Self, AFontName, APreviewText, ATextWidth, Result);
end;

procedure TJvFontComboBox.DrawItem(Index: Integer; R: TRect;
  State: TOwnerDrawState);
var
  ABmp: TBitmap;
  AColor: TColor;
  AWidth: Integer;
  TmpRect: TRect;
  S, AName: string;
begin
  with Canvas do
  begin
    AColor := Brush.Color;
    Brush.Color := Color;
    Pen.Color := Font.Color;
    FillRect(R);
    Inc(R.Top);
    //    AWidth  := 20;
    if (Integer(Items.Objects[Index]) and TRUETYPE_FONTTYPE) <> 0 then
      ABmp := FTrueTypeBmp
    else
    if (Integer(Items.Objects[Index]) and DEVICE_FONTTYPE) <> 0 then
      ABmp := FDeviceBmp
    else
      ABmp := FFixBmp;
    if not FUseImages then
      ABmp := nil;

    if ABmp <> nil then
    begin
      AWidth := ABmp.Width;
      BrushCopy(Bounds(R.Left + 2, (R.Top + R.Bottom - ABmp.Height) div 2,
        ABmp.Width, ABmp.Height), ABmp, Bounds(0, 0, ABmp.Width, ABmp.Height), clFuchsia);
      R.Left := R.Left + AWidth + 6;
    end
    else
      AWidth := 4;
    Brush.Color := AColor;
    AName := Canvas.Font.Name;
    if foWysiWyg in FOptions then
    begin
      if (foPreviewFont in Options) then
        Canvas.Font.Name := Self.Font.Name
      else
        Canvas.Font.Name := Items[Index];
    end;
    if not (foPreviewFont in Options) then
      R.Right := R.Left + TextWidth(Items[Index]) + 6;
    FillRect(R);
    OffsetRect(R, 2, 0);
    DrawText(Canvas.Handle, PChar(Items[Index]), -1, R, DT_SINGLELINE or DT_VCENTER or DT_NOPREFIX);
    if (foPreviewFont in Options) then
    begin
      Inc(AWidth, TextWidth(Items[Index]) + 36);
      Canvas.Font.Name := Items[Index];
      S := 'AbCdEfGhIj';
      Inc(AWidth, TextWidth(S));
      if DoDrawPreview(Items[Index], S, AWidth) then
      begin
        TmpRect := R;
        TmpRect.Left := 0;
        TmpRect.Right := ClientWidth - (GetSystemMetrics(SM_CXVSCROLL) + 8);
        R.Right := ClientWidth;
        DrawText(Canvas.Handle, PChar(S), -1, TmpRect, DT_SINGLELINE or DT_VCENTER or DT_RIGHT or DT_NOPREFIX);
      end;
    end;
    Canvas.Font.Name := AName;
    OffsetRect(R, -2, 0);
    if odSelected in State then
      DrawFocusRect(R);
    if FShowMRU and not (odComboBoxEdit in State) then
    begin
      // draw MRU separator
      Dec(R.Top);
      if (Index = MRUCount - 1) then
      begin
        Canvas.Pen.Color := clGray;
        Canvas.Pen.Width := 1;
        Canvas.MoveTo(0, R.Bottom - 1);
        Canvas.LineTo(ClientWidth, R.Bottom - 1);
      end
      else
      if (Index = MRUCount) and (Index > 0) then
      begin
        Canvas.Pen.Color := clGray;
        Canvas.Pen.Width := 1;
        Canvas.MoveTo(0, R.Top + 1);
        Canvas.LineTo(ClientWidth, R.Top + 1);
      end;
    end;
  end;
end;

{procedure TJvFontComboBox.WMFontChange(var Msg: TMessage);
begin
  inherited;
  Reset;
end;}

procedure TJvFontComboBox.FontChanged;
begin
  inherited FontChanged;
  ResetItemHeight;
  RecreateWnd;
end;

procedure TJvFontComboBox.ResetItemHeight;
begin
  ItemHeight := Max(GetItemHeight(Font), FTrueTypeBmp.Height);
end;

procedure TJvFontComboBox.Click;
begin
  inherited Click;
  Change;
  if FShowMRU and FWasMouse and not DroppedDown then
  begin
    ItemIndex := AddToMRU;
    FWasMouse := False;
  end;
end;

procedure TJvFontComboBox.Reset;
var
  S: string;
begin
  HandleNeeded;
  if HandleAllocated then
  begin
    S := FontName;
    GetFonts;
    if S <> '' then
      FontName := S
    else
      FontName := Font.Name;
  end;
end;

function TJvFontComboBox.GetFontName: string;
begin
  Result := inherited Text;
end;

procedure TJvFontComboBox.SetFontName(const Value: string);
begin
  HandleNeeded;
  if HandleAllocated and (Value <> '') then
  begin
    if Items.Count = 0 then
      GetFonts;
    ItemIndex := Items.IndexOf(Value);
    if ItemIndex = -1 then // try to find the font substitute name
      ItemIndex := Items.IndexOf(FontSubstitute(Value));
    if (ItemIndex = -1) and (foDisableVerify in Options) then // add if allowed to
      ItemIndex := Items.AddObject(Value, TObject(TRUETYPE_FONTTYPE));
  end;
end;

procedure TJvFontComboBox.Loaded;
begin
  inherited Loaded;
  HandleNeeded;
  Reset;
end;

function TJvFontComboBox.GetSorted: Boolean;
begin
  Result := inherited Sorted;
end;

procedure TJvFontComboBox.SetSorted(const Value: Boolean);
var
  S: string;
begin
  if Value <> inherited Sorted then
  begin
    S := FontName;
    if not FShowMRU then
      inherited Sorted := Value
    else
      inherited Sorted := False;
    FontName := S;
  end;
end;

function TJvFontComboBox.FontSubstitute(const AFontName: string): string;
var
  Size: DWORD;
  AKey: HKey;
begin
  Result := AFontName;
  if AFontName = '' then
    Exit;
  if RegOpenKeyEx(HKEY_LOCAL_MACHINE, PChar('SOFTWARE\Microsoft\Windows NT\CurrentVersion\FontSubstitutes'),
    0, KEY_QUERY_VALUE, AKey) = ERROR_SUCCESS then
  try
    if (RegQueryValueEx(AKey, PChar(AFontName),
      nil, nil, nil, @Size) = ERROR_SUCCESS) and (Size > 0) then
    begin
      SetLength(Result, Size);
      if RegQueryValueEx(AKey, PChar(AFontName), nil, nil, PByte(@Result[1]), @Size) = ERROR_SUCCESS then
        Result := string(Result)
      else
        Result := AFontName;
    end;
  finally
    RegCloseKey(AKey);
  end
  else
    Result := AFontName;
end;

function TJvFontComboBox.GetDropDownWidth: Integer;
begin
  Result := SendMessage(Handle, CB_GETDROPPEDWIDTH, 0, 0);
end;

procedure TJvFontComboBox.SetDropDownWidth(const Value: Integer);
begin
  SendMessage(Handle, CB_SETDROPPEDWIDTH, Value, 0);
end;

procedure TJvFontComboBox.SetShowMRU(const Value: Boolean);
begin
  if FShowMRU <> Value then
  begin
    if FShowMRU then
      ClearMRU;
    FShowMRU := Value;
    if FShowMRU and Sorted then
      Sorted := False;
  end;
end;

function TJvFontComboBox.AddToMRU: Integer;
var
  I: Integer;
begin
  Result := ItemIndex;
  if csDesigning in ComponentState then
    Exit;
  if (MaxMRUCount = 0) or (MaxMRUCount > MRUCount) then
  begin
    I := Items.IndexOf(Text);
    if (I > MRUCount - 1) and (I >= 0) then
    begin
      Items.InsertObject(0, Items[I], Items.Objects[I]);
      Inc(FMRUCount);
    end
    else
    if I < 0 then
    begin
      Items.InsertObject(0, Text, TObject(TRUETYPE_FONTTYPE));
      Inc(FMRUCount);
    end;
    Result := 0;
  end
  else
  if (MRUCount > 0) and (ItemIndex > 0) then
  begin
    Items[0] := Items[ItemIndex];
    Items.Objects[0] := Items.Objects[ItemIndex];
    Result := 0;
  end;
end;

procedure TJvFontComboBox.MouseDown(Button: TMouseButton;
  Shift: TShiftState; X, Y: Integer);
begin
  FWasMouse := False;
  inherited MouseDown(Button, Shift, X, Y);
end;

procedure TJvFontComboBox.MouseUp(Button: TMouseButton; Shift: TShiftState;
  X, Y: Integer);
begin
  FWasMouse := True;
  inherited  MouseUp(Button, Shift, X, Y);;
end;

procedure TJvFontComboBox.CloseUp;
begin
  inherited CloseUp;
  if FShowMRU then
  begin
    AddToMRU;
    ItemIndex := Items.IndexOf(Text);
    FWasMouse := False;
  end;
end;

procedure TJvFontComboBox.ClearMRU;
begin
  while FMRUCount > 0 do
  begin
    Items.Delete(0);
    Dec(FMRUCount);
  end;
end;

procedure TJvFontComboBox.KeyDown(var Key: Word; Shift: TShiftState);
begin
  // (rom) only accept without Shift, Alt or Ctrl down
  if (Shift * KeyboardShiftStates = []) and
    (Key = VK_RETURN) and FShowMRU then
    ItemIndex := AddToMRU;
  inherited KeyDown(Key, Shift);
end;

procedure TJvFontComboBox.SetMaxMRUCount(const Value: Integer);
var
  S: string;
begin
  if FMaxMRUCount <> Value then
  begin
    FMaxMRUCount := Value;
    if (FMaxMRUCount > 0) and (FMRUCount > 0) then
    begin
      S := Text;
      while FMRUCount > FMaxMRUCount do
      begin
        Items.Delete(0);
        Dec(FMRUCount);
      end;
      ItemIndex := Items.IndexOf(S);
      if ItemIndex < 0 then
        ItemIndex := 0;
    end;
  end;
end;

procedure TJvFontComboBox.SetParent(AParent: TWinControl);
begin
  inherited SetParent(AParent);
  if Parent <> nil then
  begin
    Reset;
    FontName := Font.Name;
  end;
end;

{$IFDEF UNITVERSIONING}
initialization
  RegisterUnitVersion(HInstance, UnitVersioning);

finalization
  UnregisterUnitVersion(HInstance);
{$ENDIF UNITVERSIONING}

end.