{ The contents of this file are subject to the Mozilla Public License  }
{ Version 1.1 (the "License"); you may not use this file except in     }
{ compliance with the License. You may obtain a copy of the License at }
{ http://www.mozilla.org/MPL/                                          }
{                                                                      }
{ Software distributed under the License is distributed on an "AS IS"  }
{ basis, WITHOUT WARRANTY OF ANY KIND, either express or implied. See  }
{ the License for the specific language governing rights and           }
{ limitations under the License.                                       }
{                                                                      }
{ The Original Code is InternetDocServer.pas                           }
{ This unit requires AxDocServer.pas                                   }
{                                                                      }
{ The Initial Developer of the Original Code is Ashley Godfrey, all    }
{ Portions created by these individuals are Copyright (C) of Ashley    }
{ Godfrey.                                                             }
{                                                                      }
{**********************************************************************}
{                                                                      }
{ This unit contains the base class required for the development of    }
{ an Internet aware document server, including basic mechanics for     }
{ loading and saving documents, and supporting Internet Explorer       }
{ navigation.                                                          }
{                                                                      }
{ Unit owner: Ashley Godfrey.                                          }
{ Last modified: May 2, 2006.                                          }
{ Updates available from http://www.evocorp.com                        }
{                                                                      }
{**********************************************************************}

unit InternetDocServer;
{$WARN SYMBOL_PLATFORM OFF}

interface
uses
  SysUtils, Windows, Classes, Controls, StdCtrls, ExtCtrls, Forms,
  Dialogs, Graphics, AxCtrls, StdVcl, ActiveX, ComObj, UrlMon, HLink,
  AxDocServer;

type
  // NOTE: TInternetDocServer by no means represents a complete implementation
  //       of an Internet Explorer compatible ActiveX Document Server, and will
  //       require code changes that suit your own server requirements.
  //
  //       For example, changes might include how you handle internal document
  //       navigation (through the IHLinkXxxx interfaces), how you implement
  //       your browse context and what you do for persistent loading and saving
  //       of the associated document.

  // So what document does Internet Explorer want you to open?
  // TInternetDocServer exposes a protected property: DocumentURL
  // DocumentURL identifies the document that the user wants to open.

  TInternetDocServer = class(TActiveDocServer,
    IHLinkSite, IHLinkTarget, IOleContainer, IOleItemContainer,
    IParseDisplayName, IPersistFile, IPersistMoniker, IPersistPropertyBag)
  private
    FBrowseContext: IHLinkBrowseContext;
    FBrowseContextReg: DWORD;
    FDocumentUrl: string;
    FCurMoniker: IMoniker;
    FHLinkFrame: IHLinkFrame;
    FPersistFileName: string;
  protected
    // IHLinkSite
    function IHLinkSite.QueryService = HLinkSiteQueryService;
    function IHLinkSite.GetMoniker = HLinkSiteGetMoniker;
    function IHLinkSite.ReadyToNavigate = HLinkSiteReadyToNavigate;
    function IHLinkSite.OnNavigationComplete = HLinkSiteOnNavigationComplete;

    function HLinkSiteQueryService(dwSiteData: DWORD;
      const guidService, riid: TGuid; out ppiunk: IUnknown): HRESULT; virtual; stdcall;
    function HLinkSiteGetMoniker(dwSiteData, dwAssign, dwWhich: DWORD;
      out ppimk: IMoniker): HRESULT; virtual; stdcall;
    function HLinkSiteReadyToNavigate(
      dwSiteData, dwReserved: DWORD): HRESULT; virtual; stdcall;
    function HLinkSiteOnNavigationComplete(dwSiteData, dwreserved: DWORD;
      hrError: HRESULT; pwzError: pWideChar): HRESULT; virtual; stdcall;

    // IHLinkTarget
    function IHLinkTarget.GetBrowseContext = HLinkTargetGetBrowseContext;
    function IHLinkTarget.GetFriendlyName = HLinkTargetGetFriendlyName;
    function IHLinkTarget.GetMoniker = HLinkTargetGetMoniker;
    function IHLinkTarget.Navigate = HLinkTargetNavigate;
    function IHLinkTarget.SetBrowseContext = HLinkTargetSetBrowseContext;

    function HLinkTargetGetBrowseContext(
      out ppihlbc: IHLinkBrowseContext): HRESULT; virtual; stdcall;
    function HLinkTargetGetFriendlyName(pwzLocation: pWideChar;
      out ppwzFriendlyName: pWideChar): HRESULT; virtual; stdcall;
    function HLinkTargetGetMoniker(pwzLocation: pWideChar; dwAssign: DWORD;
      out ppimkLocation: IMoniker): HRESULT; virtual; stdcall;
    function HLinkTargetNavigate(grfHLNF: DWORD;
      pwzJumpLocation: pWideChar): HRESULT; virtual; stdcall;
    function HLinkTargetSetBrowseContext(
      pihlbc: IHLinkBrowseContext): HRESULT; virtual; stdcall;

    // IOleContainer
    function IOleContainer.EnumObjects = OleContainerEnumObjects;
    function IOleContainer.LockContainer = OleContainerLockContainer;

    function OleContainerEnumObjects(grfFlags: Longint;
      out Enum: IEnumUnknown): HResult; virtual; stdcall;
    function OleContainerLockContainer(fLock: BOOL): HResult; virtual; stdcall;

    // IOleItemContainer
    function IOleItemContainer.EnumObjects = OleContainerEnumObjects;
    function IOleItemContainer.GetObject = OleItemContainerGetObject;
    function IOleItemContainer.GetObjectStorage = OleItemContainerGetObjectStorage;
    function IOleItemContainer.IsRunning = OleItemContainerIsRunning;
    function IOleItemContainer.LockContainer = OleContainerLockContainer;

    function OleItemContainerGetObject(pszItem: POleStr;
      dwSpeedNeeded: Longint; const bc: IBindCtx; const iid: TIID;
      out vObject): HResult; virtual; stdcall;
    function OleItemContainerGetObjectStorage(pszItem: POleStr;
      const bc: IBindCtx; const iid: TIID; out vStorage): HResult; virtual; stdcall;
    function OleItemContainerIsRunning(pszItem: POleStr): HResult; virtual; stdcall;

    // IParseDisplayName
    function ParseDisplayName(const bc: IBindCtx; pszDisplayName: POleStr;
      out chEaten: Longint; out mkOut: IMoniker): HResult; virtual; stdcall;

    // IPersistFile
    function IPersistFile.IsDirty = PersistFileIsDirty;
    function IPersistFile.Load = PersistFileLoad;
    function IPersistFile.Save = PersistFileSave;
    function IPersistFile.SaveCompleted = PersistFileSaveCompleted;
    function IPersistFile.GetCurFile = PersistFileGetCurFile;

    function PersistFileIsDirty: HResult; virtual; stdcall;
    function PersistFileLoad(
      pszFileName: POleStr; dwMode: Longint): HResult; virtual; stdcall;
    function PersistFileSave(
      pszFileName: POleStr; fRemember: BOOL): HResult; virtual; stdcall;
    function PersistFileSaveCompleted(
      pszFileName: POleStr): HResult; virtual; stdcall;
    function PersistFileGetCurFile(out pszFileName: POleStr): HResult; virtual; stdcall;

    // IPersistMoniker
    function IPersistMoniker.GetClassID = PersistMonikerGetClassID;
    function IPersistMoniker.IsDirty = PersistMonikerIsDirty;
    function IPersistMoniker.Load = PersistMonikerLoad;
    function IPersistMoniker.Save = PersistMonikerSave;
    function IPersistMoniker.SaveCompleted = PersistMonikerSaveCompleted;
    function IPersistMoniker.GetCurMoniker = PersistMonikerGetCurMoniker;

    function PersistMonikerGetClassID(out ClassID: TCLSID): HResult; virtual; stdcall;
    function PersistMonikerIsDirty: HResult; virtual; stdcall;
    function PersistMonikerLoad(
      fFullyAvailable: BOOL; pimkName: IMoniker; pibc: IBindCtx;
      grfMode: DWORD): HResult; virtual; stdcall;
    function PersistMonikerSave(pimkName: IMoniker;
      pbc: IBindCtx; fRemember: BOOL): HResult; virtual; stdcall;
    function PersistMonikerSaveCompleted(pimkName: IMoniker;
      pibc: IBindCtx): HResult; virtual; stdcall;
    function PersistMonikerGetCurMoniker(
      ppimkName: IMoniker): HResult; virtual; stdcall;

    // IPersistPropertyBag
    function IPersistPropertyBag.InitNew = PersistPropBagInitNew;
    function IPersistPropertyBag.Load = PersistPropBagLoad;
    function IPersistPropertyBag.Save = PersistPropBagSave;

    function PersistPropBagInitNew: HResult; stdcall;
    function PersistPropBagLoad(const pPropBag: IPropertyBag;
      const pErrorLog: IErrorLog): HResult; stdcall;
    function PersistPropBagSave(const pPropBag: IPropertyBag;
      fClearDirty: BOOL; fSaveAllProperties: BOOL): HResult; stdcall;

    // TInternetDocServer
    function DoGetMoniker(dwAssign: DWORD): IMoniker; virtual;
    procedure DoLoadProperties(const pPropBag: IPropertyBag;
      const pErrorLog: IErrorLog); virtual;
    function GetHLinkBrowseContext: IHLinkBrowseContext; virtual;
    function GetCurrentHlinkFrame: IHLinkFrame; virtual;

    property DocumentURL: string read FDocumentUrl;
    property HostBrowseContext: IHLinkBrowseContext
      read FBrowseContext write FBrowseContext;
    property HostHLinkFrame: IHLinkFrame read FHLinkFrame write FHLinkFrame;
    property PersistFileName: string
      read FPersistFileName write FPersistFileName;
  public
    procedure Initialize; override;
  end;

implementation

const
  DocServerFriendlyName = 'Blank';
  DocServerJumpLocation = 'Blank';

{ TInternetDocServer }

function TInternetDocServer.DoGetMoniker(dwAssign: DWORD): IMoniker;
begin
	// We already have a moniker handed to us by IPersistMoniker::Load
  if FCurMoniker <> nil then
    Result := FCurMoniker

	// Call the base class. 
  else if ClientSite <> nil then
		ClientSite.GetMoniker(dwAssign, OLEWHICHMK_OBJFULL, Result)

  else Result := nil;
end;

procedure TInternetDocServer.DoLoadProperties(
  const pPropBag: IPropertyBag; const pErrorLog: IErrorLog);
begin
  // Default, do nothing.
  //
  // This method allows setting the properties of an ActiveX control
  // through the use of HTML PARAM tags.
  //
  // To extract your parameters:
  //
  // procedure TMyDocServer.DoLoadProperties(const pPropBag: IPropertyBag);
  // var v: OleVariant;
  // begin
  //   if pPropBag.Read('MyPropertyNameHere', v, pErrorLog) = S_OK then
  //     FMyProp := v;
  // end;
end;

function TInternetDocServer.GetCurrentHlinkFrame: IHLinkFrame;
var pServiceProvider: IServiceProvider;
		frame: IOleInPlaceFrame;
		doc: IOleInPlaceUIWindow;
		rcPosRect, rcClipRect: TRect;
		frameInfo: TOleInPlaceFrameInfo;
begin
  // GetCurrentHlinkFrame handles all the negotiation necessary
  // to try to find a valid hyperlink frame.
  Result := nil;
  if ClientSite <> nil then
  begin
    // Try the easy way...
    if ClientSite.QueryInterface(IServiceProvider, pServiceProvider) = S_OK then
      pServiceProvider.QueryService(IHLinkFrame, IHLinkFrame, Result);

    if (Result = nil) and (InPlaceSite <> nil) then
    begin
      // Try the hard way
      frame := nil;
      InPlaceSite.GetWindowContext(frame, doc, rcPosRect, rcClipRect, frameInfo);
      if frame <> nil then
        frame.QueryInterface(IHlinkFrame, Result);
    end;
  end;
end;

function TInternetDocServer.GetHLinkBrowseContext: IHLinkBrowseContext;
var pHlinkFrame: IHLinkFrame;
    hr: HRESULT;
    pimk: IMoniker;
    hlid: ULONG;
begin
  // Get a Hyperlink Browse Context interface. Creates a new HBC if
  // this document isn't currently holding onto one passed by a previous
  // hyperlink. This typically happens when the document was started
  // standalone by the user and is hyperlinking for the first time.
  // When this happens, GetHLinkBrowseContext adds this document to
  // the top of the hyperlinking nav session
  Result := nil;
  hr := S_OK;

  if FBrowseContext = nil then
  begin
    pHlinkFrame := GetCurrentHlinkFrame;
    if pHlinkFrame <> nil then
      hr := pHlinkFrame.GetBrowseContext(FBrowseContext);
    if (FBrowseContext = nil) or (hr <> S_OK) then
    begin
      if HlinkCreateBrowseContext(nil, IHLinkBrowseContext, FBrowseContext) <> S_OK then
      begin
        FBrowseContext := nil;
        Exit;
      end;
      pimk := DoGetMoniker(OLEGETMONIKER_FORCEASSIGN);
      FBrowseContext.Register(0, Self as IHLinkSite, pimk, FBrowseContextReg);
      FBrowseContext.OnNavigateHLink(0, pimk, DocServerJumpLocation,
        DocServerFriendlyName, hlid);
    end;
  end;
  Result := FBrowseContext;
end;

function TInternetDocServer.HLinkSiteGetMoniker(dwSiteData, dwAssign,
  dwWhich: DWORD; out ppimk: IMoniker): HRESULT;
begin
	if dwWhich = OLEWHICHMK_CONTAINER then
		ppimk := DoGetMoniker(dwAssign)
  else ppimk := nil;
	// We return S_OK but NULL mk for OLEWHICHMK_OBJREL and OLEWHICHMK_OBJFULL
	// Because our site is just an informal holder for all the hyperlinks in the
	// document, there isn't really anything special necessary here. OBJREL &
	// OBJFULL are useful in OLE situations for linkings to embeddings but we're
	// not supporting that.
  Result := S_OK;
end;

function TInternetDocServer.HLinkSiteOnNavigationComplete(dwSiteData,
  dwreserved: DWORD; hrError: HRESULT; pwzError: pWideChar): HRESULT;
begin
  Result := S_OK;
end;

function TInternetDocServer.HLinkSiteQueryService(dwSiteData: DWORD;
  const guidService, riid: TGuid; out ppiunk: IInterface): HRESULT;
begin
  Result := QueryInterface(riid, ppiunk);
end;

function TInternetDocServer.HLinkSiteReadyToNavigate(dwSiteData,
  dwReserved: DWORD): HRESULT;
begin
  Result := S_OK;
end;

function TInternetDocServer.HLinkTargetGetBrowseContext(
  out ppihlbc: IHLinkBrowseContext): HRESULT;
begin
  ppihlbc := FBrowseContext;
  Result := S_OK;
end;

function TInternetDocServer.HLinkTargetGetFriendlyName(
  pwzLocation: pWideChar; out ppwzFriendlyName: pWideChar): HRESULT;
var pBuf: pointer;
    ulSize: ULONG;
begin
  ulSize := (Length(DocServerFriendlyName) + 1) * SizeOf(WideChar);
  pBuf := CoTaskMemAlloc(ulSize);
  if pBuf = nil then
  begin
    ppwzFriendlyName := nil;
    Result := E_FAIL
  end else begin
    StringToWideChar(DocServerFriendlyName, pBuf, Length(DocServerFriendlyName));
    Result := S_OK;
  end;
end;

function TInternetDocServer.HLinkTargetGetMoniker(
  pwzLocation: pWideChar; dwAssign: DWORD;
  out ppimkLocation: IMoniker): HRESULT;
begin
	// All possible locations are in this document and
	// this document currently only has one hyperlink target
	// so we return the document's moniker
	// (our only obligation is to return a moniker to the target)
	ppimkLocation := DoGetMoniker(dwAssign);
  if ppimkLocation = nil then
    Result := E_FAIL
  else Result := S_OK;
end;

function TInternetDocServer.HLinkTargetNavigate(
  grfHLNF: DWORD; pwzJumpLocation: pWideChar): HRESULT;
var hlid: ULONG;
    pHlinkFrame: IHLinkFrame;
    pHBC: IHLinkBrowseContext;
    pmkThis: IMoniker;
begin
  // The hyperlink frame must receive notification of a successful
  // navigation from IHlinkTarget.Navigate in order to reposition
  // its windows and update its windows' visibility. If this is the
  // same frame that hosted the hyperlink container that initiated
  // the navigation, the flags set will ensure that the frame remains
  // visible.

  // This function is called by the hyperlinking framework to indicate
  // that this document has been identified as the recipient of a
  // hyperlink navigation. The document needs to activate itself in
  // its container or show itself as appropriate. Then it needs to inform
  // the hyperlinking framework that the navigation has succeeded. Next,
  // the window positions need to be resized to match those of the last
  // hyperlink in the nav. This maintains the illusion of a browser jump
  // even if we're not in a hyperlink-frame. Finally, the doc needs to
  // jump to requested sub-location in the view

	// Activate Ourselves before doing anything else
  if DocumentSite <> nil then
    DocumentSite.ActivateMe(nil);

	// Notify the hlink frame and the browse context that the navigation
  // is complete.
  pHlinkFrame := GetCurrentHlinkFrame;
	pHBC := GetHLinkBrowseContext;
  pmkThis := DoGetMoniker(OLEGETMONIKER_FORCEASSIGN);
  Result := HlinkOnNavigate(pHlinkFrame, pHBC, grfHLNF,
    pmkThis, pwzJumpLocation, DocServerFriendlyName, hlid);
end;

function TInternetDocServer.HLinkTargetSetBrowseContext(
  pihlbc: IHLinkBrowseContext): HRESULT;
var pmkThis: IMoniker;
begin
  // Release the existing browse context, if we have one.
  if FBrowseContext <> nil then
  begin
    FBrowseContext.Revoke(FBrowseContextReg);
    FBrowseContext := nil;
  end;

  // Assign the new browse context
  FBrowseContext := pihlbc;
  if FBrowseContext <> nil then
  begin
    pmkThis := DoGetMoniker(OLEGETMONIKER_FORCEASSIGN);
    FBrowseContext.Register(0, Self as IUnknown, pmkThis, FBrowseContextReg);
  end;

  Result := S_OK;
end;

procedure TInternetDocServer.Initialize;
begin
  inherited;
  FDocumentUrl := '';
  FPersistFileName := '';
end;

function TInternetDocServer.OleContainerEnumObjects(grfFlags: Integer;
  out Enum: IEnumUnknown): HResult;
begin
  Result := E_NOTIMPL;
end;

function TInternetDocServer.OleContainerLockContainer(
  fLock: BOOL): HResult;
begin
	Result := CoLockObjectExternal(Self as IInterface, fLock, True);
end;

function TInternetDocServer.OleItemContainerGetObject(pszItem: POleStr;
  dwSpeedNeeded: Integer; const bc: IBindCtx; const iid: TIID;
  out vObject): HResult;
begin
  Result := MK_E_NOOBJECT;
end;

function TInternetDocServer.OleItemContainerGetObjectStorage(
  pszItem: POleStr; const bc: IBindCtx; const iid: TIID;
  out vStorage): HResult;
begin
  Result := MK_E_NOSTORAGE;
end;

function TInternetDocServer.OleItemContainerIsRunning(
  pszItem: POleStr): HResult;
begin
  if OleIsRunning(Self as IOleObject) then
    Result := S_OK
  else Result := S_FALSE;
end;

function TInternetDocServer.ParseDisplayName(
  const bc: IBindCtx; pszDisplayName: POleStr; out chEaten: Integer;
  out mkOut: IMoniker): HResult;
begin
  // This code will need to be changed to suit your document's
  // navigational naming structure.
	Result := CreateItemMoniker('\', pszDisplayName, mkOut);
end;

function TInternetDocServer.PersistFileGetCurFile(
  out pszFileName: POleStr): HResult;
var Malloc: IMalloc;
    MallocSize: DWORD;
begin
  Result := S_OK;
  try
    CoGetMalloc(1, Malloc);
    try
      MallocSize := (Length(FPersistFileName) + 1) * SizeOf(WideChar);
      pszFileName := Malloc.Alloc(MallocSize);
      StringToWideChar(FPersistFileName, pszFileName, MallocSize - 1);
    finally
      Malloc := nil;
    end;
  except
    Result := E_FAIL;
  end;
end;

function TInternetDocServer.PersistFileIsDirty: HResult;
begin
  Result := S_FALSE;
end;

function TInternetDocServer.PersistFileLoad(
  pszFileName: POleStr; dwMode: Integer): HResult;
begin
  FPersistFileName := WideCharToString(pszFileName);
  Result := S_OK;
end;

function TInternetDocServer.PersistFileSave(pszFileName: POleStr;
  fRemember: BOOL): HResult;
begin
  FPersistFileName := WideCharToString(pszFileName);
  Result := S_OK;
end;

function TInternetDocServer.PersistFileSaveCompleted(
  pszFileName: POleStr): HResult;
begin
  FPersistFileName := WideCharToString(pszFileName);
  Result := S_OK;
end;

function TInternetDocServer.PersistMonikerGetClassID(
  out ClassID: TCLSID): HResult;
begin
  Result := inherited GetClassID(ClassID);
end;

function TInternetDocServer.PersistMonikerGetCurMoniker(
  ppimkName: IMoniker): HResult;
begin
	ppimkName := DoGetMoniker(OLEGETMONIKER_ONLYIFTHERE);
	Result := S_OK;
end;

function TInternetDocServer.PersistMonikerIsDirty: HResult;
begin
  Result := S_FALSE;
end;

function TInternetDocServer.PersistMonikerLoad(fFullyAvailable: BOOL;
  pimkName: IMoniker; pibc: IBindCtx; grfMode: DWORD): HResult;
var CoMalloc: IMalloc;
    pszDisplayName: PWideChar;
begin
  pointer(CoMalloc) := nil;
  if pimkName = nil then
    Result := E_FAIL

	// If we return S_FALSE, we'll be called back later
	// when the data is available
	else if not fFullyAvailable then
		Result := S_FALSE

  else begin
    // Store the current moniker...
  	FCurMoniker := pimkName;
    // ...and determine what document we're trying to open.
    if CoGetMalloc(1, CoMalloc) = S_OK then
    try
      if pimkName.GetDisplayName(pibc, nil, pszDisplayName) = S_OK then
        FDocumentUrl := pszDisplayName;
    finally
      CoMalloc := nil;
    end;
    Result := S_OK;
  end;
end;

function TInternetDocServer.PersistMonikerSave(pimkName: IMoniker;
  pbc: IBindCtx; fRemember: BOOL): HResult;
begin
  Result := E_NOTIMPL;
end;

function TInternetDocServer.PersistMonikerSaveCompleted(pimkName: IMoniker;
  pibc: IBindCtx): HResult;
begin
  Result := E_NOTIMPL;
end;

function TInternetDocServer.PersistPropBagInitNew: HResult;
begin
  Result := S_OK;
end;

function TInternetDocServer.PersistPropBagLoad(const pPropBag: IPropertyBag;
  const pErrorLog: IErrorLog): HResult;
begin
  DoLoadProperties(pPropBag, pErrorLog);  
  Result := S_OK;
end;

function TInternetDocServer.PersistPropBagSave(const pPropBag: IPropertyBag;
  fClearDirty, fSaveAllProperties: BOOL): HResult;
begin
  Result := S_OK;
end;

end.