Новая компонента в Lazarus'е

Вопросы программирования и использования среды Lazarus.

Модератор: Модераторы

Новая компонента в Lazarus'е

Сообщение bestonix » 30.12.2010 17:16:48

Здравствуйте уважаемые.

Всех с наступающим новым годом !

Есть вопрос по созданию компоненты в Лазаре. Я попробовал перенести компоненту написанную на Delphi.
Скомпилировалось нормально, без ошибок, но при попытке установить в палитру вылетает сообщение:
Can't find unit ComponentTreeView used by ObjectInspector. Хотя вроде нигде не нашел ссылки на этот модуль.
Может подскажет кто в чем проблема ?
Код своей компоненты прилагаю

Код: Выделить всё
unit ComboBox1;

{$mode objfpc}{$H+}

interface

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

const
  symbTrunc : char = '~';
  symbColor : char = '`';

type

  { TComboBox1 }

  TComboBox1 = class(TComboBox)
  private
    FColouring: boolean;
    { Private declarations }
    FTruncate : boolean;
    procedure SetTrunc(Value: boolean);
    procedure FCustomDraw(Control: TWinControl; Index: integer; Rect: TRect; State: TOwnerDrawState);
  protected
    { Protected declarations }
  public
    { Public declarations }
    function   GetID(ItemNum: Integer): String;
    function   GetValue(ItemNum: Integer): String;
    function   GetColor(ItemNum: Integer): String;
    procedure  SetID(ItemNum: Integer; AID: String);
    procedure  SetValue(ItemNum: Integer; AValue: String);
    procedure  SetColor(ItemNum: Integer; AColor: String);
    function   SelectItem(ItemNum: Integer): boolean;
    function   SelectByID(ID: string): boolean;
  published
    { Published declarations }
    property Truncate: boolean read FTruncate write SetTrunc default false;
    property Colouring: boolean read FColouring write FColouring default false;
  end;

procedure Register;

implementation

function  TComboBox1.SelectByID(ID: string): boolean;
var i: integer;
begin
  Result:=false;
  for i:=0 to Items.Count-1 do
    if GetID(i) = ID then
      begin
        Result:=true;
        ItemIndex:=i;
      end;
end;

function  TComboBox1.SelectItem(ItemNum: Integer): boolean;
begin
  Result:=(SendMessage(Self.Handle,CB_SETCURSEL,ItemNum,0)>-1)
end;

procedure TComboBox1.SetTrunc(Value: boolean);
begin
  if Value then begin
    OnDrawItem:=@FCustomDraw;
    Style:=csOwnerDrawFixed;
  end else begin
    OnDrawItem:=nil;
    Style:=csDropDownList;
  end;
  FTruncate:=Value;
end;

procedure TComboBox1.FCustomDraw(Control: TWinControl;
          Index: Integer; Rect: TRect; State: TOwnerDrawState);
var
  s: string;
  i: integer;
begin
  if (FColouring) then begin
    s:=GetColor(Index);
    try
      i:=StrToInt(s);
    except
      on E: EConvertError do
         i:=clWindowText;
    end;

    if (Index<>ItemIndex) then
      Canvas.Font.Color:=i
    else Canvas.Font.Color:=clHighLightText;
  end;

  Canvas.TextRect(Rect, Rect.Left, Rect.Top, GetValue(Index));
end;

function   TComboBox1.GetID(ItemNum: Integer): String;
var
  p:integer;
begin
  Result:='NULL';
  if (ItemNum<0) or (ItemNum>=Items.Count) then Exit;
  p:=Pos(symbTrunc,Items[ItemNum]);
  if p>1 then
    Result:=Copy(Items[ItemNum],1,p-1);
end;

function   TComboBox1.GetValue(ItemNum: Integer): String;
var
  p, l   : integer;
  s      : string;
begin
  if (ItemNum<0) or (ItemNum>=Items.Count) then begin
    Result:='';
    Exit;
  end;

  p:=Pos(symbTrunc,Items[ItemNum]);
  s:=Items[ItemNum];

  if p>0 then begin
    l:=Length(s);
    s:=Copy(s,p+1,l);
  end;

  p:=Pos(symbColor,s);
  if p>0 then
    s:=Copy(s,1,p-1);

  Result:=s;
end;

function   TComboBox1.GetColor(ItemNum: Integer): String;
var
  p, l   : integer;
  s: string;
begin
  Result:='';
  if (ItemNum<0) or (ItemNum>=Items.Count) then Exit;
  s:=Items[ItemNum];
  p:=Pos(symbColor,s);
  l:=Length(s);
  if (p>0) and (p<>l) then
    Result:=Copy(Items[ItemNum],p+1,l-p);
end;

procedure  TComboBox1.SetID(ItemNum: Integer; AID: String);
var
  p,l    :integer;
  s      :string;
begin
  if (ItemNum<0) or (ItemNum>=Items.Count) then exit;
  s:=Items[ItemNum];
  p:=Pos(symbTrunc,s);
  l:=Length(s);
  if p>0 then s:=Copy(s,p+1,l-p);
  if AID='' then Items[ItemNum]:=s
  else Items[ItemNum]:=AID+symbTrunc+s;
end;

procedure  TComboBox1.SetValue(ItemNum: Integer; AValue: String);
var
  p, l   : integer;
  s,s1,s2: string;
begin
  if (ItemNum<0) or (ItemNum>=Items.Count) then exit;
  s:=Items[ItemNum];
  l:=Length(s);
  p:=Pos(symbTrunc,s);
  s1:='';
  if p>1 then
    s1:=Copy(s,1,p-1)+'~';

  p:=Pos(symbColor,s); s2:='';
  if (p>0) and (p<l) then
    s2:='`'+Copy(s,p+1,l-p);

  Items[ItemNum]:=s1+AValue+s2;
end;

procedure  TComboBox1.SetColor(ItemNum: Integer; AColor: String);
var
  p:  integer;
  s:  string;
begin
  if (ItemNum<0) or (ItemNum>=Items.Count) then exit;
  s:=Items[ItemNum];
  p:=Pos(symbColor,s);
  if p>0 then s:=Copy(s,1,p-1);
  if AColor<>'' then s:=s+symbColor+AColor;
  Items[ItemNum]:=s;
end;

procedure Register;
begin
  RegisterComponents('Onix',[TComboBox1]);
end;

end. 
bestonix
новенький
 
Сообщения: 66
Зарегистрирован: 15.04.2010 08:26:00
Откуда: Жигулёвск

Re: Новая компонента в Lazarus'е

Сообщение Maxizar » 30.12.2010 18:15:57

Я делал по мативам вот этого: Создание визуальных компонент для Lazarus Но можно и в ручную :), хотя шаблон лушче доверить сгенерировать Lazarus-у
А на вскидку.. должно быть 3 файла:
1. - Файл модуля, где описан класс компонента.
2. - Модуль регистрации.
3. - Файл lpk, с описанием компонента..
Возможно из-за этого. У меня такой ошибки не было :!:

На примере можно посмотреть мой компонент кнопки, на основе Image
Компонент TAnimateTrayIcon, сейчас возможно не заработает из за конфликта.. в последних версиях Lazarus-a сделали почти то же самое...
Maxizar
постоялец
 
Сообщения: 385
Зарегистрирован: 20.03.2010 19:48:14

Re: Новая компонента в Lazarus'е

Сообщение bestonix » 06.01.2011 22:56:18

Доброго времени суток.

Переделал вобчем все заново. Скомпилировалось и встало в палитру нормально, НО.
Допустим строки выглядят след. образом:
1~строка №1
2~строка №2
3~строка №5
и т.д.

При установке свойства Truncate=true не видно перемещения мышкой по строкам списка,
но при этом не видно и текста прописанного до тильды (этот эффект как раз и ожидается).
Если свойство Truncate=false, то перемещение мышкой видны, но текст до тильды виден.
Смысл компоненты в том, чтоб скрыть от пользователя дополнительную информацию, например ID строки.
Подскажите где закралась ошибка.
bestonix
новенький
 
Сообщения: 66
Зарегистрирован: 15.04.2010 08:26:00
Откуда: Жигулёвск

Re: Новая компонента в Lazarus'е

Сообщение Odyssey » 07.01.2011 11:50:27

Ошибка, скорее всего, в собственной отрисовке, т.е. где-то в "procedure FCustomDraw". Судя по проверке (Index<>ItemIndex), подсветка текущего элемента там происходит с помощью Canvas.Font.Color, т.е. цвета шрифта. Возможно, при вашей теме оформления разница между clWindowText и clHighLightText не заметна на глаз.
bestonix писал(а):Смысл компоненты в том, чтоб скрыть от пользователя дополнительную информацию, например ID строки.
Если честно, то использовать для этого компонент, включающий скрытую информацию в текст Item'а, и скрывающий её при отрисовке -- не очень. Потому что внешний вид компонента будет отличаться от системного, либо придётся подгонять процедуру отрисовки так, чтобы не было отличий от системной отрисовки, а это довольно сложно сделать кроссплатформенно. Я бы для таких целей использовал свойство Item.Data: Pointer. Оно есть у всех элементов списков, и в него можно поместить указатель на строку или экземпляр класса, и уже в эту строку/экземпляр класса записывать ту информацию, которая не должна отображаться. Единственное, что работать с указателями на строки в этом случае придётся через PChar/StrNew/StrDispose.
Odyssey
энтузиаст
 
Сообщения: 580
Зарегистрирован: 29.11.2007 17:32:24

Re: Новая компонента в Lazarus'е

Сообщение bestonix » 07.01.2011 18:11:57

Odyssey писал(а):Если честно, то использовать для этого компонент, включающий скрытую информацию в текст Item'а, и скрывающий её при отрисовке -- не очень. Потому что внешний вид компонента будет отличаться от системного, либо придётся подгонять процедуру отрисовки так, чтобы не было отличий от системной отрисовки, а это довольно сложно сделать кроссплатформенно. Я бы для таких целей использовал свойство Item.Data: Pointer. Оно есть у всех элементов списков, и в него можно поместить указатель на строку или экземпляр класса, и уже в эту строку/экземпляр класса записывать ту информацию, которая не должна отображаться. Единственное, что работать с указателями на строки в этом случае придётся через PChar/StrNew/StrDispose.


Безусловно через Item.Data работать универсально. Но по моему мнению создавать объект для хранения всего одного значения это неоправданная трата ресурсов. По большей части всегда достаточно иметь ID+строка из БД. И иметь ее практически под рукой и без лишних трат думается более разумным.
Как бы там ни было, за подсказку спасибо. Подумаю и еще раз попробую

PS. Всех с праздником, с рождеством !!!
bestonix
новенький
 
Сообщения: 66
Зарегистрирован: 15.04.2010 08:26:00
Откуда: Жигулёвск

Re: Новая компонента в Lazarus'е

Сообщение dunin » 08.01.2011 17:37:35

bestonix писал(а):...создавать объект для хранения всего одного значения это неоправданная трата ресурсов. По большей части всегда достаточно иметь ID+строка из БД. И иметь ее практически под рукой и без лишних трат думается более разумным.
...

Диман, ты Голова. :)
Кстати, в последнем Лазаре есть пункт меню "преобразовать компонент Дельфи в Лазарус". Попробуй...
Аватара пользователя
dunin
энтузиаст
 
Сообщения: 634
Зарегистрирован: 02.05.2007 13:18:11
Откуда: Тољя††и

Re: Новая компонента в Lazarus'е

Сообщение VirtUX » 16.12.2011 19:09:18

Собственно сабж. Пытаюсь установить свои компоненты и получаю ошибку, что не найден componenttreeview. При компиляции не ругается.
Исходник:
Код: Выделить всё
unit UDPComp;

{$mode objfpc}{$H+}

interface

uses
  Classes, SysUtils, blcksock
  {$IFDEF WINDOWS}
    ,synsock
  {$ENDIF}
  {$IFDEF UNIX}
    ,sslinux
  {$ENDIF}
  ;

type

  TOnMessageReceivedEvent = procedure (Host, Port, Mess: string; const Error: boolean) of object;
  TOnAnswerReceivedEvent = procedure (Mess: string; const Error: boolean) of object;

  { TUdpServerReader }

  TUdpServerReader = class(TThread)
  private
    s, mHost, mPort: string;
    Error: boolean;
  protected
    UdpSocket: TUDPBlockSocket;
    procedure Execute; override;
    procedure SyncMess;
  public
    Host: string;
    Port: string;
    Started: boolean;
    Terminator: string;
    TimeOut: integer;
    OnMessageReceived: TOnMessageReceivedEvent;
    constructor Create(CreateSuspended: Boolean; const StackSize: SizeUInt=DefaultStackSize);
  end;

  { TUDPServer }

  TUDPServer = class(TComponent)
  private
    Reader: TUdpServerReader;
  private
    function GetEnabled: boolean;
    function GetHost: string;
    function GetOnMessageReceived: TOnMessageReceivedEvent;
    function GetPort: string;
    function GetTerminator: string;
    function GetTimeOut: integer;
    procedure SetEnabled(const AValue: boolean);
    procedure SetHost(const AValue: string);
    procedure SetOnMessageReceived(const AValue: TOnMessageReceivedEvent);
    procedure SetPort(const AValue: string);
    procedure SetTerminator(const AValue: string);
    procedure SetTimeOut(const AValue: integer);
    { Private declarations }
  protected
    { Protected declarations }
  public
    { Public declarations }
    property Enabled: boolean read GetEnabled write SetEnabled;
    procedure SendMessage(Host, Port, Mess: string);
    constructor Create(AOwner: TComponent); override;
    destructor  Destroy; override;
  published
    { Published declarations }
    property Host: string read GetHost write SetHost;
    property Port: string read GetPort write SetPort;
    property Terminator: string read GetTerminator write SetTerminator;
    property TimeOut: integer read GetTimeOut write SetTimeOut;
    property OnMessageReceived: TOnMessageReceivedEvent read GetOnMessageReceived write SetOnMessageReceived;
  end;

  { TUdpClientReader }

  TUdpClientReader = class(TThread)
  private
    s: string;
    Error: boolean;
    procedure SyncMess;
  protected
    UdpSocket: TUDPBlockSocket;
    procedure Execute; override;
  public
    Host: string;
    Port: string;
    Started: boolean;
    Terminator: string;
    TimeOut: integer;
    OnAnswerReceived: TOnAnswerReceivedEvent;
    constructor Create(CreateSuspended: Boolean; const StackSize: SizeUInt=DefaultStackSize);
  end;

  TUDPClient = class(TComponent)
  private
    Reader: TUdpClientReader;
  private
    function GetEnabled: boolean;
    function GetOnAnswerReceived: TOnAnswerReceivedEvent;
    function GetServerHost: string;
    function GetServerPort: string;
    function GetTerminator: string;
    function GetTimeOut: integer;
    procedure SetEnabled(const AValue: boolean);
    procedure SetOnAnswerReceived(const AValue: TOnAnswerReceivedEvent);
    procedure SetServerHost(const AValue: string);
    procedure SetServerPort(const AValue: string);
    procedure SetTerminator(const AValue: string);
    procedure SetTimeOut(const AValue: integer);
  public
    property Enabled: boolean read GetEnabled write SetEnabled;
    procedure SendMessage(Mess: string);
    constructor Create(AOwner: TComponent); override;
    destructor Destroy; override;
  published
    property OnAnswerReceived: TOnAnswerReceivedEvent read GetOnAnswerReceived write SetOnAnswerReceived;
    property ServerHost: string read GetServerHost write SetServerHost;
    property ServerPort: string read GetServerPort write SetServerPort;
    property Terminator: string read GetTerminator write SetTerminator;
    property TimeOut: integer read GetTimeOut write SetTimeOut;
  end;

procedure Register;

implementation

procedure Register;
begin
  RegisterComponents('Standard',[TUDPServer, TUDPClient]);
end;

function TUDPClient.GetEnabled: boolean;
begin
  Result := Reader.Started;
end;

function TUDPClient.GetOnAnswerReceived: TOnAnswerReceivedEvent;
begin
  Result := Reader.OnAnswerReceived;
end;

function TUDPClient.GetServerHost: string;
begin
  Result := Reader.Host;
end;

function TUDPClient.GetServerPort: string;
begin
  Result := Reader.Port;
end;

function TUDPClient.GetTerminator: string;
begin
  Result := Reader.Terminator;
end;

function TUDPClient.GetTimeOut: integer;
begin
  Result := Reader.TimeOut div 1000;
end;

procedure TUDPClient.SetEnabled(const AValue: boolean);
begin
  if Reader.Started = AValue then exit;

  if AValue then Reader.Resume
  else Reader.Terminate;
end;

procedure TUDPClient.SetOnAnswerReceived(const AValue: TOnAnswerReceivedEvent);
begin
  if AValue = Reader.OnAnswerReceived then exit;

  Reader.OnAnswerReceived := AValue;
end;

procedure TUDPClient.SetServerHost(const AValue: string);
begin
  if AValue = Reader.Host then exit;

  Reader.Host := AValue;
end;

procedure TUDPClient.SetServerPort(const AValue: string);
begin
  if AValue = Reader.Port then exit;

  Reader.Port := AValue;
end;

procedure TUDPClient.SetTerminator(const AValue: string);
begin
  if AValue = Reader.Terminator then exit;

  Reader.Terminator := AValue;
end;

procedure TUDPClient.SetTimeOut(const AValue: integer);
var
  v: integer;
begin
  v := AValue * 1000;
  if v = Reader.TimeOut then exit;

  Reader.TimeOut := v;
end;

procedure TUDPClient.SendMessage(Mess: string);
begin
  Reader.UdpSocket.SendString(Mess + Terminator);
end;

constructor TUDPClient.Create(AOwner: TComponent);
begin
  inherited Create(AOwner);

  Reader := TUdpClientReader.Create(true);
end;

destructor TUDPClient.Destroy;
begin
  Reader.Free;

  inherited Destroy;
end;

{ TUdpClientReader }

procedure TUdpClientReader.SyncMess;
begin
  if Assigned(OnAnswerReceived) then OnAnswerReceived(s, Error);
end;

procedure TUdpClientReader.Execute;
begin

  UdpSocket:=TUDPBlockSocket.Create();

  try
    { Соединимся с хостом }
    UdpSocket.Connect(Host, Port);
    { Если были найдены ошибки }
    if UdpSocket.LastError <> 0 then Exit;
    { Тело потока }
    while not Terminated do begin
      { Возщьмем некоторые данные }
      Error := false;
      s := UdpSocket.RecvTerminated(TimeOut, Terminator);
      { Если нет ошибок то обработаем ответ }
      if UdpSocket.LastError = 0 then Synchronize(@SyncMess)
      { мначе обработаем ошибку }
      else begin
           { Если нет ответа }
           if UdpSocket.LastError=WSAETIMEDOUT then s:=''
           { иначе покажем ошибку }
           else begin

                Error := true;
                s := IntToStr(UdpSocket.LastError)+' : '+UdpSocket.LastErrorDesc;
                Synchronize(@SyncMess);

                end;
           end;

      Sleep(1);

    end;

  UdpSocket.CloseSocket();

  finally

         FreeAndNil(UdpSocket);

  end;

end;

constructor TUdpClientReader.Create(CreateSuspended: Boolean;
  const StackSize: SizeUInt);
begin
  inherited Create(CreateSuspended, StackSize);

  FreeOnTerminate := true;

  OnAnswerReceived := nil;
  TimeOut :=          10000;
  Host :=             'localhost';
  Port :=             '4444';
  Terminator :=       #1;
  Error :=            false;
  Started :=          false;
end;

{ TUdpServerReader }

procedure TUdpServerReader.Execute;
begin

  Started := true;
  UdpSocket:=TUDPBlockSocket.Create;

  try
    UdpSocket.Bind(Host, Port);
    if UdpSocket.LastError<>0 then Exit;
    while not Terminated do begin

          Error := false;
          s := UdpSocket.RecvTerminated(TimeOut, Terminator);

          if UdpSocket.LastError=0 then begin

             mHost := UdpSocket.GetRemoteSinIP;
             mPort := IntToStr(UdpSocket.GetRemoteSinPort);

             Synchronize(@SyncMess);

             end
          else begin
               if UdpSocket.LastError = WSAETIMEDOUT then s := ''
               else begin
                    Error := true;
                    s := IntToStr(UdpSocket.LastError)+' : '+UdpSocket.LastErrorDesc;
                    Synchronize(@SyncMess);
               end;
          end;

          Sleep(1);

          end;

    UdpSocket.CloseSocket;

  finally

         FreeAndNil(UdpSocket);

  end;

  Started := false;

end;

procedure TUdpServerReader.SyncMess;
begin
  if Assigned(OnMessageReceived) then OnMessageReceived(mHost, mPort, s, Error);
end;

constructor TUdpServerReader.Create(CreateSuspended: Boolean;
  const StackSize: SizeUInt);
begin
  inherited Create(CreateSuspended, StackSize);

  FreeOnTerminate := true;

  OnMessageReceived := nil;
  TimeOut :=           10000;
  Host :=              '0.0.0.0';
  Port :=              '4444';
  Terminator :=        #1;
  Error :=             false;
  Started :=           false;
end;

{ TUDPServer }

function TUDPServer.GetEnabled: boolean;
begin
  Result := Reader.Started;
end;

function TUDPServer.GetHost: string;
begin
  Result := Reader.Host;
end;

function TUDPServer.GetOnMessageReceived: TOnMessageReceivedEvent;
begin
  Result := Reader.OnMessageReceived;
end;

function TUDPServer.GetPort: string;
begin
  Result := Reader.Port;
end;

function TUDPServer.GetTerminator: string;
begin
  Result := Reader.Terminator;
end;

function TUDPServer.GetTimeOut: integer;
begin
  Result := Reader.TimeOut div 1000;
end;

procedure TUDPServer.SetEnabled(const AValue: boolean);
begin

  if AValue = Reader.Started then exit;

  if AValue then Reader.Resume
  else Reader.Terminate;

end;

procedure TUDPServer.SetHost(const AValue: string);
begin
  if Reader.Host = AValue then exit;

  Reader.Host := AValue;
end;

procedure TUDPServer.SetOnMessageReceived(const AValue: TOnMessageReceivedEvent);
begin
  if Reader.OnMessageReceived = AValue then exit;

  Reader.OnMessageReceived := AValue;
end;

procedure TUDPServer.SetPort(const AValue: string);
begin
  if Reader.Port = AValue then exit;

  Reader.Port := AValue;
end;

procedure TUDPServer.SetTerminator(const AValue: string);
begin
  if Reader.Terminator = AValue then exit;

  Reader.Terminator := AValue;
end;

procedure TUDPServer.SetTimeOut(const AValue: integer);
var
  v: integer;
begin
  v := AValue * 1000;
  if Reader.TimeOut = v then exit;

  Reader.TimeOut := v;
end;

procedure TUDPServer.SendMessage(Host, Port, Mess: string);
begin

  Reader.UdpSocket.SetRemoteSin(Host, Port);
  Reader.UdpSocket.SendString(Mess + Terminator);

end;

constructor TUDPServer.Create(AOwner: TComponent);
begin
  inherited Create(AOwner);

  Reader := TUdpServerReader.Create(true);

end;

destructor TUDPServer.Destroy;
begin
  Reader.Free;

  inherited Destroy;
end;

end.


В зависимостях прописаны LCL и FCL.
Аватара пользователя
VirtUX
энтузиаст
 
Сообщения: 880
Зарегистрирован: 05.02.2008 10:52:19
Откуда: Крым, Алушта

Re: Новая компонента в Lazarus'е

Сообщение VirtUX » 18.12.2011 14:07:21

Добавлю инфу:
Lazarus 0.9.30.2
Windows 7 sp1 32-bit

Добавлено спустя 37 минут 39 секунд:
Проблема решена. Нужно было просто пересобрать Лазарь с полной очисткой.
Аватара пользователя
VirtUX
энтузиаст
 
Сообщения: 880
Зарегистрирован: 05.02.2008 10:52:19
Откуда: Крым, Алушта


Вернуться в Lazarus

Кто сейчас на конференции

Сейчас этот форум просматривают: нет зарегистрированных пользователей и гости: 242

Рейтинг@Mail.ru