
with GNATCOM;                                   use GNATCOM;
with GNATCOM.Types;                             use GNATCOM.Types;
with GNATCOM.Events;                            use GNATCOM.Events;
with GNATCOM.Create.COM_Interface;              use GNATCOM.Create.COM_Interface;
with GNATCOM.Iinterface;                        use GNATCOM.Iinterface;
with GNATCOM.Dispinterface;                     use GNATCOM.Dispinterface;
with GNATOCX;                                   use GNATOCX;
with GNATOCX.IOleClientSite_Interface;          use GNATOCX.IOleClientSite_Interface;
with GNATOCX.IOleObject_Interface;              use GNATOCX.IOleObject_Interface;
with GWindows;                                  use GWindows;
with GWindows.Types;                            use GWindows.Types;
with GWindows.Constants;                        use GWindows.Constants;
with GWindows.Base;                             use GWindows.Base;
with GWindows.Application;                      use GWindows.Application;
with GWindows.ActiveX;                          use GWindows.ActiveX;
with GWindows.GStrings;                         use GWindows.GStrings;
with GWindows.AuxHelper;                        use GWindows.AuxHelper;

with SHDocVw;
with SHDocVw.IWebBrowser2_Interface;            use SHDocVw.IWebBrowser2_Interface;
with SHDocVw.DWebBrowserEvents2_Events;         use SHDocVw.DWebBrowserEvents2_Events;
with MSHTML;                                    use MSHTML;
with MSHTML.IHTMLDocument2_Interface;           use MSHTML.IHTMLDocument2_Interface;
with MSHTMLHST;                                 use MSHTMLHST;
with MSHTMLHST.IDocHostUIHandler_Object;        use MSHTMLHST.IDocHostUIHandler_Object;
with MSHTML.IHTMLElementCollection_Interface;   use MSHTML.IHTMLElementCollection_Interface;
with MSHTML.IHTMLElement_Interface;             use MSHTML.IHTMLElement_Interface;
with MSHTML.IHTMLEventObj_Interface;            use MSHTML.IHTMLEventObj_Interface;
with HtmlForm;                                  use HtmlForm;

package body RTSDDMessageBox is

   type WebBrowserEvents2_Event_Type is new DWebBrowserEvents2_Event with null record;
   procedure DocumentComplete(
			      This  : WebBrowserEvents2_Event_Type;
			      pDisp : GNATCOM.Types.VARIANT;
			      URL   : GNATCOM.Types.VARIANT
			     );
   procedure NavigateComplete2(
			       This  : WebBrowserEvents2_Event_Type;
			       pDisp : GNATCOM.Types.VARIANT;
			       URL   : GNATCOM.Types.VARIANT
			      );
   --  Override from SHDocVw.DWebBrowserEvents2_Events.DWebBrowserEvents2_Event
   type DocHostUIHandler_Object_Type is
     new IDocHostUIHandler_Object_Type with null record;
   function ShowContextMenu(
			    This           : DocHostUIHandler_Object_Type;
			    dwID           : DWORD;
			    ppt            : access Point_Type;
			    pcmdtReserved  : access IUnknown;
			    pdispReserved  : access IDispatch
			   ) return HRESULT;
   function GetHostInfo(
			This           : DocHostUIHandler_Object_Type;
			pInfo          : access DOCHOSTUIINFO
		       ) return HRESULT;
   g_oDocHostUIHandler  : DocHostUIHandler_Object_Type;
   type DHtmlForm_type is new HtmlForm_type with null record;
   procedure UpdateData(
			This       : in out DHtmlForm_type;
			bReadOp    : Boolean := False
		       );
   function g_fNewQueryInterface(
				 This   : access IOleClientSite;
				 riid   : Pointer_To_GUID;
				 ppvObj : Pointer_To_Pointer_To_Void
				) return HRESULT;
   pragma Convention (StdCall, g_fNewQueryInterface);
   type RTSDDMessageBox_Type is new Window_Type with null record;
   procedure On_Close (Window    : in out RTSDDMessageBox_Type;
		       Can_Close :    out Boolean);
   --  Called to request if window may close
   g_wRTSDDMessageBox    : RTSDDMessageBox_Type;
   g_fOldQueryInterface  : af_IOleClientSite_QueryInterface;
   g_usVersionHTMLString : GString_Unbounded := To_GString_Unbounded(GetVersionString & "&nbsp;&beta;");
   g_usCopyRightDates    : GString_Unbounded := To_GString_Unbounded("2006-2017");
   g_oWebClientSite      : IOleClientSite_Type;
   IC_Control            : aliased ActiveX_Type;
   IC_COM                : IWebBrowser2_Type;
   Main_Url              : GString := "res://" & GetAppFileName & "/RTSDDMESSAGEBOX.HTM";
   -- HtmlForm
   procedure OnButtonOK(oEventObj : in out IHTMLEventObj_Type);
   g_oHtmlForm           : DHtmlForm_type;
   g_aOnClickEvents      : aliased Event_Descriptors :=
     (
      1 => (To_GString_Unbounded("ButtonOK"), OnButtonOK'Access)
     );

   procedure Show_RTSDDMessageBox(
				  wParent  : in out Window_Type'Class;
				  nResult : out Integer
				 )
   is
      WebBrowser_Event_Object : aliased WebBrowserEvents2_Event_Type;
      --  Create event object
      WebBrowser_Event : Pointer_To_COM_Interface_Type :=
	SHDocVw.DWebBrowserEvents2_Events.Create (WebBrowser_Event_Object'Unchecked_Access);
      --  Create COM interface wrapper around event object
      WebBrowser_Events_CPoint : IConnectionPoint_Type;
      --  Interface to connection point with in COM object
      --  Used to connect and disconnect event object
      --  Disconnect is performed automaticly when Handle_Events is finalized
      oOleObject       : IOleObject_Type;
      pClientSite      : aliased Pointer_To_IOleClientSite;
   begin
      Create_As_Dialog(
		       g_wRTSDDMessageBox,
		       wParent,
		       "AboutBox",
		       Width => 740,
		       Height => 310
		      );
      Create (
	      IC_Control,
	      g_wRTSDDMessageBox,
	      SHDocVw.CLSID_WebBrowser,
	      1,
	      1,
	      1,
	      1
	     );
      Dock (IC_Control, GWindows.Base.Fill);
      Large_Icon (g_wRTSDDMessageBox, "MAIN_FRAME");
      Query (IC_COM, Interfac (IC_Control));
      Query (oOleObject, IC_COM);
      GetClientSite(oOleObject, pClientSite'Unchecked_Access);
      g_fOldQueryInterface := pClientSite.Vtbl.QueryInterface;
      Attach(g_oWebClientSite, pClientSite);
      Create(g_oDocHostUIHandler);
      pClientSite.Vtbl.QueryInterface := g_fNewQueryInterface'Access;
      SetClientSite(oOleObject, pClientSite);
      SHDocVw.DWebBrowserEvents2_Events.Set_Events(
						   WebBrowser_Events_CPoint,
						   For_Object      => IC_COM,
						   Event_Interface => WebBrowser_Event
						  );
      Navigate(
	       IC_COM,
	       To_BSTR_From_GString(Main_Url)
	      );
      nResult := Show_Dialog(g_wRTSDDMessageBox);
   end Show_RTSDDMessageBox;

   procedure OnButtonOK(oEventObj : in out IHTMLEventObj_Type)
   is
   begin
      End_Dialog(g_wRTSDDMessageBox, IDOK);
   end OnButtonOK;

   function g_fNewQueryInterface(
				 This   : access IOleClientSite;
				 riid   : Pointer_To_GUID;
				 ppvObj : Pointer_To_Pointer_To_Void
				) return HRESULT
   is
   begin
      if riid.all = IID_IDocHostUIHandler then
	 ppvObj.all := Address(g_oDocHostUIHandler);
	 return S_OK;
      end if;
      return g_fOldQueryInterface(
				  This,
				  riid,
				  ppvObj
				 );
   end g_fNewQueryInterface;

   function ShowContextMenu(
			    This           : DocHostUIHandler_Object_Type;
			    dwID           : DWORD;
			    ppt            : access Point_Type;
			    pcmdtReserved  : access IUnknown;
			    pdispReserved  : access IDispatch
			   ) return HRESULT
   is
   begin
      if dwID = CONTEXT_MENU_CONTROL then
	 return S_FALSE;
      end if;
      return S_OK;
   end ShowContextMenu;

   function GetHostInfo(
			This           : DocHostUIHandler_Object_Type;
			pInfo          : access DOCHOSTUIINFO
		       ) return HRESULT
   is
   begin
      pInfo.all.dwFlags := DOCHOSTUIFLAG_NO3DBORDER or DOCHOSTUIFLAG_DIALOG;
      return S_OK;
   end GetHostInfo;

   procedure UpdateData(
			This       : in out DHtmlForm_type;
			bReadOp    : Boolean := False
		       )
   is
   begin
      DDX_DHtml_ElementInnerHtml(
				 This,
				 "version_str",
				 g_usVersionHTMLString,
				 bReadOp
				);
      DDX_DHtml_ElementInnerText(
				 This,
				 "message_text",
				 g_usMessageText,
				 bReadOp
				);
      DDX_DHtml_ElementInnerText(
				 This,
				 "cr_dates",
				 g_usCopyRightDates,
				 bReadOp
				);
      DDX_DHtml_Img_Src(
			This,
			"message_type_img",
			g_usMessageTypeImageSRC,
			bReadOp
		       );
   end UpdateData;

   procedure NavigateComplete2(
			       This  : WebBrowserEvents2_Event_Type;
			       pDisp : GNATCOM.Types.VARIANT;
			       URL   : GNATCOM.Types.VARIANT
			      )
   is
      pragma Unreferenced (This, pDisp, URL);
   begin
      Create(
             g_oHtmlForm,
             IC_Control'Access,
	     IC_COM,
	     g_aOnClickEvents'Access
	    );
   end NavigateComplete2;

   procedure DocumentComplete(
			      This  : WebBrowserEvents2_Event_Type;
			      pDisp : GNATCOM.Types.VARIANT;
			      URL   : GNATCOM.Types.VARIANT
			     )
   is
      sDocTitle : GString := Get_title(g_oHtmlForm);
   begin
      Text(g_wRTSDDMessageBox, sDocTitle);
      UpdateData(g_oHtmlForm);
   end DocumentComplete;

   procedure On_Close (Window    : in out RTSDDMessageBox_Type;
		       Can_Close :    out Boolean)
   is
   begin
      Can_Close := True;
      Pointer(g_oWebClientSite).Vtbl.QueryInterface := g_fOldQueryInterface;
   end On_Close;

end RTSDDMessageBox;
