| Новости | Поиск | FAQ | Статьи | Книги | Новости VCL | | Форумы ЧАТ | Орешник | KOL и MCK |
Форумы -» Основная («Начинающим»)/ Базы / WinAPI / Компоненты / Сети / Media / Игры / Corba и COM / KOL / FreePascal / .Net / Прочее / RSDN.ORG

	« предыдущая ветвь | форум | следующая ветвь »

Вывод текста в собственном компоненте [D7, WinXP]

Страницы:   < 1 2 3 >

Max_005 ©   (2005-04-18 12:43:00) 

Пишу компонент. Приведу часть его кода:

type
TMyComp = class(TGraphicControl)
private
  function GetCanvas: TCanvas;
  ...
protected
  procedure Paint; override;
  ...
public
  constructor Create(AOwner: TComponent); override;
  destructor Destroy; override;
  property Canvas: TCanvas read GetCanvas;
  ...


function TMSSkinUltraMenu.DestRect: TRect;
var
w, h, cw, ch: Integer;
xyaspect: Double;
begin
if FShowPictute = shwPictureUp then
  begin
  w := PictureUp.Width;
  h := PictureUp.Height;
  end;
if FShowPictute = shwPictureMove then
  begin
  w := PictureMove.Width;
  h := PictureMove.Height;
  end;
cw := ClientWidth;
ch := ClientHeight;
if Stretch or (Proportional and ((w > cw) or (h > ch))) then
begin
if Proportional and (w > 0) and (h > 0) then
begin
    xyaspect := w / h;
    if w > h then
    begin
      w := cw;
      h := Trunc(cw / xyaspect);
      if h > ch then  // woops, too big
      begin
        h := ch;
        w := Trunc(ch * xyaspect);
      end;
    end
    else
    begin
      h := ch;
      w := Trunc(ch * xyaspect);
      if w > cw then  // woops, too big
      begin
        w := cw;
        h := Trunc(cw / xyaspect);
      end;
    end;
  end
  else
  begin
    w := cw;
    h := ch;
  end;
end;

with Result do
begin
  Left := 0;
  Top := 0;
  Right := w;
  Bottom := h;
end;

if Center then
OffsetRect(Result, (cw - w) div 2, (ch - h) div 2);
end;

procedure TMyComp.Paint;
var
Save: Boolean;
begin
if csDesigning in ComponentState then
with inherited Canvas do
begin
Pen.Style := psDash;
Brush.Style := bsClear;
Rectangle(0, 0, Width, Height);
end;
Save := FDrawing;
FDrawing := True;
try
with inherited Canvas do
  begin
  if FShowPictute = shwPictureUp then
    begin
    StretchDraw(DestRect, PictureUp.Graphic);
    end;
  if FShowPictute = shwPictureMove then
    begin
    StretchDraw(DestRect, PictureMove.Graphic);
    end;
  end;

finally
FDrawing := Save;
end;
end;

function TMyComp.GetCanvas: TCanvas;
var
Bitmap: TBitmap;
begin
if FShowPictute = shwPictureUp then
  begin
    if PictureUp.Graphic = nil then
      begin
     Bitmap := TBitmap.Create;
       try
       Bitmap.Width := Width;
       Bitmap.Height := Height;
       PictureUp.Graphic := Bitmap;
       finally
       Bitmap.Free;
       end;
      end;
    if PictureUp.Graphic is TBitmap then
     Result := TBitmap(PictureUp.Graphic).Canvas
    else
     raise EInvalidOperation.Create(SImageCanvasNeedsBitmap);
  end;

if FShowPictute = shwPictureMove then
  begin
    if PictureMove.Graphic = nil then
      begin
     Bitmap := TBitmap.Create;
       try
       Bitmap.Width := Width;
       Bitmap.Height := Height;
       PictureMove.Graphic := Bitmap;
       finally
       Bitmap.Free;
       end;
      end;
    if PictureMove.Graphic is TBitmap then
     Result := TBitmap(PictureMove.Graphic).Canvas
    else
     raise EInvalidOperation.Create(SImageCanvasNeedsBitmap);
  end;
end;

Но у меня есть одна небольшая загвоздка... Как мне вывести текст в этом компоненте? И чтобы сам текст, цвет, шрифт текста задавались в свойствах? Помогите пожалуйста. Я в процедуре Paintнаписал:

Canvas.Font:=Font;
 Canvas.TextOut(Round((Width-Canvas.TextWidth(Caption))/2), Round((Height-Canvas.TextHeight(Caption))/2), Caption);

Но фон текста белый и перекрывает все... а еще он не по середине...

---

Max_005   (2005-05-20 21:08:00) [21]

Юрий ЗотовТ.е. для того чтобы свойства TextImage1 и TextImage2 нормально показывались? или какие свойства?

---

Юрий Зотов   (2005-05-20 17:35:00) [22]

> Max_005   (20.05.05 16:58) [27]

1. ParentFont - стандартное свойство контролов. Его описание есть в справке.

2. Это редактор свойства и его регистрация. В данном случае он не обязателен, я включил его лишь для того, чтобы в Инспекторе Объектов получить стандартное отображение значения свойства, являющегося ссылкой на внутренний компонент и сделать это свойство read-only.

---

Max_005   (2005-05-20 16:58:00) [23]

Подниму старую тему... См. Юрий Зотов (19.04.05 01:23) [20]
Все понятно кроме двух вещей:
1. Для чего свойство ParentFontв TYzTextImage.
2. И про Юнит DT-пакета. Мы тут регистрируем сой компонент, а зачем нужен еще какой-то тип?

type
TInternalSubComponentProperty = class(TComponentProperty)
  function GetAttributes: TPropertyAttributes; override;
  function GetValue: string; override;
end;

и еще мне не очень понятна эта строка:

RegisterPropertyEditor(TYzTextImage.ClassInfo, TYzDoubleTextImage, '', TInternalSubComponentProperty)

по ходу какие-то свойства регистрирует... зачем?

---

Юрий Зотов   (2005-04-19 14:48:00) [24]

> такое ощущение что открывшийся popup перехватывает все
> сообщения...

Ну, все - не все, а сообщения ввода (мыши и клавиатуры) - точно перехватывает. А иначе как бы меню работало?

Вопрос - как программно закрыть TPopupMenu при уходе указателя мыши с компонента, на котором оно было открыто. Это - в основную или в WinAPI (скорее, в WinAPI). Предполагаю, что для этого потребуется мышиный хук.

---

Max_005   (2005-04-19 14:21:00) [25]

Юрий Зотов а разве не надо в коде компонента писать это? чтобы меню раскрывалось на другом компоненте при наведении на него мышкой? Я тут попробовал сделать на сообщение "CM_MOUSEENTER", чтобы как курсор окажется на другом таком же компоненте то меню откроется... Но этого не происходит...:( такое ощущение что открывшийся popup перехватывает все сообщения... Вообще может все это можно сделать с MainMenu? Вобщем у меня окно программы нестандартного вида... поэтому у формы нет заголовка... А в этой форме нужно сделать меню. Я посмотрел множество примеров на http://www.delphiworld.narod.ruтам есть хорошие примеры по переделыванию MainMenu, но проблема в том что у меня сами пункты меню не в ряд расположены... а по верхней границе формы, а там форма округлая... Вот я и подумал такой компонент сделать... Такое необычное меню... Поискал готовые компоненты такие, тоже не нашел... Нашел только одно, но из-за него сама Delphi глючить стала... и уже откомпилилированная программа с таким меню тоже глючит... Попробовал посмотреть ее исходняки, но я там ВООБЩЕ ничего не понял...:( Может вы знаете какойнибудь такой компонент? или подскажете как сделать переключающееся это меею?

---

Юрий Зотов   (2005-04-19 13:54:00) [26]

Этот вопрос уже в "основную", к разработке компонентов он не относится.

---

Max_005   (2005-04-19 12:48:00) [27]

Не.. вы не так немного поняли. Если на форме два и больше будет таких коипонентов, то при наведении курсора на 2-й и т.д. чтобы уже на этих открывалось меню, если вообще меню было открыто хоть на какомнибудь таком коипоненте... Грубый пример как MainMenu, откроешь меню, и при наведении на другие пункты меню, там "Файл", "Редактировать", и т.д. оно само расскрывается...

---

Юрий Зотов   (2005-04-19 07:23:00) [28]

1. Если раскрывшееся меню тут же надо закрывать и вместо него показывать другое, то зачем его вообще открывать? Надо сразу показать другое.

2. Что за странный интерфейс? Что бы Вы сказали о конструкторе машины, если бы Вы сели в нее, тронулись с места, а она вдруг поехала бы не вперед, а вбок? Вот то же самое пользователи скажут и о таком интерфейсе.

---

Max_005   (2005-04-19 02:39:00) [29]

Юрий Зотов огромнейшее тебе СПАСИБО!!! только теперь у меня еще одна проблема появилась... Можно ли сделать вот как: при расскрывшемся меню на этом компоненте закрывать это меню и расскрывать другое меню на другом таком же компоненте при наведении на него курсора

---

Юрий Зотов   (2005-04-19 01:23:00) [30]

> Max_005

Вот обещанный код (рассчитан на D7, но с небольшими переделками сможет работать в любой версии Delphi). Он делает все, что было оговорено в [18], но законченным компонентом я бы его все же не назвал - это скорее именно скелет, потому что у него маловато возможностей (только то, что было оговорено в [18]). Если Вы изучите это пример досконально и с книжкой Фаронова в руках, то, во-первых, поймете, как он работает, а, во-вторых, сумеете нарастить на него "мясо" самостоятельно.

Нужно сделать 2 пакета (run-time и design-time), в каждом по одному юниту. RT-пакет компилируются в любой каталог, доступный через Path. В секцию requires DT-пакета добавьте ссылку на RT-пакет.

============== Юнит RT-пакета ==============

unit MyComp;

interface

uses
 Windows, Messages, SysUtils, Classes, Graphics, Controls;

type
 TYzTextImage = class(TGraphicControl)
 private
   FPicture: TPicture;
   procedure SetPicture(const Value: TPicture);
   procedure PictureChanged(Sender: TObject);
   procedure CMFontChanged(var Message: TMessage); message CM_FONTCHANGED;
   procedure CMTextChanged(var Message: TMessage); message CM_TEXTCHANGED;
 protected
   procedure Paint; override;
 public
   constructor Create(AOwner: TComponent); override;
   destructor Destroy; override;
 published
   property Font;
   property ParentFont;
   property Picture: TPicture read FPicture write SetPicture;
   property Text;
 end;

 TYzDoubleTextImage = class(TCustomControl)
 private
   FTextImage1: TYzTextImage;
   FTextImage2: TYzTextImage;
   procedure SetTextImage1(const Value: TYzTextImage);
   procedure SetTextImage2(const Value: TYzTextImage);
   procedure CMMouseEnter(var Message: TMessage); message CM_MOUSEENTER;
   procedure CMMouseLeave(var Message: TMessage); message CM_MOUSELEAVE;
 protected
   procedure Paint; override;
 public
   constructor Create(AOwner: TComponent); override;
   destructor Destroy; override;
 published
   property PopupMenu;
   property TextImage1: TYzTextImage read FTextImage1 write SetTextImage1;
   property TextImage2: TYzTextImage read FTextImage2 write SetTextImage2;
 end;

implementation

{ TYzTextImage }

procedure TYzTextImage.CMFontChanged(var Message: TMessage);
begin
 inherited;
 Invalidate
end;

procedure TYzTextImage.CMTextChanged(var Message: TMessage);
begin
 inherited;
 Invalidate
end;

constructor TYzTextImage.Create(AOwner: TComponent);
begin
 inherited;
 FPicture := TPicture.Create;
 FPicture.OnChange := PictureChanged;
end;

destructor TYzTextImage.Destroy;
begin
 FPicture.Free;
 inherited
end;

procedure TYzTextImage.Paint;
const
 Flags = DT_CENTER or DT_WORDBREAK;
var
 R: TRect;
begin
 with Canvas do
 begin
   Brush.Style := bsClear;
   if csDesigning in ComponentState then
  begin
    Pen.Style := psDash;
     Rectangle(0, 0, Width, Height)
  end;
   R := ClientRect;
   if FPicture.Graphic <> nil then
     StretchDraw(R, FPicture.Graphic)
   else
     FillRect(R);
   if Text <> '' then
   begin
     Font.Assign(Self.Font);
     DrawText(Handle, PChar(Text), Length(Text), R, Flags or DT_CALCRECT);
     OffsetRect(R, (Width - R.Right + R.Left) div 2, (Height - R.Bottom + R.Top) div 2);
     DrawText(Handle, PChar(Text), Length(Text), R, Flags)
   end
 end
end;

procedure TYzTextImage.PictureChanged(Sender: TObject);
begin
 Invalidate
end;

procedure TYzTextImage.SetPicture(const Value: TPicture);
begin
 FPicture.Assign(Value)
end;

{ TYzDoubleTextImage }

procedure TYzDoubleTextImage.CMMouseEnter(var Message: TMessage);
begin
 FTextImage1.Visible := True;
 FTextImage2.Visible := False;
 inherited
end;

procedure TYzDoubleTextImage.CMMouseLeave(var Message: TMessage);
begin
 FTextImage1.Visible := False;
 FTextImage2.Visible := True;
 inherited
end;

constructor TYzDoubleTextImage.Create(AOwner: TComponent);

 function CreateTextImage: TYzTextImage;
 begin
   Result := TYzTextImage.Create(Self);
   with Result do
   begin
     Parent := Self;
     Align := alClient;
     SetSubComponent(True)
   end
 end;

begin
 inherited;
 FTextImage1 := CreateTextImage;
 FTextImage1.Visible := False;
 FTextImage2 := CreateTextImage
end;

destructor TYzDoubleTextImage.Destroy;
begin
 FTextImage2.Free;
 FTextImage1.Free;
 inherited
end;

procedure TYzDoubleTextImage.Paint;
begin
 with Canvas do
 begin
   Brush.Style := bsClear;
   if csDesigning in ComponentState then
  begin
    Pen.Style := psDash;
     Rectangle(0, 0, Width, Height)
  end;
 end
end;

procedure TYzDoubleTextImage.SetTextImage1(const Value: TYzTextImage);
begin
 FTextImage1.Assign(Value)
end;

procedure TYzDoubleTextImage.SetTextImage2(const Value: TYzTextImage);
begin
 FTextImage2.Assign(Value)
end;

end.

============== Юнит DT-пакета ==============

unit MyCompReg;

interface

uses
 Classes, MyComp, DesignIntf, DesignEditors;

type
 TInternalSubComponentProperty = class(TComponentProperty)
   function GetAttributes: TPropertyAttributes; override;
   function GetValue: string; override;
 end;

procedure Register;

implementation

procedure Register;
begin
 RegisterComponents('Yz Examples', [TYzTextImage, TYzDoubleTextImage]);
 RegisterPropertyEditor(TYzTextImage.ClassInfo, TYzDoubleTextImage, '', TInternalSubComponentProperty)
end;

{ TInternalSubComponentProperty }

function TInternalSubComponentProperty.GetAttributes: TPropertyAttributes;
begin
 Result := inherited GetAttributes - [paMultiSelect, paValueList, paSortList, paRevertable] + [paReadOnly]
end;

function TInternalSubComponentProperty.GetValue: string;
begin
 Result := '(' + GetComponentReference.ClassName + ')'
end;

end.


---

Max_005   (2005-04-18 21:36:00) [31]

Юрий Зотов пришли тогда на xkiller@pisem.net
А я сейчас еще в Библио-Глобус(книжный) съездил, купил Фаронова по разработке компонентов... Только что приехал. Я и ее почитаю еще :)

---

Юрий Зотов   (2005-04-18 20:26:00) [32]

> Max_005   (18.04.05 19:55) [16]

> давай я тебе пришлю весь свой код компанента?

Не стоит. Свой я напишу за час, а на разбор и переделку чужого кода могут потребоваться сутки.

> там наверняка 2-3 строчки подписать чтобы было все
> нормально...

Не уверен. Компоненты имеют свою специфику, поэтому если нет опыта написания компонентов, то запросто может оказаться, что он изначально неверно спроектирован и его проще переписать с нуля, чем переделывать. Такое - не редкость, даже когда компонент написан сильным программистом, но просто не имеющим опыта написания именно компонентов.

Давайте уж лучше уясним задачу.

Итак - компонент хранит 2 картинки. Когда курсор находится над компонентом, то показывается одна, когда за его пределами - вторая. Поверх каждой картинки рисуется свой текст и он показывается вместе с самой картинкой, на ее фоне. Компонент имеет свойство "popup-меню" и это меню должно выскакивать при щелчке по компоненту правой кнопкой мыши.

Все так, или что-то я понял неверно?

---

Max_005   (2005-04-18 20:04:00) [33]

но забыл сказать самое главное... текст чтобы был поверх этих картинок всегда... я сначала сделал чтобы этот текст был нарисован на изображении... но теперь переделываю чтобы программно писался... вот и мучаюсь... не знаю как это сделать...:(

---

Max_005   (2005-04-18 19:55:00) [34]

Юрий Зотов, давай я тебе пришлю весь свой код компанента? там наверняка 2-3 строчки подписать чтобы было все нормально... А компонент у меня вот что делать должен: за основу взят Image(сам его код), но он переделан. добавил по аналогии еще одно свойство для изображения. Мне нужно чтобы при наведении курсора то которое изображение сейчас показывается изменилось на второе... а при нажатии по компоненту правой кнопкой расскрывался popup. Этот popup проставляется в свойстве ActiveMenu. но это наверно лучше увидить код...

---

Юрий Зотов   (2005-04-18 19:40:00) [35]

> Max_005

Объяснять придется слишком много, на эту тему аж книжки написаны. Если хотите научиться писать компоненты, то стоит одну из них купить (Фаронова, или Веселова с Головановым). А для примера могу попробовать набросать скелет (работающий) Вашего компонента - но для этого надо знать, что он должен делать.

---

Max_005   (2005-04-18 18:46:00) [36]

почему все это не работает? я наверно всем надоел тут... Я на самом деле компоненты никогда не писал... я новичек в этом деле... да и программировать недавно начал только... А этот компонент мне позарез как нужен... Может поможет ктонибудь или хотябы объяснит... Почему я когда задаю Canvas.Brush.Style:=bsClear; то шрифты которые задаются так:

published
property Font: TFont read GetFont write SetFont;
...
function TMSSkinUltraMenu.GetFont: TFont;
begin
Result := Canvas.Font
end;

procedure TMSSkinUltraMenu.SetFont(const Value: TFont);
begin
Canvas.Font.Assign(Value)
end;

не работают...:(

---

Max_005   (2005-04-18 18:19:00) [37]

Я сделал вот как:

procedure TMSSkinUltraMenu.Paint;
var
 Save: Boolean;
begin
if csDesigning in ComponentState then
with inherited Canvas do
 begin
 Pen.Style := psDash;
 Brush.Style := bsClear;
 Rectangle(0, 0, Width, Height);
 end;
Save := FDrawing;
FDrawing := True;
 try
 with inherited Canvas do
   begin
   if FShowPictute = shwPictureUp then
     begin
     StretchDraw(DestRect, PictureUp.Graphic);
     end;
   if FShowPictute = shwPictureMove then
     begin
     StretchDraw(DestRect, PictureMove.Graphic);
     end;
   end;

 Canvas.Brush.Style:=bsClear;
 Canvas.TextOut((Width-Canvas.TextWidth(Text)) div 2, (Height-Canvas.TextHeight(Text)) div 2, Text);

 finally
 FDrawing := Save;
 end;
end;

Прозрачность появилась... только теперь почему то не работают шрифты...:( а еще при наведении курсора на компонент у меня идет перерисовка, функция "Refresh" так вот при наведении курсора у меня текст почемуто еще рисуется вверху, слева... а как курсор вне зоны компонента идет тоже перерисовка... и надпись вторая(которая слева, сверху) исчезает... что это такое? текст то должен нигде не рисоваться...

---

Max_005   (2005-04-18 17:49:00) [38]

Я сейчас откапал в интернете функцию SetBkMode может ей лучше воспользоваться?

---

Юрий Зотов   (2005-04-18 17:24:00) [39]

А если True, то этот кусок кода просто НЕ исполняется. То есть, фон НЕ закрашивается, а текст рисуется прямо по существующему фону, каким бы он ни был. Только и всего.

---

jack128   (2005-04-18 17:23:00) [40]

Вот тут выводится текст метки.
Max_005   (18.04.05 16:55) [8]
DoDrawText(Rect, DrawStyle);
Смотри как устроена эта функция..

---

Страницы:   < 1 2 3 >

Наверх