Конференция "KOL" » Плагины для DE. Как лучше реализовать расширяемость?
 
  • Sheleh (07.01.15 18:29) [0]
    В общем разрабатываю Desktop Environment. Пока только панели (без самого рабочего стола и проводника).
    Концепция следующая: в программе жестко не определены панели и внешний вид, программа при запуске считывает их из ini, и создает соответствующие объекты сохраняя указанную зависимость:
    [TaskBar]
    Obj1=0,Form,1,40,Bottom,C7D0D4,,,,255
     Obj2=1,Panel,1,1,Top,DCD2C8 ;верхний бордюр
     Obj3=1,Panel,1,1,Top,FFFFFF   ;второй бордюр

     Obj4=1,Panel,50,1,Left,C7D0D4    ;область слева, например под StartButton
     Obj5=1,Panel,50,1,Right,C7D0D4  ;область справ под Tray и часы
     Obj6=1,Panel,1,20,Client,C7D0D4 ;область под таскбар
       Obj7=6,TaskBar.dll                  ;плагин, реализующий функциональность таскбара

    [HighBar]
    Obj1=0,Form,1,40,Top,C7D0D4,,,,230
    Obj2=1,GPanel,1,1px,Bottom,A87F4C,A87F4C,Vertical,TopLeft
    Obj3=1,GPanel,1,1,Client,DCC1A7,A69283,Vertical,TopLeft


    Т.е. панели могут выглядеть как угодно, имитируя классический стиль([TaskBar]), либо использовать градиенты и прозрачность [HighBar]. Так же подобный подход позволяет создавать многослойные панели.

    На данный момент программа динамически создает указанные в ini визуальные объекты. Затык у меня на этапе разработки концепции dll плагинов, которые должны быть сопоставлены с панелями. Т.е. как написать и подключить dll, что бы она занималась отрисовкой сопоставленных ей областей?

    library TaskBar;

    uses
     Windows,
     //Messages,
     kol;

    const
     HookMsg = 1317;
    var
     CurHook, ServHwnd:HWND;
     instance: Hwnd;

    function CBTHook(CODE, WParam, LParam: DWORD): DWORD; stdcall;
    begin
     Result:=CallNextHookEx(CurHook, CODE, WParam, LParam);
     if (code=1) or (code=4) or (code=5) then
      begin
        if not IsWindow(wParam) then exit;
        if GetParent(wParam)<>0 then exit;
        if GetWindow(wParam, GW_OWNER)<>0 then exit;
        if ((GetWindowLong(wParam,GWL_EXSTYLE) and WS_EX_TOOLWINDOW)<>0) then exit;
        instance:=GetModuleHandle('TaskBar.dll');
        SendMessage(instance, HookMsg, wParam, Code);
         TextOut(GetDC(ServHwnd), 2, 20, PChar(Int2Str(HookMsg)+' '+Int2Str(wParam)+' '+Int2Str(Code)), 20);
      end;
     ServHwnd:=ServHwnd;
    end;

    procedure Start(HandleProg: HWND) export; stdcall;
    Var
     Msg: kol.TMsg;
    begin
     ServHwnd:=HandleProg;
     CurHook:= SetWindowsHookEx(WH_CBT, @CBTHook, HInstance, 0);
     if CurHook <> 0 then
      MessageBox(0, PChar('Hooked !'+Int2Str(ServHwnd)), 'Msg', MB_OK+MB_ICONINFORMATION)
     else
      MessageBox(0, 'Not Hooked!', 'Error', MB_OK+MB_ICONERROR);

     while kol.GetMessage(Msg, HandleProg, 0, 0) do
      begin
         TextOut(GetDC(ServHwnd), 200, 3, PChar(Int2Str(Msg.message)+'/'+Int2Str(Msg.wParam)+'/'+Int2Str(Msg.lParam)), 20);
        //windows.TranslateMessage(Msg);
        //windows.DispatchMessage(Msg);
        sleep(100); // Иначе цикл подвешивает систему
      end;
    end;

    exports
     Start;

    begin

    end.



    Это код dll, которую я гружу и запускаю в отдельном потоке из основной программы. Проблема в том что глобальные переменные не передаются между процедурами.
    Процедуре Start(HandleProg: HWND) я передал handle панели из основной программы, на которой нужно будет рисовать кнопки. Здесь я ставлю хук для отслеживания сообщений создания/закрытия/сворачивания сторонних окон. Чтобы эта процедура не завершилась, я добавил цикл обработки сообщений.

    Но вот как передать информацию о сработавших хуках из функции CBTHook в GetMessage процедуры Start? Вообще как можно в процедуре Start корректно принимать и обрабатывать сообщения?
    Кроме того, объявленная глобальная переменная  ServHwnd:HWND; равна нулю в CBTHook
  • Sheleh (07.01.15 18:34) [1]
    Код основной программы, если интересно
    program WDE;

    uses
      windows, kol ;

     type TOnThreadExecute = function(Sender:PThread): Integer of object;

    var
     Obj: array [0..254] of array [0..254] of PControl;
     Menu, PopUp:PMenu;
     Thread1: PThread;
     Start: procedure (HandleProg: HWND) stdcall;
     ParentObjHandle: THandle;
     DllName: String;
     hDLL: THandle;

    Procedure SetWindowPos(Obj: PControl; caAlign: TControlAlign);
    begin
     if not Obj.IsForm then
      Obj.Align := caAlign
     else
      begin
        Obj.Left:=0; Obj.Top:=0;
        if caAlign=caNone then
         begin
          {Obj.Left:=l;
           Obj.Top:=t;
           Obj.Width:=w;
           Obj.Height:=h;}

         end;
        if caAlign=caBottom then          //В зависимости от типа расположения панели задаем координаты формы
         begin
           Obj.Width:=GetDesktopRect.Right;
           Obj.Top:=GetDesktopRect.Bottom-Obj.Height;
         end;
        if caAlign=caTop then Obj.Width:=GetDesktopRect.Right;
        if caAlign=caRight then
         begin
           Obj.Left:=GetDesktopRect.Right-Obj.Width;
           Obj.Height:=GetDesktopRect.Bottom;
         end;
        if caAlign=caLeft then Obj.Height:=GetDesktopRect.Bottom;
      end;
    end;

    procedure ProcessMenu(P: Pointer; Sender: PMenu; Item:Integer);
    begin
       case Item of
        0: begin
             //Settings.Show;
           end;
        1: Applet.Close;
       end;
    end;

    function Str2TGS(Value: string): TGradientStyle;
    begin
     Result:=gsHorizontal;
     if Value='Vertical' then Result:=gsVertical;
     if Value='Horizontal' then Result:=gsHorizontal;
     if Value='Rectangle' then Result:=gsRectangle;
     if Value='Elliptic' then Result:=gsElliptic;
     if Value='Rombic' then Result:=gsRombic;
     if Value='TopToBottom' then Result:=gsTopToBottom;
     if Value='BottomToTop' then Result:=gsBottomToTop;
    end;

    function Str2TGL(Value: string): TGradientLayout;
    begin
     Result:=glTopLeft;
     if Value='TopLeft' then Result:=glTopLeft;
     if Value='Top' then Result:=glTop;
     if Value='TopRight' then Result:=glTopRight;
     if Value='Left' then Result:=glLeft;
     if Value='Center' then Result:=glCenter;
     if Value='Right' then Result:=glRight;
     if Value='BottomLeft' then Result:=glBottomLeft;
     if Value='Bottom' then Result:=glBottom;
     if Value='BottomRight' then Result:=glBottomRight;
    end;

    function Str2TCA(Value: string): TControlAlign;
    begin
     Result:=caNone;
     if Value='Top' then Result:=caTop;
     if Value='Bottom' then Result:=caBottom;
     if Value='Right' then Result:=caRight;
     if Value='Left' then Result:=caLeft;
     if Value='Client' then Result:=caClient;
    end;

    Function CommaText(Value: string; Index: integer):String;
    var i,j: integer;
       s:string;
    begin
     s:='';
     j:=0;
     Result:='';
     for i:=1 to length(Value) do
      begin
        if Value[i]<>',' then s:=s+Value[i];
        if (Value[i]=',') or (i=length(Value)) then
         begin
           if j=Index then Result:=s;
           j:=j+1;
           s:='';
         end;
      end;
    end;

    function Thread1Execute(dummy:pointer;Sender: PThread): Integer;
    begin
     @Start:=GetProcAddress(Hdll, 'Start');
     Start(ParentObjHandle);
     Result:=0;
    end;

    Procedure LoadSettings();
    var StrList:PStrList;
       i,j:Integer;
       ini:PIniFile;
    Label
       L_end;
    begin
     ini:=OpenIniFile(ChangeFileExt(ParamStr(0),'.ini'));
     strList:= NewStrList;         //
     ini.GetSectionNames(strList); //Запрашиваем список панелей из файла настроек
      for j:=0 to strList.Count - 1 do
       if pos('Bar', strList.Items[j])>0 then //Если секция содержит данные о панели, начинаем цикл ее создания
        begin
          ini.Section:=strList.Items[j];
          i:=1;
          while ini.ValueString('Obj'+int2str(i),'')>'' do
           begin
             if pos('.dll',CommaText(ini.ValueString('Obj'+int2str(i),''),1))>0 then
              begin
                DllName:=CommaText(ini.ValueString('Obj'+int2str(i),''),1);
                hDLL:= LoadLibrary(PChar(DllName));
                ParentObjHandle:=Obj[j,Str2Int(CommaText(ini.ValueString('Obj'+int2str(i),''),0))].Handle;
                Thread1:=NewThreadEx(TOnThreadExecute(MakeMethod(nil,@Thread1Execute)));
                goto L_end;
              end;
             if not assigned(Obj[j,i]) then
              begin
                if CommaText(ini.ValueString('Obj'+int2str(i),''),1)='Form' then
                 begin
                   Obj[j,i]:=NewForm(Applet, 'Form'+Int2Str(i));       //Создаем форму панели
                   Menu:=NewMenu(Obj[j,i], 0, [], nil);
                   PopUp:= NewMenu(Obj[j,i], 0, ['Settings','Close'], TOnMenuItem( MakeMethod(nil, @ProcessMenu )));
                 end;
                if CommaText(ini.ValueString('Obj'+int2str(i),''),1)='Panel' then
                 Obj[j,i]:=NewPanel(Obj[j,Str2Int(CommaText(ini.ValueString('Obj'+int2str(i),''),0))], esNone ); //esNone esRaised esTransparent esLowered
                if CommaText(ini.ValueString('Obj'+int2str(i),''),1)='GPanel' then
                 Obj[j,i]:=NewGradientPanelEx(Obj[j,Str2Int(CommaText(ini.ValueString('Obj'+int2str(i),''),0))],0,0,gsVertical,glTopLeft);
              end;
             Obj[j,i].Border:=0;
             Obj[j,i].HasBorder:=False;
             Obj[j,i].CanResize:=True;
             Obj[j,i].StayOnTop:=True;
             Obj[j,i].Width:=Str2Int(CommaText(ini.ValueString('Obj'+int2str(i),''),2));
             Obj[j,i].Height:=Str2Int(CommaText(ini.ValueString('Obj'+int2str(i),''),3));
             SetWindowPos(Obj[j,i],Str2TCA(CommaText(ini.ValueString('Obj'+int2str(i),''),4)));
             Obj[j,i].Color:=Hex2Int(CommaText(ini.ValueString('Obj'+int2str(i),''),5));
             Obj[j,i].Color1:=Hex2Int(CommaText(ini.ValueString('Obj'+int2str(i),''),5));
             Obj[j,i].Color2:=Hex2Int(CommaText(ini.ValueString('Obj'+int2str(i),''),6));
             Obj[j,i].SetGradientStyle(Str2TGS(CommaText(ini.ValueString('Obj'+int2str(i),''),7)));
             Obj[j,i].SetGradientLayout(Str2TGL(CommaText(ini.ValueString('Obj'+int2str(i),''),8)));
             Obj[j,i].AlphaBlend:=Str2Int(CommaText(ini.ValueString('Obj'+int2str(i),''),9));
             Obj[j,i].SetAutoPopupMenu(PopUp);
             L_end:
           i:=i+1;
          end;
        end;
     ini.Free;
    end;

    begin
     Applet:=NewApplet('WDE');
     LoadSettings();
     Run(Applet);
    end.

  • Sheleh (07.01.15 18:43) [2]
    Вообще GetMessage(Msg, HInstanse, 0, 0) в процедуре Start библиотеки принимает какие-то сообщения, но ни одного сообщения, посланного из CBTHook функцией SendMessage(HInstance, HookMsg, wParam, Code);

    HInstance и там и тут один и тот же handle, что не так?
  • Sheleh (07.01.15 18:57) [3]
    Вру, GetMessage(Msg, HInstanse, 0, 0) в процедуре Start возвращает только одно сообщение:
    Msg.message=0
    Msg.lParam=1
    Msg.wParam=-1296958476
  • Thaddy © (08.01.15 10:39) [4]
    Your problem is you are trying to run GUI elements from a separate thread. That's an absolute NONO. All userinterface elements should run from the same thread, although actual processing may be done in a separate thread.
    Again: everything that needs to be drawn should be done in one and the same thread.
    And from the processing thread you should communicate with the GUI thread by PostThreadMessage.
  • Sheleh (08.01.15 17:01) [5]
    Да я тоже не в восторге от идеи многопоточности. Понимаю, что все это как то криво. Но вот как сделать красиво и универсально? Создавать свои компоненты на базе TControl, и как-то размещать их в dll? Буду пробовать.
  • Thaddy © (08.01.15 18:05) [6]
    Yes, but KOL supports several other possibilities.

    I will describe  here the method I sometimes use.

    It uses a special memorymanager ( http://thaddy.co.uk/commm.pas ) that does about the same as sharemem.

    The only thing you have to do - most of the time - is export the constructing function.
    For example:

    library mybutton;

    uses
     commm,  //important
     kol;

    function UnderlinedButton(AParent:PControl;const Caption:KOLString):PControl;
     begin
       Result := NewButton(AParent, Caption);
       Result.Font.FontStyle := [fsUnderline];
     end;

     exports
     UnderlinedButton;

    begin
    end.



    The project file:


    program ub;
    //save as ub.dpr
    uses
     commm,   //important!
     Kol,
     ub1 in 'ub1.pas';

    begin
     NewForm1( Form1, nil);
     Run(Form1.form);
    end.



    Implementation unit:

    unit ub1;
    //save as ub1.pas
    interface
    uses
     Windows, Messages, Kol;
    const
    cps:KolString = 'Kol project in ' + {$IFDEF FPC}'Freepascal '{$ELSE}'Delphi '{$ENDIF} +
       {$IFDEF WIN64}'64 bits '{$ELSE}'32 bits '{$ENDIF} +
       {$IFDEF UNICODE_CTRLS}'Unicode'{$ELSE}'Ansi'{$ENDIF};
    type

    PForm1=^TForm1;
    TForm1=object(Tobj)
     Form:pControl;
     Ub:PControl;
    public
    end;

    procedure NewForm1( var Result: PForm1; AParent: PControl );
    function NewUnderlinedButton(AParent:PControl;const Caption:KOLString):PControl; external 'mybutton.dll' name 'UnderlinedButton';

    var
     Form1:pForm1;

    implementation

    procedure NewForm1( var Result: PForm1; AParent: PControl );
    begin
     New(Result,Create);
     with Result^ do
     begin
       Form:= NewForm(AParent,cps);
       Applet:=Form;
       Form.Add2AutoFree(Result);
       ub:=NewUnderlinedButton(Form,'Test');
     end;
    end;
    end.

  • Thaddy © (08.01.15 18:22) [7]
    Note commm.pas is delphi only, but I have a version for FPC on request.
  • Thaddy © (08.01.15 18:34) [8]
    Here's a unified commm.pas for both delphi and freepascal:

    unit COMMM;
    (*      system
    purpose: Simple COM based memory manager replacement, tested for Delphi 4-7
     author: © 2004, Thaddy de Koning, mailto:thaddy[@]thaddy.com
     status: Use as you like, freeware, but I retain the copyrights.
             No warranties *what*so*ever*. Only Dutch is law applicable.
             (Since it understands the "WhatSoEver" part a little better than most)

    Remarks: Use this if you write COM based applications and/or don't want to
             use ShareMem.pas with BORLNDMM.DLL.
             Also suitable for KOL and KOL dll'
    s.

             *****************************************************************
             This is very simple code, but with far reaching implications.
             *****************************************************************
             Please read these comments carefully before you use this unit and
             make shure you fully understand what it does.
             *****************************************************************
             
    Features: + All memory is marshalled through COM.
               This means a.o. that COM provides the reference counting across
               modules, so you don't need the ShareMem unit and don't need to
               distribute BORLNDMM.DLL when using long strings, dynamic arrays
               etc in your dll code.
               COM marshalling simply overrides and ignores Delphi's reference
               counting mechanism.
               During extensive tests I encountered no problems.
             - Because of this it may have an effect on highly specialized code
               that hacks - and I mean hacks - into the Delphi reference count
               mechanism itself, but that is very rare and you will know it when
               you do so. Most programmers need not worry about this.
             + It highly simplifies writing COM based applications since you
               can use Delphi memory access functions without having to worry how
               to allocate the memory. Simply put: getmem and coTaskMemAlloc
               are basically the same and New and (Re)Allocmem provide COM memory
               as well. Even strings and dynamic arrays etc are COM based memory,
               since they rely on these low level routines.
             + This unit guarantees that almost all means of allocating memory with
               Delphi can be used transparantly with COM with the exception of the
               VirtualAlloc - page - related low level WIN32 API.
             + Since it is all COM marshalled memory it is fully shareable
               between COM based applications written in other languages like
               VB or C++ and with some thought even with the scripting host.
             + Your existing code is suddenly COM memory compliant! Just recompile.
             + Your existing dll code maybe managed code (.net) compliant since the
               .NET garbage collection feature seems to rely on COM memory -
               management on the lowest level. Some tests done, but not extensive.
             + It has some basic garbage collection capabilities, even under
               WIN 95/98, since COM releases the orphaned memory if it knows for
               shure that the owning processes are unloaded.
               This does NOT mean your application cannot leak while running!
           -/+ It is a little slower than Delphi'
    s default memorymanager, though,
               but the granularity - 16 bytes - is pretty good.
           -/! Read the warning below! Its use has ambiguities you may overlook.
             
        Use: Simply include it as the *first* unit in the uses clause of your
             project file (.dpr).

    ****************************************************************************
    Warning:
             Do not forget to document that you used it! It is very easy to make
             a mistake later and it will probably break your code if you forget
             about it! Most other memory manager replacements do not have this
             ambiguous disadvantage, so be warned and be very very carefull!
             I highly recommend marking every single unit that may depend on it.
             Trust me, it is very comfortable to use but very easy to forget.
             This may be easily overlooked, even if you use a versioning system.
             *******************************************************************

    *)


    interface
    {$DEFINE I_HAVE_READ_THE_WARNING}
    {$IFNDEF I_HAVE_READ_THE_WARNING}
    PLEASE READ THE WARNING!
    {$ENDIF}

    implementation

    uses
     //Both units do not allocate memory, so are safe to use
     Windows,ActiveX;

    {
    Freepascal structure is different from delphi:

    procedure GetMemoryManager(var MemMgr: TMemoryManager);
    procedure SetMemoryManager(const MemMgr: TMemoryManager);

    the TMemoryManager record is defined as follows:
     TMemoryManager = record
       NeedLock    : Boolean;
       Getmem      : Function(Size:PtrInt):Pointer;
       Freemem     : Function(var p:pointer):PtrInt;
       FreememSize : Function(var p:pointer;Size:PtrInt):PtrInt;
       AllocMem    : Function(Size:PtrInt):Pointer;
       ReAllocMem  : Function(var p:pointer;Size:PtrInt):Pointer;
       MemSize     : function(p:pointer):PtrInt;
       InitThread          : procedure;
       DoneThread          : procedure;
       RelocateHeap        : procedure;
       GetHeapStatus       : function :THeapStatus;
       GetFPCHeapStatus    : function :TFPCHeapStatus;
     end;

    }

    {$IFDEF FPC}
    Function ComGetMem(Size:PtrInt):Pointer;
    {$ELSE}
    function ComGetMem(size: Integer): Pointer;
    {$ENDIF}
    begin
     Result := coTaskMemAlloc(size);
     {$IFOPT D+}
     FillChar(Result^,Size,$CC);
     // = int3, so you get a debug breakpoint if you
     // have troubles
     {$ENDIF}
    end;

    {$IFDEF FPC}
    Function ComFreeMem(var p:pointer):PtrInt;
    {$ELSE}
    function ComFreeMem(p: Pointer): Integer;
    {$ENDIF}
    begin
     coTaskMemFree(P);
     Result:= 0;//!!!Magic!!!
    end;

    {$IFDEF FPC}
    Function ComReAllocMem(var p:pointer;Size:PtrInt):Pointer;
    {$ELSE}
    function ComReallocMem(p: Pointer; size: Integer): Pointer;
    {$ENDIF}
    begin
     Result:=CoTaskMemRealloc(p,Size);
    end;

    const
    {$IFDEF FPC}
     ComMemoryManager: TMemoryManager = (
     GetMem: @ComGetMem;
     FreeMem: @ComFreeMem;
     ReallocMem: @ComReallocMem);
    {$ELSE}
     ComMemoryManager: TMemoryManager = (
     GetMem: ComGetMem;
     FreeMem: ComFreeMem;
     ReallocMem: ComReallocMem);
    {$ENDIF}
    var
     OldMM: TMemoryManager;

    initialization
     coInitialize(nil);
     GetMemoryManager( OldMM );
     SetMemoryManager( ComMemoryManager );

    finalization
     SetMemoryManager( OldMM );
     coUninitialize;
    end.
    // Was that all? yes it was!

  • Sheleh (09.01.15 05:56) [9]
    1. Ok, but your construktor of NewCustomObject is placed not in dll code.
    Is it possible to post all code of custom component in a dll to easy plug in new KOLobjects without recompiling the server application?

    2. How it is using commm.pas in your server app? I don't see any direct calls to your memory manager, how it works? Memory is allocated automatically in the needed quantities?
  • Thaddy © (09.01.15 08:32) [10]
    1. It is just an example. Any code can be in the DLL provided you use commm.
    2. ANY memory manager is installed as an opaque, including the default memorymanager. Commm (or the memorymanager in sharemem.dll ) simply provides an easy to use cross dll/exe mechanism, so the memory allocated by the dll and the memory allocated by the executable is under the same control. You do not have to know about the internals, but they are explained in the header. Granularity is 16 bytes, so on a per allocation basis it doesn't waste more than 15, most of which would be lost due to alignment anyway. This is normal behaviour and more or less the same as the default memorymanager. Simply ignore the technical details. It just works.

    There is just ONE rule: if you want to use commm ( or sharemem) you MUST use it in both the dll's AND the executable.

    A memory manager simply allocates, re- allocates and de- allocates memory based on what is needed. Consider it a part of the compiler, NOT part of normal sourcecode is probably a simpler way to describe it. That's why we talk about "installing a memorymanager".
  • Sheleh (09.01.15 09:12) [11]
    Cool! Thanks )
  • Thaddy © (09.01.15 11:57) [12]
    To illustrate, here is a complete KOL control in a dll using commm as the memory manager.

    First the dll:

    library shapes;

    uses
    commm,  //MUST be used in the executable as well. MUST be first unit
    Windows,messages,kol;
    type
     TShapeType =   (stArrowRight, stArrowLeft,
                     stArrowUp, stArrowDown,
                     stEllipse,
                     stLineHorz, stLineVert,
                     stRectangle, stRectangleRound,
                     stTriangleUp, stTriangleDown, stTriangleLeft, stTriangleRight
                     );

     PShapeData=^TShapeData;
     TShapeData = object(TObj)
     private
       FShape: TShapeType;
       procedure Paint(sender:pControl;DC:HDC);
     end;

    //function NewShape(aOwner:PControl;aType:TShapeType;PenColor,BrushColor:TColor):Pcontrol;
    { Creates a Shape control
    Pencolor   = Color1
    BrushColor = Color2
    Possible Shapes: stArrowRight,stArrowLeft,stArrowUp,stArrowDown,stEllipse,
                     stLineHorz,stLineVert,stRectangle,stRectangleRound,stTriangleUp,
                     stTriangleDown,stTriangleLeft,stTriangleRight}


    function NewShape(aOwner:PControl;aType:TShapeType;PenColor,BrushColor:TColor):Pcontrol;
    var
     Data:PShapeData;
    begin
    {Create the Shape data object}
    New(Data,Create);
    {Create the control as a paintbox}
    if not Assigned(Applet) then
      Applet := aOwner;
    Result:=NewPaintBox(aOwner).setsize(50,50);
    with Result^ do
    begin
      {CustomObj's are automatically free'd in the TObject destructor}
      CustomObj:=Data;
      {Set the shape}
      Data.FShape:=aType;
      {Set the paint routine}
      OnPaint:=Data.Paint;
      {Set the colors}
      Color1:=PenColor;
      Color2:=BrushColor;
      {Leave the rest transparent}
      Transparent:=true;
    end;
    end;

    procedure TShapeData.Paint(sender:PControl;DC:HDC);
    var
     PT: Integer;
    begin
     with sender.canvas^ do
     begin
       Pen.Color:=sender.Color1;
       Brush.Color:=sender.Color2;
       PT := Pen.PenWidth div 2;
       case FShape of
         stRectangle: Rectangle(PT,PT, sender.Width-PT, sender.Height-PT);
         stRectangleRound: RoundRect(PT,PT, sender.Width-PT, sender.Height-PT, sender.Width div 4, sender.Height div 4);
         stEllipse: Ellipse(PT, PT, sender.Width-PT, sender.Height-PT);
         stLineHorz:
           begin
             MoveTo(0, sender.Height div 2);
             LineTo(sender.Width-1, sender.Height div 2);
           end;
         stLineVert:
           begin
             MoveTo(sender.Width div 2, 0);
             LineTo(sender.Width div 2, sender.Height-1);
           end;
         stArrowLeft:
           begin
             MoveTo(sender.Width-1, sender.Height div 2);
             LineTo(PT, sender.Height div 2);
             LineTo(sender.Height div 2, sender.Height-1);
             MoveTo(PT, sender.Height div 2);
             LineTo(sender.Height div 2, 0);
           end;
         stArrowRight:
           begin
             MoveTo(0, sender.height div 2);
             LineTo(sender.width-PT, sender.height div 2);
             LineTo(sender.width-1-(sender.height div 2), sender.height-1);
             MoveTo(sender.width-PT, sender.height div 2);
             LineTo(sender.width-1-(sender.height div 2), 0);
           end;
         stArrowUp:
           begin
             MoveTo(sender.width div 2, sender.height-1);
             LineTo(sender.width div 2, PT);
             LineTo(0, sender.width div 2);
             MoveTo(sender.width div 2, PT);
             LineTo(sender.width-1, sender.width div 2);
           end;
         stArrowDown:
           begin
             MoveTo(sender.width div 2, 0);
             LineTo(sender.width div 2, sender.height-PT);
             LineTo(0, sender.height-1-(sender.width div 2));
             MoveTo(sender.width div 2, sender.height-PT);
             LineTo(sender.width-1, sender.height-1-(sender.width div 2));
           end;
         stTriangleUp:
           Polygon([MakePoint(sender.width div 2, 0), MakePoint(sender.width-1, sender.height-1), MakePoint(0, sender.height-1)]);
         stTriangleDown:
           Polygon([MakePoint(0, 0), MakePoint(sender.width-1, 0), MakePoint(sender.width div 2, sender.height-1)]);
         stTriangleLeft:
           Polygon([MakePoint(0, sender.height div 2), MakePoint(sender.width-1, 0), MakePoint(sender.width-1, sender.height-1)]);
         stTriangleRight:
           Polygon([MakePoint(0, 0), MakePoint(sender.width-1, sender.height div 2), MakePoint(0, sender.height-1)]);
       end;
     end;
    end;

    function NewArrowRight(AParent:PControl;PenColor,BrushColor:TColor):PControl;
    begin
     Result := NewShape(AParent,stArrowRight,PenColor,BrushColor);
    end;

    function NewArrowLeft(AParent:PControl;PenColor,BrushColor:TColor):PControl;
    begin
     if not Assigned(Applet) then Applet := AParent.ParentForm;
     Result := NewShape(AParent,stArrowLeft,PenColor,BrushColor);
    end;

    function NewArrowUp(AParent:PControl;PenColor,BrushColor:TColor):PControl;
    begin
     if not Assigned(Applet) then Applet := AParent.ParentForm;
     Result := NewShape(AParent,stArrowUp,PenColor,BrushColor);
    end;

    function NewArrowDown(AParent:PControl;PenColor,BrushColor:TColor):PControl;
    begin
     Result := NewShape(AParent,stArrowDown,PenColor,BrushColor);
    end;

    function NewTriangleUp(AParent:PControl;PenColor,BrushColor:TColor):PControl;
    begin
     Result := NewShape(AParent,stTriangleUp,PenColor,BrushColor);
    end;
    function NewTriangleDown(AParent:PControl;PenColor,BrushColor:TColor):PControl;
    begin
     Result := NewShape(AParent,stTriangleDown,PenColor,BrushColor);
    end;
    // Add more like this if you need it
    //Add more like this if you need it...

    exports
     NewArrowRight,
     NewArrowLeft,
     NewArrowUp,
     NewArrowDown,
     NewTriangleUp,
     NewTriangleDown;

    begin
    end.


  • Thaddy © (09.01.15 11:58) [13]
    The executable project:


    program shapesdemo;
    uses
     commm,  //IMPORTANT
     Kol,
     shapesapp1 in 'shapesapp1.pas';

    begin
     NewForm1( Form1, nil);
     Run(Form1.form);
    end.



    And the main form for the executable:

    unit shapesapp1;

    interface
    uses
     Windows, Messages, Kol;
    const
    cps:KolString = 'KOL control in a dll using commm';
    type

    PForm1=^TForm1;
    TForm1=object(Tobj)
     Form:pControl;
     ShapeL,
     ShapeR,
     ShapeU,
     ShapeD,
     TriangleU,
     TriangleD:PControl;
    public
    end;

    procedure NewForm1( var Result: PForm1; AParent: PControl );
    function NewArrowRight(AParent:PControl;Pen,Brush:TColor):PControl; external 'shapes.dll' name 'NewArrowRight';
    function NewArrowLeft(AParent:PControl;Pen,Brush:TColor):PControl; external 'shapes.dll' name 'NewArrowLeft';
    function NewArrowUp(AParent:PControl;Pen,Brush:TColor):PControl; external 'shapes.dll' name 'NewArrowUp';
    function NewArrowDown(AParent:PControl;Pen,Brush:TColor):PControl; external 'shapes.dll' name 'NewArrowDown';
    function NewTriangleUp(AParent:PControl;Pen,Brush:TColor):PControl; external 'shapes.dll' name 'NewTriangleUp';
    function NewTriangleDown(AParent:PControl;Pen,Brush:TColor):PControl; external 'shapes.dll' name 'NewTriangleDown';

    var
     Form1:pForm1;

    implementation

    procedure NewForm1( var Result: PForm1; AParent: PControl );
    begin
     New(Result,Create);
     with Result^ do
     begin
       Form:= NewForm(AParent,cps);
       Applet:=Form;
       Form.Add2AutoFree(Result);
       Form.Color := clGreen;
       ShapeL:=NewArrowLeft(Form, clBlue, clWhite).PlaceDown;
       ShapeL.Canvas.Pen.PenWidth := 4;
       ShapeR:=NewArrowRight(Form,clwhite,clRed).PlaceRight;
       ShapeU:=NewArrowUp(Form,clBlack,clYellow).PlaceDown;
       ShapeD:=NewArrowDown(Form,clRed,clBlack).PlaceRight;
       TriangleU:=NewTriangleUp(Form,clYellow,clBlack).placedown;
       TriangleD:=NewTriangleDown(Form,clBlack,clRed).placedown;

     end;
    end;
    end.

  • Thaddy © (09.01.15 12:00) [14]
    As you can see, because the memory is shared, you can create a completely new KOL control and use it from a dll. You MUST use commm.
    But the same principle goes for what you are trying to achieve.
  • Thaddy © (09.01.15 12:16) [15]
    You can use any method that is in TControl.
    In other words, the interface for the dll control is the same as that of Tcontrol.
    That's why you can also attach events of TOnEvent, like OnClick etc.

    A beautiful example of the design principle behind KOL ;)
  • Thaddy © (09.01.15 12:29) [16]
    You also asked:
    "Is it possible to post all code of custom component in a dll to easy plug in new KOLobjects without recompiling the server application?"

    The answer is YES, BUT. provided you stick to only methods from TControl.
    In that case, the design should be such that you only use methods of TControl.
    Otherwise you need to rely on RTTI (which we KOL users hate by design!) or wrote a KOL com object (which is technically the same).

    I suggest you can also use COM scripting.
    An example on how to do that is here:
    http://thaddy.co.uk/kolaxscript.zip

    That doesn't use the msscript control but is directly build on top of the scripting engine. The KOL code will run at full speed and only the interfacing is done through script.
  • Sheleh (09.01.15 22:00) [17]
    Too many chars. Stack of my mind is overflowed. I need a time.. Thanks for help Thaddy, Now I'm gonna go build my own DE + theme-pack, with blackjack and hook-libs!
  • Sheleh (11.01.15 19:28) [18]
    She's Alive! I did it.
    Конечно я еще не написал полноценного компонента, но как я и хотел, весь код содержится в одной dll, подключается одной единственной универсальной функцией и уже выводит иконки запущенных приложений.
    Library TaskBar;

    uses commm,
        Windows,
        Messages,
        KOL,
        ShellApi;

    type
     TApp = record
       Icon16, Icon32: THandle;
       wnd:HWND;
       Owner:HWND;
       Parent:HWND;
       Visible:boolean;
       lParam: LPARAM;
       Caption: String;
       ExeName: String;
       ExePath: String;
       index: integer;
       IsFgnd, IsIconic, IsMaximized:boolean;
    end;

    type
     PTaskBar = ^TTaskBar;
     TTaskBar = object(TControl)
     private
       procedure PaintTaskBar( Sender: PControl; DC: HDC );
       procedure MouseDown(pt: TPoint);
    end;

    type
     PTaskBarData = ^TTaskBarData;
     TTaskBarData = object(TObj)
     private
       fStates: PTaskBarData;
       Apps: array [0..1000] of Tapp;
       WndAllCnt, WndCount: integer;
       hDLL: THandle;
    end;

    function GetModuleFileNameExW(hProcess:THandle; hModule:HMODULE; lpFilename:PWideChar; nSize:DWORD):DWORD; stdcall; external 'PSAPI.DLL';

    var CurHook: Hwnd;

    {$R *.res}

    function WindowGetEXE(wnd:HWND):string;
    var wt:array[0..MAX_PATH-1] of WChar;
       r:integer;
       prc:THandle;
       prcID:cardinal;
    begin
     result:='';
     if GetWindowThreadProcessID(wnd,prcID)<>0 then
     begin
       prc:=OpenProcess(PROCESS_ALL_ACCESS,false,prcID);
       if prc<>0 then
        try
          r:=GetModuleFileNameExW(prc,0,wt,MAX_PATH*2);
          if r<>0 then result:=wt;
        finally
          CloseHandle(prc)
        end
     end
    end;

    //function ExtractAssociatedIcon(HINSTANCE: Hwnd; LPTSTR: Pchar; lpiIcon: Pointer):Hwnd; stdcall; external 'Shell32.dll';

    function WindowGetIcon(wnd:HWND; fSmall:boolean;ExeName: PChar):Cardinal;
    var
    defIcon:HICON;
    r,iType1,iType2: integer;
    IconIndex : word;
    TestIcon: PIcon;
    begin
       IconIndex:=0;
       TestIcon:=NewIcon;
       TestIcon.Handle:=ExtractAssociatedIcon(hInstance, ExeName, IconIndex);
       if TestIcon.Empty then
         defIcon:=LoadIcon(0,IDI_APPLICATION) else defIcon:=TestIcon.Handle;

       if fSmall then
        begin iType1:=ICON_SMALL; iType2:= GCL_HICONSM; end else
        begin iType1:=ICON_BIG; iType2:= GCL_HICON; end;

      r:=SendMessageTimeOut(wnd,WM_GETICON,iType1,0,SMTO_ABORTIFHUNG or 8, 100, result);
      if (r=0) then result:=defIcon else
      begin
       if (result=0) then  result:=GetClassLong(wnd,iType2);
       if (result=1) then  result:=defIcon
      end;
    end;

    function GetWindowState(Wnd:HWnd):integer;
    var WPlacement : PWINDOWPLACEMENT;
    begin
     GetMem(WPlacement,SizeOf(TWINDOWPLACEMENT));
     WPlacement^.Length:=SizeOf(TWINDOWPLACEMENT);
     if GetWindowPlacement(Wnd,WPlacement) then Result:=WPlacement^.showCmd else Result:=-1;
     FreeMem(WPlacement);
    end;

    function GetWndInfo(wnd:HWND):Tapp;
    var wn: array[0..MAX_PATH-1] of char;
    begin
     GetWindowText(wnd,wn,MAX_PATH);
     Result.wnd:=wnd;
     Result.Caption:=wn;
     Result.ExeName:=ExtractFileName(WindowGetEXE(wnd));
     Result.ExePath:=ExtractFilePath(WindowGetEXE(wnd));
     Result.IsFgnd:=False; if wnd=GetForegroundWindow() then Result.IsFgnd:=True;
     Result.IsIconic:=IsIconic(wnd);//GetWindowState(wnd);
     //Result.index:=WndCount;
     Result.Icon16:=WindowGetIcon(wnd,True,PChar(WindowGetEXE(wnd)));
     Result.Icon32:=WindowGetIcon(wnd,false,PChar(WindowGetEXE(wnd)));
    end;

    function FindChildWindow(Parent:integer; Text:string):integer;
    var
     hChildWnd, hWnd: integer;
     s:array[0..MAX_PATH-1] of char;
    begin
     Result:=0;
     hWnd:=FindWindowEx(Parent,0,nil,nil);
     if hWnd=0 then Exit;
     repeat
       GetWindowText(hWnd,s,MAX_PATH);
       if Text=s then
        begin
          Result:=hWnd;
          Break;
        end;
       hChildWnd:=FindChildWindow(hWnd, Text);
       if hChildWnd<>0 then
        begin
          Result:=hChildWnd;
          Break;
        end;
       hWnd:=FindWindowEx(Parent,hWnd,nil,nil);
     until hWnd=0;
    end;

    function EnumWindowsProc(wnd:HWND; lParam: LPARAM):BOOL; stdcall;
    begin
    result:=true;
    if (IsWindowVisible(wnd)) and (GetParent(wnd)=0) and  (GetWindow(wnd,GW_OWNER)=0) and
    ((GetWindowLong(wnd,GWL_EXSTYLE) and WS_EX_TOOLWINDOW)=0) then
       SendMessage(FindChildWindow(0, 'FR43DW-GDR51I'),1343,wnd,0);
    end;

    function CBTHook(CODE, WParam, LParam: DWORD): DWORD; stdcall;
    begin
     Result:=CallNextHookEx(CurHook, CODE, WParam, LParam);
     if (code=1) or (code=4) or (code=5) then
      begin
        if not IsWindow(wParam) then exit;
        if GetParent(wParam)<>0 then exit;
        if GetWindow(wParam, GW_OWNER)<>0 then exit;
        if ((GetWindowLong(wParam,GWL_EXSTYLE) and WS_EX_TOOLWINDOW)<>0) then exit;
        SendMessage(FindChildWindow(0, 'FR43DW-GDR51I'),1343,wParam,code);
      end;
    end;

    function TaskBarWndProc(Sender: PControl; var Msg: TMsg; var Rslt: Integer ): Boolean;
    var wnd: HWND;
         i: integer;
         newwnd: boolean;
    begin
     Result := False;
     case Msg.message of
       WM_SIZE:
         Sender.Invalidate;
       WM_LBUTTONDOWN:
         begin
           PTaskBar(Sender).MouseDown(SmallPointToPoint(TSmallPoint(Msg.LParam)));
           GetWindowLong(wnd, HInstance);
           EnumWindows(@EnumWindowsProc,0);
         end;
       1343:
         begin
           i:=0;
           newwnd:=True;
           while PTaskBarData(Sender.CustomObj).Apps[i].wnd>0 do
            begin
              if PTaskBarData(Sender.CustomObj).Apps[i].wnd=Msg.wParam then
               begin
                 PTaskBarData(Sender.CustomObj).Apps[i]:=GetWndInfo(Msg.wParam);
                 newwnd:=False;
               end;
              i:=i+1;
            end;
           if (WindowGetEXE(Msg.wParam)<>ParamStr(0)) and newwnd then PTaskBarData(Sender.CustomObj).Apps[i]:=GetWndInfo(Msg.wParam);
           Sender.Invalidate;
         end;
     end;
    end;

    function NewObject(AParent: PControl): PTaskBar;
    var
     data: PTaskBarData;
    begin
     Result := PTaskBar(NewPanel(AParent, esLowered));
     Result.Align:=caClient;
     Result.Caption:='FR43DW-GDR51I';
     Result.AttachProc(@TaskBarWndProc);
     Result.OnPaint := Result.PaintTaskBar;
     Result.Transparent:=True;
     New(data, Create);
     Result.CustomObj := data;
     
     CurHook:= SetWindowsHookEx(WH_CBT, @CBTHook, HInstance, 0);
     if CurHook <> 0 then
      MessageBox(0, PChar('Hooked !'), 'Msg', MB_OK+MB_ICONINFORMATION)
     else
      MessageBox(0, 'Not Hooked!', 'Error', MB_OK+MB_ICONERROR);

     EnumWindows(@EnumWindowsProc,0);
    end;

    { TTaskBarData }

    procedure TTaskBar.MouseDown(pt: TPoint);
    var
     x, y: integer;
    begin
     //x := pt.x div (ClientWidth div PTaskBarData(CustomObj).fXCells);
    end;

    procedure TTaskBar.PaintTaskBar(Sender: PControl; DC: HDC );
    var
     i: integer;
    begin
     i:=0;
     while PTaskBarData(Sender.CustomObj).Apps[i].wnd>0 do
      begin
        DrawIcon(DC, i*60+15, 2, PTaskBarData(Sender.CustomObj).Apps[i].Icon32);
        i:=i+1;
      end;
    end;

    exports
    NewObject;

    begin
    end.
  • RusSun © (13.02.15 22:08) [19]
    2Thaddy Thank you very much for your example. According 's publications easy to do.

    2Sheleh. Можно принскин расположения панелей прислать на мыло, а то не получается завершить пример. Спасибо.
 
Конференция "KOL" » Плагины для DE. Как лучше реализовать расширяемость?
Есть новые Нет новых   [118456   +51][b:0][p:0.016]