Форум программистов
 

Восстановите пароль или Зарегистрируйтесь на форуме, о проблемах и с заказом рекламы пишите сюда - alarforum@yandex.ru, проверяйте папку спам!

Вернуться   Форум программистов > Delphi программирование > Общие вопросы Delphi
Регистрация

Восстановить пароль
Повторная активизация e-mail

Купить рекламу на форуме - 42 тыс руб за месяц

Ответ
 
Опции темы Поиск в этой теме
Старый 12.04.2014, 13:34   #11
Viburn
 
Регистрация: 05.04.2014
Сообщений: 8
По умолчанию

Спасибо, пользуясь вашими советами дошёл до этого.
Всё нормально компилируеться, чёрная рамка рисуеться, только вот на мышь оно никак не реагирует.

Код:
unit MainWindow;

interface

uses
  Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,
  Dialogs, StdCtrls, ExtCtrls, jpeg;

type
  TImage = class(ExtCtrls.TImage)
    procedure CMMouseEnter(var Message: TMessage); message CM_MOUSEENTER;
    procedure CMMouseLeave(var Message: TMessage); message CM_MOUSELEAVE;
  private
    FBorderColor : TColor;
    FBorderWidth : integer;
    procedure SetBorderColor(Val : TColor);
    procedure SetBorderWidth(Num : integer);
  protected
    procedure Paint; override;
  published
    property BorderColor : TColor read FBorderColor write SetBorderColor default clBlack;
    property BorderWidth : integer read FBorderWidth write SetBorderWidth default 1;
  end;

  TForm1 = class(TForm)
    Image1: TImage;
    Image2: TImage;
    Image3: TImage;
    Image4: TImage;
    Image5: TImage;
    Image6: TImage;
  private
    { Private declarations }
  public
    { Public declarations }
  end;

var
  Form1: TForm1;

implementation

{$R *.dfm}

procedure TImage.SetBorderColor(Val : TColor);
begin
  if Val = FBorderColor then Exit;
  FBorderColor:=Val;
  Invalidate;
end;

procedure TImage.SetBorderWidth(Num : integer);
begin
  if Num = FBorderWidth then Exit;
  FBorderWidth:=Num;
  Invalidate;
end;

procedure TImage.Paint;
begin
  inherited;
  with Canvas do
    begin
    Pen.Color:=BorderColor;
    Pen.Width:=BorderWidth;
    Brush.Style:=bsClear;
    Rectangle(ClientRect);
    end;
end;


procedure TImage.CMMouseEnter(var Message: TMessage);
begin
  BorderWidth:=3;
  BorderColor:=clMenuHighlight;
  inherited;
end;
procedure TImage.CMMouseLeave(var Message: TMessage);
begin
  BorderWidth:=1;
  BorderColor:=clBlack;
  inherited;
end;


end.
Viburn вне форума Ответить с цитированием
Старый 12.04.2014, 14:19   #12
Аватар
Старожил
 
Аватар для Аватар
 
Регистрация: 17.11.2010
Сообщений: 18,922
По умолчанию

Paint убери и с использованием Bitmap
Код:
unit Unit1;

interface

uses
  Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,
  Dialogs, ExtCtrls, StdCtrls;

type

  TImage = class(ExtCtrls.TImage)
    procedure CMMouseEnter(var Message: TMessage); message CM_MOUSEENTER;
    procedure CMMouseLeave(var Message: TMessage); message CM_MOUSELEAVE;
  private
    FBorderColor : TColor;
    FBorderWidth : integer;
    procedure SetBorderColor(Val : TColor);
    procedure SetBorderWidth(Num : integer);
    procedure SetBitmap;
  published
    property BorderColor : TColor read FBorderColor write SetBorderColor default clBlack;
    property BorderWidth : integer read FBorderWidth write SetBorderWidth default 1;
  end;

  TForm1 = class(TForm)
    Image1: TImage;
    Image2: TImage;
    Image3: TImage;
    Image4: TImage;
    Image5: TImage;
    Image6: TImage;
    procedure FormCreate(Sender: TObject);
  private
    { Private declarations }
  public
    { Public declarations }
  end;

var
  Form1: TForm1;

implementation

{$R *.dfm}

procedure TImage.SetBitmap;
var b: TBitMap;
begin
  b:=TBitMap.Create;
  b.Assign(Self.Picture.Bitmap);
  with b.Canvas do begin
    Pen.Color:=BorderColor;
    Pen.Width:=BorderWidth;
    Brush.Style:=bsClear;
    Rectangle(ClientRect);
  end;
  Self.Picture.Bitmap.Assign(b);
  b.Free;
end;

procedure TImage.SetBorderColor(Val : TColor);
begin
  if Val = FBorderColor then Exit;
  FBorderColor:=Val;
  SetBitmap;
end;

procedure TImage.SetBorderWidth(Num : integer);
begin
  if Num = FBorderWidth then Exit;
  FBorderWidth:=Num;
  SetBitmap;
end;

procedure TImage.CMMouseEnter(var Message: TMessage);
begin
  BorderWidth:=3;
  BorderColor:=clMenuHighlight;
  inherited;
end;

procedure TImage.CMMouseLeave(var Message: TMessage);
begin
  BorderWidth:=1;
  BorderColor:=clBlack;
  inherited;
end;

procedure TForm1.FormCreate(Sender: TObject);
var i: Integer;
begin
  for i:=0 to ControlCount-1 do
    if Controls[i] is TImage then begin
      TImage(Controls[i]).Picture.Bitmap.Width:=TImage(Controls[i]).Width;
      TImage(Controls[i]).Picture.Bitmap.Height:=TImage(Controls[i]).Height;
      TImage(Controls[i]).BorderWidth:=1;
      TImage(Controls[i]).BorderColor:=clBlack;
    end;
end;

end.
Если бы архитекторы строили здания так, как программисты пишут программы, то первый залетевший дятел разрушил бы цивилизацию
Аватар вне форума Ответить с цитированием
Старый 12.04.2014, 15:11   #13
Viburn
 
Регистрация: 05.04.2014
Сообщений: 8
По умолчанию

После убирания рамка остаёться и сливается с чёрной рамкой на фоне. А надо бы чтобы оставалась одна чёрная рамка.


Того же результата я добился с этим кодом

Код:
var  TheRect: TRect;
var InImage,Down: Boolean;


procedure TImage.CMMouseEnter(var Message: TMessage);
begin
  InImage:=True;
  if not Down then begin
  TheRect:=Rect(0,0,Width,Height);
  Canvas.Pen.Color:=clMenuHighlight;
  Canvas.Pen.Width:=3;
  Canvas.Brush.Style:=bsClear;
  Canvas.Rectangle(TheRect);
  end;
  inherited;
end;
procedure TImage.CMMouseLeave(var Message: TMessage);
begin
  TheRect:=Rect(0,0,Width, Height);
  Canvas.Pen.Color:= clRed;
  Canvas.Pen.Width:=1;
  Canvas.Brush.Style:=bsClear;
  Canvas.Rectangle(TheRect);
  inherited;
end;

Последний раз редактировалось Viburn; 12.04.2014 в 16:59.
Viburn вне форума Ответить с цитированием
Ответ


Купить рекламу на форуме - 42 тыс руб за месяц



Похожие темы
Тема Автор Раздел Ответов Последнее сообщение
The message resource is present but the message is not found in the string/message table Apokal Win Api 0 19.05.2011 18:06
project raised exception class estringlisterror with message list index out of bounds obsession Общие вопросы Delphi 23 09.05.2011 01:31
EStringListError with message 'List index out of bounds (644)' после удаления дубликатов dzds Помощь студентам 2 25.03.2011 09:39
ошибка raized exception class EListError with message 'List index out of bounds(1)'.Process stopped SGRaptor Софт 0 22.05.2010 19:12
raised exception class EIdSocketError with message' Socket Error # 10022 Invalid argument eldar Работа с сетью в Delphi 16 08.08.2008 23:49