{ 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 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 code will require modifications to AxCtrls.pas, as identified   }
{ by compiler errors (i.e., cannot override static methods, etc.).     }
{                                                                      }
{**********************************************************************}
{                                                                      }
{ This unit contains the base classes required for implementation of   }
{ an ActiveX Document Server, including automated registration.        }
{                                                                      }
{ Unit owner: Ashley Godfrey.                                          }
{ Last modified: May 2, 2005.                                          }
{ Updates available from http://www.evocorp.com                        }
{                                                                      }
{**********************************************************************}

unit AxDocServer;

{$WARN SYMBOL_PLATFORM OFF}

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

const
  // DOCMISC provides miscellaneous property information about a document
  // object.
  // Object supports multiple views.
  DOCMISC_CANCREATEMULTIPLEVIEWS = 1;
  // Object supports complex rectangles and, therefore implements
  // IOleDocumentView::SetRectComplex.
	DOCMISC_SUPPORTCOMPLEXRECTANGLES = 2;
  // Object supports activation in a separate window and, therefore
  // implements IOleDocumentView::Open.
	DOCMISC_CANTOPENEDIT = 4;
  // Object does not support file read/write.
	DOCMISC_NOFILESUPPORT	= 8;

type
  TActiveDocServer = class(TActiveXControl, IOleDocument,
    IOleDocumentView, IOleInPlaceObject, IOleObject)
  private
    FContainer: TPanel;
    FDocumentSite: IOleDocumentSite;
    FInPlaceActive: Boolean;
  protected
    // IOleDocument
    function CreateView(Site: IOleInPlaceSite; Stream: IStream; rsrvd: DWORD;
      out View: IOleDocumentView):HResult; stdcall;
    function GetDocMiscStatus(var Status: DWORD):HResult; stdcall;
    function EnumViews(out Enum: IEnumOleDocumentViews;
      out View: IOleDocumentView):HResult; stdcall;
    // IOleDocumentView
    function SetInPlaceSite(Site: IOleInPlaceSite):HResult; stdcall;
    function GetInPlaceSite(out Site: IOleInPlaceSite):HResult; stdcall;
    function GetDocument(out P: IUnknown):HResult; stdcall;
    function SetRect(const View: TRECT):HResult; stdcall;
    function GetRect(var View: TRECT):HResult; stdcall;
    function SetRectComplex(
      const View, HScroll, VScroll, SizeBox):HResult; stdcall;
    function Show(fShow: BOOL):HResult; stdcall;
    function UIActivate(fUIActivate: BOOL):HResult; stdcall;
    function Open:HResult; stdcall;
    function CloseView(dwReserved: DWORD):HResult; stdcall;
    function SaveViewState(pstm: IStream):HResult; stdcall;
    function ApplyViewState(pstm: IStream):HResult; stdcall;
    function Clone(NewSite: IOleInPlaceSite;
      out NewView: IOleDocumentView):HResult; stdcall;
    // IOleInPlaceObject
    function InPlaceDeactivate: HResult; stdcall;
    // IOleObject
    function DoVerb(iVerb: Longint; msg: PMsg;
      const activeSite: IOleClientSite; lindex: Longint;
      hwndParent: HWND; const posRect: TRect): HResult; stdcall;
    function SetClientSite(const clientSite: IOleClientSite): HResult; stdcall;
    // TActiveDocumentServer
    procedure DoSetClientSite(ClientSite: IOleClientSite); virtual;
    procedure DoSetInplaceSite(Site: IOleInplaceSite); virtual;
    procedure InitializeControl; override;

    // ********************************************************************** //
    // InPlaceActivate is not virtual by default, therefore you should receive
    // a compile error on the following method declaration. This will require
    // you to modify the declaration of InPlaceActivate in TActiveXControl
    // (provided in AxCtrls.pas with Delphi) such that it is "virtual", i.e.:
    //
    //   function InPlaceActivate(ActivateUI: Boolean): HResult; virtual;
    // ********************************************************************** //
    function InPlaceActivate(ActivateUI: Boolean): HResult; override;
  public
    procedure Initialize; override;
    function ObjQueryInterface(const IID: TGUID; out Obj): HResult; override;

    property Container: TPanel read FContainer;
    property DocumentSite: IOleDocumentSite read FDocumentSite;
    property InplaceActive: Boolean read FInPlaceActive;
  end;

  TActiveDocServerClass = class of TActiveDocServer;

  TActiveDocServerFactory = class(TActiveXControlFactory)
  private
    FDocMiscStatus: DWORD;   // Miscellaneous document properties
    FFileExtension: string;  // File extension to associate with this document
    FHandler: string;
    FMimeType: string;       // MIME type to associate with this document
  protected
    function GetFileExtension: string; virtual;
    procedure UpdateDownloadClasses(Register: Boolean); virtual;
    procedure UpdateFileExtensions(Register: Boolean); virtual;
    procedure UpdateMimeDatabase(Register: Boolean); virtual;
  public
    constructor Create(ComServer: TComServerObject;
      ActiveXDocClass: TActiveDocServerClass; const ClassID: TGUID;
      FileExtension, MimeType, OleHandler: string;
      ToolboxBitmapID, MiscStatus, DocMiscStatus: Integer;
      ThreadingModel: TThreadingModel);
    procedure UpdateRegistry(Register: Boolean); override;

    property DocMiscStatus: DWORD read FDocMiscStatus;
  end;

implementation
uses
  ComServ, Registry;

{ TActiveDocServer }

function TActiveDocServer.ApplyViewState(pstm: IStream): HResult;
begin
  Result := E_NOTIMPL;
end;

function TActiveDocServer.Clone(NewSite: IOleInPlaceSite;
  out NewView: IOleDocumentView): HResult;
begin
  Result := E_NOTIMPL;
end;

function TActiveDocServer.CloseView(dwReserved: DWORD): HResult;
begin
  Result := S_OK;
  try
    Show(False);
    SetInPlaceSite(nil);
  except
    Result := E_UNEXPECTED;
  end;
end;

function TActiveDocServer.CreateView(Site: IOleInPlaceSite;
  Stream: IStream; rsrvd: DWORD; out View: IOleDocumentView): HResult;
begin
  try
		// If we've already created a view then we can't create another
		// as we only support the ability to create one view
    if InPlaceSite <> nil then
      Result := E_FAIL
//    else if View = nil then
//      Result := E_POINTER
    else begin
      // Return self as IOleDocumentView
      View := Self as IOleDocumentView;

      // If pIPSite is not NULL, then the document object should pass the pointer
      // to the new view in a call to IOleDocumentView::SetInPlaceSite. If pIPSite
      // is NULL, the caller is responsible for making this same call.
      if Site <> nil then
        View.SetInPlaceSite(Site);

      // If pstm is not NULL, then the document object should initialize the
      // view object by passing pstm in a call to IOleDocumentView::ApplyViewState.
      if Stream <> nil then
        View.ApplyViewState(Stream);

      // This method must be completely implemented for any document object;
      // E_NOTIMPL is not an acceptable return value.
      Result := S_OK;
    end;
  except
    Result := E_FAIL;
  end;
end;

procedure TActiveDocServer.DoSetClientSite(ClientSite: IOleClientSite);
begin
  // Stub
end;

procedure TActiveDocServer.DoSetInplaceSite(Site: IOleInplaceSite);
begin
  // Stub
end;

function TActiveDocServer.DoVerb(iVerb: Integer; msg: PMsg;
  const activeSite: IOleClientSite; lindex: Integer; hwndParent: HWND;
  const posRect: TRect): HResult;
begin
  if (FDocumentSite <> nil) and
     ((iVerb = OLEIVERB_SHOW) or (iVerb = OLEIVERB_UIACTIVATE)) and
     not FInPlaceActive then
    Result := FDocumentSite.ActivateMe(nil)
  else
  Result := inherited DoVerb(
     iVerb, msg, activeSite, lindex, hwndParent, posRect);
end;

function TActiveDocServer.EnumViews(
  out Enum: IEnumOleDocumentViews; out View: IOleDocumentView): HResult;
begin
  try
    Enum := nil;
    // Single view only, i.e., we only ever support one view.
    View := Self as IOleDocumentView;
    Result := S_OK;
  except
    Result := E_FAIL;
  end;
end;

function TActiveDocServer.GetDocMiscStatus(var Status: DWORD): HResult;
begin
  Status := (Factory as TActiveDocServerFactory).DocMiscStatus;
  Result := S_OK;
end;

function TActiveDocServer.GetDocument(out P: IInterface): HResult;
begin
  try
    P := Self as IUnknown;
    Result := S_OK;
  except
    Result := E_FAIL;
  end;
end;

function TActiveDocServer.GetInPlaceSite(
  out Site: IOleInPlaceSite): HResult;
begin
  Site := InPlaceSite;
  Result := S_OK;
end;

function TActiveDocServer.GetRect(var View: TRECT): HResult;
begin
  if Assigned(FContainer) then
  begin
    View := FContainer.BoundsRect;
    Result := S_OK;
  end else
    Result := E_UNEXPECTED;
end;

procedure TActiveDocServer.Initialize;
begin
  inherited;
  FDocumentSite := nil;
end;

procedure TActiveDocServer.InitializeControl;
begin
  FContainer := Control as TPanel;
  FContainer.BevelOuter := bvNone;
  FContainer.BevelInner := bvNone;
  FContainer.Color := clWindow;
  FContainer.Visible := True;
end;

function TActiveDocServer.InPlaceActivate(ActivateUI: Boolean): HResult;
begin
  Result := inherited InPlaceActivate(ActivateUI);
  // On FInPlaceActive error in inherited, InPlaceSite is released...
  FInPlaceActive := InPlaceSite <> nil;
end;

function TActiveDocServer.InPlaceDeactivate: HResult;
(*var ParentWnd: HWND;
begin
  // This is a work-around for the fact that TActiveXControl
  // implementation of this method makes the control go away
  // to ParkingWindow la-la land.  It needs to stay put within
  // the document.
  ParentWnd := Control.ParentWindow;
  Result := inherited InplaceDeactivate;
  Control.ParentWindow := ParentWnd;
  Control.Visible := True;  *)
begin
  Result := inherited InplaceDeactivate;
  FInPlaceActive := False;
end;

function TActiveDocServer.ObjQueryInterface(const IID: TGUID;
  out Obj): HResult;
begin
  // Must stub out IOleLink, or container will assume this is
  // a linked object rather than an embedded object.
  if IsEqualGuid(IID, IOleLink) then
    Result := E_NOINTERFACE
  else Result := inherited ObjQueryInterface(IID, Obj);
end;

function TActiveDocServer.Open: HResult;
begin
  Result := E_NOTIMPL;
end;

function TActiveDocServer.SaveViewState(pstm: IStream): HResult;
begin
  Result := E_NOTIMPL;
end;

function TActiveDocServer.SetClientSite(
  const clientSite: IOleClientSite): HResult;
begin
  if clientSite <> nil then
    clientSite.QueryInterface(IOleDocumentSite, FDocumentSite);
  Result := inherited SetClientSite(clientSite);
  DoSetClientSite(inherited ClientSite);
end;

function TActiveDocServer.SetInPlaceSite(Site: IOleInPlaceSite): HResult;
begin
  Result := S_OK;
  try
    if InPlaceSite <> nil then
    begin
      UIActivate(False);
      Result := InPlaceDeactivate;
    end;
    if (Result = S_OK) and (Site <> nil) then
      inherited SetInplaceSite(Site);

    DoSetInplaceSite(inherited InPlaceSite);
  except
    Result := E_UNEXPECTED;
  end;
end;

function TActiveDocServer.SetRect(const View: TRECT): HResult;
begin
  // Implement using the inherited TActiveXControl
  // IOleInPlaceObject.SetObjectRects impl
  Result := SetObjectRects(View, View);
end;

function TActiveDocServer.SetRectComplex(
  const View, HScroll, VScroll, SizeBox): HResult;
begin
  Result := E_NOTIMPL;
end;

function TActiveDocServer.Show(fShow: BOOL): HResult;
begin
  try
    if fShow then
      Result := InPlaceActivate(False)
    else begin
      Result := UIActivate(False);
      Control.Visible := False;
    end;
  except
    Result := E_UNEXPECTED;
  end;
end;

function TActiveDocServer.UIActivate(fUIActivate: BOOL): HResult;
begin
  try
    Result := S_OK;
    if fUIActivate then
    begin
      if InPlaceSite <> nil then
        InPlaceActivate(True)
      else Result := E_UNEXPECTED;
    end else
      UIDeactivate;
  except
    Result := E_UNEXPECTED;
  end;
end;

{ TActiveDocServerFactory }

constructor TActiveDocServerFactory.Create(ComServer: TComServerObject;
  ActiveXDocClass: TActiveDocServerClass;
  const ClassID: TGUID; FileExtension, MimeType, OleHandler: string;
  ToolboxBitmapID, MiscStatus, DocMiscStatus: Integer;
  ThreadingModel: TThreadingModel);
begin
  FDocMiscStatus := DocMiscStatus;
  FFileExtension := FileExtension;
  FMimeType := MimeType;
  if OleHandler <> '' then
    FHandler := OleHandler
  else FHandler := 'ole32.dll';

  inherited Create(ComServer, ActiveXDocClass, TPanel, ClassId,
    ToolboxBitmapID, '', MiscStatus, ThreadingModel);
end;

function TActiveDocServerFactory.GetFileExtension: string;
begin
  Result := FFileExtension;
  if (Result <> '') and (Result[1] <> '.') then
    Result := '.' + Result;
end;

procedure TActiveDocServerFactory.UpdateDownloadClasses(Register: Boolean);
var ClassesKey: string;
    Reg: TRegistry;
    EditData: DWORD;
begin
  // Prevents the "Some files can harm your computer message"
  // for this particular program ID.
  
  ClassesKey := '\SOFTWARE\Classes\' + ProgID;
  if Register then
  begin
    Reg := TRegistry.Create;
    with Reg do
    try
      RootKey := HKEY_LOCAL_MACHINE;
      if OpenKey(ClassesKey, True) then
      begin
        EditData := $10000;
        WriteBinaryData('EditFlags', EditData, 4);
      end;
    finally
      Reg.Free;
    end;
  end;
end;

procedure TActiveDocServerFactory.UpdateFileExtensions(Register: Boolean);
var ExtKey: string;
begin
  if FFileExtension <> '' then
  begin
    ExtKey := GetFileExtension;
    if Register then
    begin
      CreateRegKey(ExtKey, '', ProgID);
      if FMimeType <> '' then
        CreateRegKey(ExtKey, 'Content Type', FMimeType);
    end else
      DeleteRegKey(ExtKey);
  end;
end;

procedure TActiveDocServerFactory.UpdateMimeDatabase(Register: Boolean);
var MimeKey: string;
    Extension: string;
begin
  if (FMimeType <> '') and (FFileExtension <> '') then
  begin
    MimeKey := 'MIME\Database\Content Type\' + FMimeType;
    if Register then
    begin
      Extension := GetFileExtension;
      if Extension <> '' then
        CreateRegKey(MimeKey, 'Extension', Extension);
      CreateRegKey(MimeKey, 'CLSID', GuidToString(ClassID));
    end else
      DeleteRegKey(MimeKey);
  end;
end;

procedure TActiveDocServerFactory.UpdateRegistry(Register: Boolean);
var ClassKey: string;
    ProgIdKey: string;
begin
  ClassKey := 'CLSID\' + GUIDToString(ClassID) + '\';
  ProgIdKey := ProgID + '\';
  if Register then
  begin
    inherited;
    CreateRegKey(ClassKey + 'DocObject', '', '8');
    CreateRegKey(ClassKey + 'Programmable', '', '');
    CreateRegKey(ClassKey + 'Insertable', '', '');
    CreateRegKey(ClassKey + 'InprocHandler32', '', FHandler);
    CreateRegKey(ProgIdKey + 'DocObject', '', IntToStr(DocMiscStatus));
    CreateRegKey(ProgIdKey + 'Insertable', '', '');

    // Need to remove "control" key added by inherited method
    DeleteRegKey(ClassKey + 'Control');
  end else begin
    DeleteRegKey(ClassKey + 'DefaultExtension');
    DeleteRegKey(ClassKey + 'DefaultIcon');
    DeleteRegKey(ClassKey + 'DocObject');
    DeleteRegKey(ClassKey + 'Programmable');
    DeleteRegKey(ClassKey + 'Insertable');
    DeleteRegKey(ClassKey + 'InprocHandler32');
    DeleteRegKey(ProgIdKey + 'DocObject');
    DeleteRegKey(ProgIdKey + 'Insertable');
    inherited;
  end;
  UpdateFileExtensions(Register);
  UpdateMimeDatabase(Register);
  UpdateDownloadClasses(Register);
end;

end.