(*
/*

CLASS {AL4_tray|_Delphi_KOL}, NATIVE, UNTESTED :

IMPORT: {Control}, {Icon} .

NATIVE: @
        "uses AL4_form, Windows, AL4_tray;" .
        
NATIVE: "///COPY AL4_tray.pas" .
*/
*)
unit AL4_tray;
{$I EXTERNAL_DEFINES.inc}
{$I KOLDEF.inc}
//defines

interface

uses {$IFDEF KOL} KOL 
     {$ELSE} Classes, Forms, Controls, Menus,
             StdCtrls, ExtCtrls, ComCtrls, Dialogs
     {$ENDIF},
// use AL4 to access system functions (AL4.pas inserted by the compiler into
// a project folder)
     AL4,
// use AL4_form to access PAL4Column
	 AL4_form,
// use AL4_drawing to access PBitmapEx
	 AL4_drawing,
// to access NoneObj_C_Control
	 UnitC_Control,
// use All_classes from a project folder (generated for a certain project)
     All_classes, Windows, Messages;

//{$WARN UNIT_DEPRECATED OFF}
//{$WARN SYMBOL_PLATFORM OFF}
//{$WARN UNSAFE_TYPE OFF}
//{$WARN UNSAFE_CAST OFF}
//{$WARN UNSAFE_CODE OFF}

type
// class to store tray icon component
    PTrayPanel = ^TTrayPanel;
    TTrayPanel = object(TControl)
        TrayObject: PTrayIcon;
        IconObject: PIcon;
        Active: Boolean;
        Form: PAL4Form;
        constructor CreateTrayPanel(xParent: PControl);
        destructor Destroy; virtual; //override;
        procedure Form_tray_icon_mouse(Sender: PObj; Msg: Word);
        procedure Form_tray_icon_destroy(Sender: PObj);
    end;

function Do_create_tray_icon(P: Integer; X_T: Pointer; X_Icon: Ref_obj): Integer;
procedure Do_replace_tray_icon(X_Handle: Integer; X_Icon: Ref_obj);

function NewTrayPanel(ParentForm: PControl): PTrayPanel;

implementation

{ TTrayPanel }

constructor TTrayPanel.CreateTrayPanel(xParent: PControl);
begin
    inherited CreateParented(xParent);
end;

destructor TTrayPanel.Destroy;
begin
  Free_And_Nil(TrayObject);
  //if IconObject <> nil then IconObject.RefDec;
  //Free_And_Nil(IconObject);
  inherited;
end;

function NewTrayPanel(ParentForm: PControl): PTrayPanel;
begin 
    new(Result, CreateTrayPanel(ParentForm));
end;


//------------------------------------------------------------ T R A Y
(*
/*
// Create tray icon component.
//----------------------------------------------------------------------------
FUN Create_tray_icon(
    {Control} T|ray_icon_object, 
    {Icon} Icon|_handle) ==> INT
    :
    RESULT = do_create_tray_icon(T.Form_.Handle, T, Icon) .

FUN do_create_tray_icon( INT F|orm_handle,
    {Control} T|ray_icon_create, {Icon} Ico|n_handle) ==> INT, NATIVE :
@   "   RESULT := Do_Create_tray_icon(X_F, X_T, X_Ico);" 
    "   Do_replace_tray_icon(RESULT, X_Ico);" .
*/
*)
function Do_Create_tray_icon(P: Integer; X_T: Pointer; X_Icon: Ref_obj): Integer;
var Parent: PAL4Column;
    TP: PTrayPanel;
    F: PAL4Form;
begin
    F := PAL4Form(P);
    Parent := PAL4Column(F.Get_current_column_handle);
    TP := NewTrayPanel(Parent.Panel);
	TP.Form := F;
    TP.Visible := FALSE;
    TP.Width := 0;
    TP.Height := 0;
    TP.TrayObject := NewTrayIcon(F.Form, 0);
    TP.TrayObject.Active := FALSE;
    TP.TrayObject.Tag := Integer(X_T);
    TP.TrayObject.OnMouse := TP.Form_tray_icon_mouse;
    TP.TrayObject.OnDestroy := TP.Form_tray_icon_destroy;
    TP.Tag := Integer(X_T);
    PObj(X_T).Tag := DWORD(TP);
    
    
    Result := Integer(TP);
end;

(*
/*
// Create tray icon component.
//----------------------------------------------------------------------------
FUN Set_tray_icon_active( INT Handle|_tray_icon_object, 
    BOOL Active|_value ), NATIVE :
   @"var TP: PTrayPanel;"
    "    TP := PTrayPanel(X_Handle);"
    "	 if X_Handle = 0 then Exit;"
    "    TP.Active := X_Active;"
    "    if TP.TrayObject <> nil then"
    "       TP.TrayObject.Active := X_Active;" .
    
// Set tray icon text.
//----------------------------------------------------------------------------        
FUN Set_tray_icon_text( INT Handle|_tray_icon_object, 
    STR S|how_text ), NATIVE :
   @"var TP: PTrayPanel;"
    "    TP := PTrayPanel(X_Handle);"
    "    TP.TrayObject.Tooltip := X_S;" .
    
// Destroy try icon object.
//----------------------------------------------------------------------------
FUN Destroy_tray_icon( INT Handle|_tray_icon_object), NATIVE :
   @"var TP: PTrayPanel;"
    "    TP := PTrayPanel(X_Handle);"
    "    TP.TrayObject.Active := false;"
    "    Free_And_Nil(TP.TrayObject);" .
    
// Destroy icon.
//----------------------------------------------------------------------------
FUN Destroy_icon( INT Handle|_icon), NATIVE :
   @"     //if X_Handle > 0 then DestroyIcon(X_Handle);" .
    
// Load icon from file.
//----------------------------------------------------------------------------
FUN Load_icon_from_file( STR Path|_to_file_containing_icon ) ==> INT,
    NATIVE :
   @"    {$IFNDEF NOEXCEPTIONS}"
    "    try"
    "    {$ENDIF}"
    "       Result := LoadImage(0, PChar(X_Path), IMAGE_ICON, 0, 0,"
    "       LR_LOADFROMFILE);"
    "    {$IFNDEF NOEXCEPTIONS}"
    "    except on E: Exception do begin"
    "           Any_exception(E);"
    "           Result := 0;"
    "           end;"
    "    end;"
    "    {$ENDIF}" .
    

// Replace tray icon by another icon object
//----------------------------------------------------------------------
FUN Replace_tray_icon( INT Handle|_tray_icon_object,
    {Icon} Value|_icon_to_set ), NATIVE :
@   "   Do_replace_tray_icon(X_Handle, X_Value);" .
*/
*)
var empty_icon: HIcon;

procedure Do_replace_tray_icon(X_Handle: Integer; X_Icon: Ref_obj);
var TP: PTrayPanel;
    ico: C_Icon;
    b: PBitmapEx;
    i: PIcon;
    bmp, mask: KOL.PBitmap;
    ii: TIconInfo;
begin
    TP := PTrayPanel(X_Handle);
    ico := C_Icon(X_Icon.Obj);
    b := PBitmapEx(ico.F_Handle);
    if b <> nil then begin 
                     i := b.Ico;
                     //i.RefInc;
                     end
    else i := nil;
    //if TP.IconObject <> nil then TP.IconObject.RefDec;
    if i <> nil then 
    begin
        TP.IconObject := i;
        //TP.IconObject.RefInc;
        TP.TrayObject.Icon := i.Handle;
    end
    else
    begin
        if empty_icon = 0 then
        begin
           bmp := NewBitmap(16, 16);
           bmp.Canvas.Brush.Color := clWhite;
           bmp.Canvas.FillRect(MakeRect(0, 0, 16, 16));
           mask := NewBitmap(16, 16);
           FillChar(ii, Sizeof(ii), 0);
           ii.fIcon := TRUE;
           ii.hbmMask := mask.Handle;
           ii.hbmColor := bmp.Handle;
           empty_icon := CreateIconIndirect(ii);
           bmp.Free;
           mask.Free;
        end;
        TP.TrayObject.Icon := empty_icon;
    end;
    TP.TrayObject.Active := TP.Active;
end;

procedure TTrayPanel.Form_tray_icon_mouse(Sender: PObj; Msg: Word);
//?{Tray}
type PPObj = ^PObj; // fix a bug in KOL 3.23
var F: C_Form;
    TI: PTrayIcon;
    R: Ref_obj;
    P: TPoint;
    b: Integer;
//.
begin
//?{Tray}

    TI := PTrayIcon(PPObj(Sender)^); // fix a bug in KOL 3.23
    case Msg of
    WM_LBUTTONUP: b := 1;
    WM_RBUTTONUP: b := 2;
    WM_MBUTTONUP: b := 3;
    else Exit;
    end;
    
    R := Pointer(TI.Tag);
    
    form.Mouse_button := b;
    
    GetCursorPos(P);
    P := Form.Form.Screen2Client(P);
    Form.Popup_point.f_X := Pixels(P.X);
    Form.Popup_point.f_Y := Pixels(P.Y);

    F := C_Form(Form.AL4Object.Obj);
    
    //Object_assign_hard(F.F_sender, R.Obj);
    //F.F_sender_alias := C_Control(R.obj).F_Alias;
    
    operation_started(F, 0, R);
    try
    F.M_Click;
    finally
    F.M_operation_ended(0);
    end;

	//Object_assign_hard(F.F_sender, NoneObj_C_Control);
//.
end;

procedure TTrayPanel.Form_tray_icon_destroy(Sender: PObj);
//?{Tray}
var XT: C_Tray;
//.
begin
//?{Tray}
    XT := C_Tray(Ref_obj(Tag).Obj);
    XT.F_Handle := 0;
    if TrayObject <> nil then
    	TrayObject.Active := false;
    TrayObject := nil;
//.
end;

end.
(*
/*
END
*/
*)



