== Developing a Noah Fitting Module == == Noah 2.0 Fitting Module == === Module Installation === * Internal Setup Program: Registering the module using the Moduleinstall.ocx Component. (Required) ==== Internal Setup Program ==== The installation is performed from within the Noah System * From within NOAH 2.0: ** Select from menu: Setup > Install Module ** Type the drive and folder name (full path) where the files are. For example: ''D:\'' * From within NOAH 3.0: ** Select from menu: Tools > Setup > Install Module ** Press button: < Install New Module > ** Find and select installer in folder where the files are: For example: ''D:\install.ini'' ** Click on < Finish > button to finish the installation. ** Click on < Ok > when the dialog "Click OK when module installation is complete" shows up. The module developer only needs to refer to the ''setup.exe''. For example, NOAHAud3’s ''install.ini'' has just two lines: [Installation] InstallCmd2=setup.exe ===== Installation of the Accessibility layer ===== Source: //NOAH 2.0 32-bit Accessibility Layer Installation//, NOAH 3.0 SDK, HIMSA. The NOAH16.exe and Online32.exe must be installed, if your Module uses the 32-bit Accessibility Layer. If your module is not using the NOAHvb.ocx then it is not necessary to install it. Check the registry to see if the NOAH16.exe, the Online32.exe and the NOAHvb.ocx have already been installed. If the components are already installed: * Check the registry to see where the components have been installed * Check the version of the components, if a more recent version exists then upgrade the components * When upgrading one or all of the components install the components in same path as the existing components * Do not assume that the components are installed in a certain path * Do not uninstall any of the components * Do not move any of the existing components * Do not downgrade the existing version of the components * Do not install any of the three components as shared If the two components are not already installed. This is only the case when NOAH 3 in not installed, and no modules using the Accessibility Layer has previously been installed. * Install the NOAH16.exe and the Online32.exe * Register the two components in the registry If your module uses the NOAHvb.ocx * Install or upgrade the two runtime DLLs msvcrt.dll and mfc42.dll prior to installing the NOAHvb.ocx. Please note that these two DLLs could be used by other applications when your installation is launched. This will prevent you from upgrading the DLL’s immediately. The usual approach is to delay the upgrade until the next boot of the system. ===== How to check the registry ===== In order to find out if the Wrapper components have already been installed or where they have been installed, then you will need to check the registry: To find the entries in registry the Prog. ID’s are found in ''HKEY_CLASSES_ROOT''. The Prog. ID’s have a CLSID. In ''HKEY_CLASSES_ROOT\CLSID\//{class ID for component}//'' you find the ''LocalServer'', ''LocalServer32'', ''InprocServer32'' paths respectively. The Prog. ID’s to look for are: HKEY_CLASSES_ROOT\Noah16.ModuleIF HKEY_CLASSES_ROOT\OnLine32.OnLine HKEY_CLASSES_ROOT\NOAHVB.NoahVBCtrl == Noah 3.0 Fitting Module == === Module Installation === Installation types: * External Setup Program: Registering the program using the module’s own Setup Program. (Required) * Internal Setup Program: Registering the module using the Moduleinstall.ocx Component. (Optional) ==== External Setup Program ==== The module developer must program his own module setup program (for example, ''Setup.exe'') to register module data with the //Module Installation Server// component. * Import Type Library: ** Open Delphi and create a new project. ** Select Project > Import Type Library. ** Select "ModuleInstallationServer 1.0 Type Library (Version 1.0)" ** Palette Name: Noah ** Unit dir name: ''C:\Program Files\Borland\Delphi7\Imports\'' ** Check "Generate Component Wrapper". ** Press < Install > button. * Place object ModuleInstServer1 (an instance of TModuleInstServer) on the project's main form. * Create an Installation routine in the main form. unit main; interface uses Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms, Dialogs, ComCtrls, StdCtrls, OleCtrls, ModuleInstallationServer_TLB; type TfrmMain = class(TForm) btnInstall: TButton; btnUninstall: TButton; StatusBar1: TStatusBar; ModuleInstServer1: TModuleInstServer; procedure FormActivate(Sender: TObject); procedure btnInstallClick(Sender: TObject); procedure btnUninstallClick(Sender: TObject); private { Private declarations } public { Public declarations } end; var frmMain: TfrmMain; implementation {$R *.dfm} procedure TfrmMain.FormActivate(Sender: TObject); begin ModuleInstServer1.Initialize(); end; //------------------------------------------------------------------------------ //{* // @section procbtnInstallClick Procedure: btnInstallClick // @brief // @param[in] Sender: TObject // @retval None // @remarks Rev.History: // - smayr 2007-Aug-31, Routine creation. // //------------------------------------------------------------------------------ procedure TfrmMain.btnInstallClick(Sender: TObject); begin var oMod: Module; oDTs: DataTypes; oDT: DataType; oProts: Protocols; oProt: Protocol; oSub: SubModule; begin try // create objects oMod := CoModule.Create(); oDTs := CoDataTypes.Create(); oDT := CoDataType.Create(); oProts := CoProtocols.Create(); oProt := CoProtocol.Create(); oSub := CoSubModule.Create(); try // Set datatype that the module can make/show oDT.Code := 1; oDT.Format := 100; // Add datatype to collection oDTs.Add(oDT); // Set on-line protocol and related datatype that the module supports oProt.DataTypes := oDTs; oProt.Number := 1; oProts.Add(oProt); // Set submodule oSub.LocalID := 1; oSub.ManufacturerID := 044; // 044=Audina, 1=HIMSA; oMod.CanMake := oDTs; oMod.CanShow := oDTs; // ClassID of the module. Remember that the module must also have a valid ProgID entry. oMod.CLSID := '{444DA45F-3BE7-11D1-BAD1-07704FC9C2B9}'; oMod.HelpPath := 'C:\Program Files\HIMSA\NOAH System\HIMSA\Modules\Fitting\044\FITTING.HLP'; //oMod.KeyName := 'NoKey'; oMod.LocalID := 2; // Manufacturer's internal Local Module Identifier oMod.LogoDLLPath := 'C:\Program Files\HIMSA\NOAH System\HIMSA\Modules\Fitting\044\Logo044.dll'; // logo.dll oMod.ManufacturerID := 044; // 044=Audina, 1=HIMSA; oMod.Name := 'The AudinaTestManuf Module'; // module name oMod.Protocols := oProts; // protocols used in Inter-module Communication (IMC) oMod.Show := True; // Set the module category using the ModuleInstallationServer collection of ModuleCategories oMod.Category := ModuleInstServer1.ModuleCategories.Item[1]; oMod.SubModules.Add(oSub); ModuleInstServer1.InstallModule('AudinaTestManuf', oMod); except on E:Exception do begin ShowMessage('Error: '{+ IntToStr(Err.Number)} + ' ' + E.ClassName + ' ' + E.Message); end; end; finally // destroy objects (in reverse order) oSub := nil; oProt := nil; oProts := nil; oDT := nil; oDTs := nil; oMod := nil; end; end; procedure TfrmMain.btnUninstallClick(Sender: TObject); begin try ModuleInstServer1.UninstallModule(044 {ManufCode assigned by HIMSA}, 2 {ModuleCode assigned by Manuf}); except on E:Exception do begin ShowMessage('Error: '+ E.ClassName + ' ' + E.Message); end; end; end; end. ==== Internal Setup Program ==== The installation is performed from within the Noah System * From within NOAH 2.0: ** Select from menu: Setup > Install Module ** Type the drive and folder name (full path) where the files are. For example: ''D:\'' * From within NOAH 3.0: ** Select from menu: Tools > Setup > Install Module ** Press button: < Install New Module > ** Find and select installer in folder where the files are: For example: ''D:\install.ini'' ** Click on < Finish > button to finish the installation. ** Click on < Ok > when the dialog "Click OK when module installation is complete" shows up. The module developer only needs to refer to the ''setup.exe''. For example, NOAHAud3’s ''install.ini'' has just two lines: [Installation] InstallCmd2=setup.exe ==== Registry Keys ==== Once a NOAH 2.0 fitting module has been installed and registered in NOAH 3.0, these are the registry entries related to that module: Windows Registry Editor Version 5.00 [HKEY_LOCAL_MACHINE\SOFTWARE\HIMSA\NOAH\Version 3.0\Modules\Audina Hearing Instruments] "ID"=dword:0000002c [HKEY_LOCAL_MACHINE\SOFTWARE\HIMSA\NOAH\Version 3.0\Modules\Audina Hearing Instruments\Module 44] "Name"="Audina" "Show"=hex:01 "Category"=dword:00000000 "ButtonDLLPath"="C:\\Program Files\\HIMSA\\Modules\\Fitting\\044\\Logo044.DLL" "ID"=dword:0000002c "CLSID"="C:\\Program Files\\HIMSA\\Modules\\Fitting\\044\\Fit044WM.exe" "InstalledDate"=hex:94,49,aa,b5,72,33,e3,40 "HelpPath"="C:\\Program Files\\HIMSA\\Modules\\Fitting\\044\\FITTING.HLP" "ActionMake"=hex:81,00,64,00,82,00,64,00,83,00,64,00,84,00,64,00,85,00,64,00 "ActionShow"=hex:81,00,64,00,82,00,64,00,83,00,64,00,84,00,64,00,85,00,64,00 === Module Creation === ==== Create Noah Components ==== Create Noah Components in Delphi for use in a Fitting Module by creating a project: * Create a component project folder. * Create a new Package (File > New > Other > Package (under New tab). * Import ActiveX Components (click on Add icon, select Import ActiveX tab). ** Select the required Noah components to import (see list). ** Class Names: Rename each class names by adding a prefix to keep class names unique (eg. TModuleServer --> TNhModuleServer, TSession --> TNhSession). ** Palette Name: ''Noah'' ** Unit Dir Name: //(point to project folder)// ** Add. * Save and Build project, then Install components to the palette. ====== Required ActiveX Components (or Type Libraries) to import ====== * HimsaIMCClientCtrlLib: for Inter-process Communication in module development. * HimsaIMCServerCtrlLib: N/A. * IMCLib: for Inter-process Communication in module development. * ModuleInstallationServer: for external module installation. * ModuleServer: for module development. * NoahActiveDocContainerLib: for module container. ====== Optional ActiveX Components (or Type Libraries) ====== Other possible NOAH Type Libraries to import: db_tester DBEVentServer DH1030 DH1031 DH1033 DH1035 DH1036 DH1038 DH1040 DH1041 DH1043 DH1044 DH1045 DH1046 DH1049 DH1053 DH2052 DH2055 DH2057 DH2064 DH2070 DH3081 DH3082 DH3084 DH4105 DH4108 DH5129 FittingDataTrans HimsaGeneralError HIMSAIMCClientCtrl HIMSAIMCServerCtrl HIPAACryptation HIPAALib HitPrn2 imc IMCLegacyClient IMCLegacyServer JournalPrintHandler ActiveX Control module LegacyHost LegacyIMCHost LegacyPrintHandler LocaleBase Module Selection component presents logos for install modules ModuleInstallation ModuleInstallationServer ModuleServer MSProxy NoahActiveDocContainer NOAHAudiogram32 NOAHAudiogramC NOAHAudReport NoahBasicInterfaces NoahClient NoahCom NoahDatabase NoahDatabaseSchedulerSetup ActiveX Control module NoahDatabaseTools NoahDbHelper NoahExtReport NoahFitPrintHdl NOAHFitting NoahGlobalObjects NoahLegacyConverter NOAHLicenseServer NoahProxy32 NOAHRemHitConverter NoahReportGracphis ActiveX Control module NoahServer NoahUtil NoahVB ActiveX Control module NoahVersion OfficeServer OnLine32 OSPrintProxy RainierChart Sample VB module for VB ScriptHost SessionBrowser ActiveX Control module VBPrintHelper ==== Create Active Document Container ==== The fitting module consists of an container (an Active Document Server, found in the form of an ActiveX component called "Noah Active Document Container") which will have the actual form (Active Document Server, in Delphi called Active Form). To create the Active Document Container (ADC), perform the following steps: * Install the type library NoahActiveDocContainer (see Importing Type Libraries, above). * Create a Delphi project. * Place a NoahModuleContainerCtrl object on the form. * Add code to initalize and launch the module. Example: unit main; interface uses Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms, Dialogs, IMCLib_TLB, NOAHACTIVEDOCCONTAINERLib_TLB, OleServer, OleCtrls, StdCtrls; type TfrmMain = class(TForm) NhModContainer: TNoahModuleContainerCtrl; btnLaunchMod: TButton; NhFrame1: TNhFrame; procedure FormCreate(Sender: TObject); procedure btnLaunchModClick(Sender: TObject); private { Private declarations } public { Public declarations } procedure LaunchModule(ModProgId: string); end; function DataToVariant(const Data; Len: integer): Variant; procedure DebugStr(str: string); var frmMain: TfrmMain; implementation {$R *.dfm} //------------------------------------------------------------------------------ procedure TfrmMain.FormCreate(Sender: TObject); //var // ModProgID: string; begin // ModProgID := '{DB12A360-C57D-43A5-8BB9-23CDB46808E4}'; // LaunchModule(ModProgID); end; //------------------------------------------------------------------------------ procedure TfrmMain.btnLaunchModClick(Sender: TObject); var ModProgID: string; begin //ModProgID := 'GenericServer.Document'; //'{DB12A360-C57D-43A5-8BB9-23CDB46808E4}'; //ModProgID := 'Word.Basic'; //'{DB12A360-C57D-43A5-8BB9-23CDB46808E4}'; ModProgID := 'UnitSvr.AreaUnitConverter'; DebugStr('LaunchModule(): Ready to Launch Module = ' + ModProgID); LaunchModule(ModProgID); DebugStr('LaunchModule(): Finished launching module'); end; //------------------------------------------------------------------------------ procedure TfrmMain.LaunchModule(ModProgId: string); var MenuWidth: array [0..2] of integer; MenuTitles: array [0..2] of shortstring; MenuIdx: array [0..2] of integer; vMenuWidth: OleVariant; vMenuTitles: OleVariant; vMenuIdx: OleVariant; begin MenuWidth[0] := 1; // file menu group MenuWidth[1] := 0; // application menu group MenuWidth[2] := 1; // window menu group vMenuWidth := DataToVariant(MenuWidth, Sizeof(integer)*3); DebugStr('LaunchModule(): Size MenuWidth = ' + IntToStr(Sizeof(MenuWidth))); // there are two menus in the application MenuTitles[0] := '&File'; MenuTitles[1] := '&WindowsMenu'; vMenuTitles := DataToVariant(MenuTitles, Sizeof(MenuTitles)); DebugStr('LaunchModule(): Size MenuTitles = ' + IntToStr(Sizeof(MenuTitles))); MenuIdx[0] := -1; // no application menus MenuIdx[1] := 3; // window menu has position 1 MenuIdx[2] := 4; // helpmenu has position 2 vMenuIdx := DataToVariant(MenuIdx, Sizeof(integer)*3); DebugStr('LaunchModule(): Size MenuIdx = ' + IntToStr(Sizeof(MenuIdx))); try NhModContainer.launch(vMenuWidth, vMenuTitles, vMenuIdx, ModProgID, 'NOAH 3.0'); //NhFrame1.launch(ModProgID, 'Noah Active Document Container'); except on E:Exception do begin DebugStr('LaunchModule(): Error ' + E.ClassName + ' ' + E.Message); ShowMessage('LaunchModule(): Error ' + E.ClassName + ' ' + E.Message); end; end; end; //------------------------------------------------------------------------------ {* // @section procDataToVariant Procedure: DataToVariant // @brief // @param[in] const Data; Len: integer // @retval Variant // @remarks Rev.History: // - smayr 2007-Sep-27, Routine creation. } //------------------------------------------------------------------------------ function DataToVariant(const Data; Len: integer): Variant; var p: pByte; begin Result := VarArrayCreate([0,len-1], varByte); p := VarArrayLock(Result); try move(Data, p^, Len); finally VarArrayUnLock(Result); end; end; //------------------------------------------------------------------------------ procedure DebugStr(str: string); begin OutputDebugString(PChar(str)); end; end. ===== Parent vs ParentWindow ===== From Delphi User Documentation: (("ParentWindow property (TWinControl)", Delphi Help, Borland)) ParentWindow refers to the window handle that underlies the parent control. To designate a non-VCL control as a parent, assign that control’s handle to ParentWindow. This assignment causes the control to be moved into the parent’s screen area. Setting ParentWindow has no effect if Parent is not nil (Delphi) or NULL (C++). TActiveXControl objects use ParentWindow to insert a control in an ActiveX container window. ParentWindow is set automatically when a control is constructed with a call to CreateParented (Delphi) or the appropriate overloaded constructor (C++). Some controls (such as ActiveX controls) are contained in native windows rather than in a parent VCL control. For these controls, the value of Parent is nil (Delphi) or NULL (C++) and the ParentWindow property specifies the window. (("Parent property (TControl)", Delphi Help, Borland)) ==== Create Active Document Server ==== The actual work of the module is done by an Active Document Server (ADS). This ADS will be contained and launched by the Noah Module Container (Active Document Container). Perform the following steps to create this ADS: 1. Hide the main form when started via automation. In the project file, add the line ''Application.ShowMainForm := (ComServer.StartMode = smStandAlone);'' before the creation of the forms. For example (N3Module.dpr): program N3Module; uses ComServ, Forms, DAXDocLib_TLB in 'DAXDocLib_TLB.pas', Main in 'Main.pas' {DAXDocSvr: CoClass}, MainForm in 'MainForm.pas' {frmMain}, AxCtrls in 'AxCtrls.pas', AxDocs in 'AxDocs.pas', dlgIMCSvrSel in 'dlgIMCSvrSel.pas' {dlgIMCServerSelection}; {$R *.TLB} {$R *.RES} begin Application.Initialize; // Don't show main form when started via automation Application.ShowMainForm := (ComServer.StartMode = smStandAlone); Application.CreateForm(TfrmMain, frmMain); Application.CreateForm(TdlgIMCServerSelection, dlgIMCServerSelection); Application.Run; end. 2. Make the form fit inside the module container window. For example (FormMain.pas): procedure TfrmMain.FormActivate(Sender: TObject); begin if Application.ShowMainForm = False then begin ShowWindow(Application.Handle, SW_HIDE); // hide application from Windows taskbar self.BorderStyle := bsNone; // no borders self.Align := alClient; // maximize inside Noah module container end; end; 3. Create and initialize ActiveX Document. For example (main.pas): unit Main; interface uses ComObj, ActiveX, AxDocs, Menus, ComCtrls, DAXDocLib_TLB, StdVcl; type TDAXDocSvr = class(TActiveXDocument, IDAXDocSvr, IPersistStreamInit) private FItem: TMenuItem; FSubItem: TMenuItem; protected { IPersistStreamInit } function IPersistStreamInit.Load = PersistStreamLoad; function IPersistStreamInit.Save = PersistStreamSave; function IsDirty: HResult; stdcall; public destructor Destroy; override; procedure DoMenuClick(Sender: TObject); procedure Initialize; override; end; implementation uses ComServ, StdCtrls, MainForm, AxCtrls, Windows, Dialogs; { TDelphiAxDoc } destructor TDAXDocSvr.Destroy; begin inherited Destroy; FSubItem.Free; FItem.Free; end; procedure TDAXDocSvr.DoMenuClick(Sender: TObject); begin // with TColorDialog.Create(nil) do // begin // if Execute then (Control as TMemo).Color := Color; // Free; // end; end; procedure TDAXDocSvr.Initialize; begin inherited Initialize; FItem := NewItem('&Change color', 0, False, True, DoMenuClick, 0, 'ColorItem'); FSubItem := NewSubMenu('&Edit', 0, 'EditItem', [FItem]); Menu := NewMenu(Control, 'MainMenu', [FSubItem]); end; { TDelphiAxDoc.IPersistStreamInit } function TDAXDocSvr.IsDirty: HResult; begin // if (Control as TMemo).Modified then Result := S_OK // else Result := S_FALSE; result := S_FALSE; end; initialization TActiveXDocumentFactory.Create( ComServer {ComServerObject}, TDAXDocSvr {ActiveXDocClass}, TfrmMain {WinCtrlClass}, CLASS_DAXDocSvr {ClassID}, 0 {ToolBoxBitmapID}, 131473 {MiscStatus}, tmApartment {ThreadingModel}, '' {Handler. If empty, then 'ole32.dll'}, 8 {DOCMISC_NOFILESUPPORT} {DocMiscStatus} ); finalization end. 4. Create a Type Library for the ActiveX Document Server. For example (DAXDocLib_TLB.pas): unit DAXDocLib_TLB; // ************************************************************************ // // WARNING // ------- // The types declared in this file were generated from data read from a // Type Library. If this type library is explicitly or indirectly (via // another type library referring to this type library) re-imported, or the // 'Refresh' command of the Type Library Editor activated while editing the // Type Library, the contents of this file will be regenerated and all // manual modifications will be lost. // ************************************************************************ // // PASTLWTR : 1.2 // File generated on 10/2/2007 9:05:47 AM from Type Library described below. // ************************************************************************ // // Type Lib: D:\proj\ezFITNoah-Nh3Native\DAXDocSvr-N3Module\N3Module.tlb (1) // LIBID: {1C76ACA2-F8F8-42F6-9C11-04C441289BAD} // LCID: 0 // Helpfile: // HelpString: Delphi ActiveX Document Server for Noah 3.0 Module // DepndLst: // (1) v2.0 stdole, (C:\WINDOWS\system32\stdole2.tlb) // ************************************************************************ // {$TYPEDADDRESS OFF} // Unit must be compiled without type-checked pointers. {$WARN SYMBOL_PLATFORM OFF} {$WRITEABLECONST ON} {$VARPROPSETTER ON} interface uses Windows, ActiveX, Classes, Graphics, StdVCL, Variants; // *********************************************************************// // GUIDS declared in the TypeLibrary. Following prefixes are used: // Type Libraries : LIBID_xxxx // CoClasses : CLASS_xxxx // DISPInterfaces : DIID_xxxx // Non-DISP interfaces: IID_xxxx // *********************************************************************// const // TypeLibrary Major and minor versions DAXDocLibMajorVersion = 1; DAXDocLibMinorVersion = 0; LIBID_DAXDocLib: TGUID = '{1C76ACA2-F8F8-42F6-9C11-04C441289BAD}'; IID_IDAXDocSvr: TGUID = '{A0C777B2-1731-4869-8570-DC4D2D722000}'; CLASS_DAXDocSvr: TGUID = '{0E83087B-76E9-48D2-8285-9F72AD4C56AC}'; type // *********************************************************************// // Forward declaration of types defined in TypeLibrary // *********************************************************************// IDAXDocSvr = interface; IDAXDocSvrDisp = dispinterface; // *********************************************************************// // Declaration of CoClasses defined in Type Library // (NOTE: Here we map each CoClass to its Default Interface) // *********************************************************************// DAXDocSvr = IDAXDocSvr; // *********************************************************************// // Interface: IDAXDocSvr // Flags: (4416) Dual OleAutomation Dispatchable // GUID: {A0C777B2-1731-4869-8570-DC4D2D722000} // *********************************************************************// IDAXDocSvr = interface(IDispatch) ['{A0C777B2-1731-4869-8570-DC4D2D722000}'] end; // *********************************************************************// // DispIntf: IDAXDocSvrDisp // Flags: (4416) Dual OleAutomation Dispatchable // GUID: {A0C777B2-1731-4869-8570-DC4D2D722000} // *********************************************************************// IDAXDocSvrDisp = dispinterface ['{A0C777B2-1731-4869-8570-DC4D2D722000}'] end; // *********************************************************************// // The Class CoDAXDocSvr provides a Create and CreateRemote method to // create instances of the default interface IDAXDocSvr exposed by // the CoClass DAXDocSvr. The functions are intended to be used by // clients wishing to automate the CoClass objects exposed by the // server of this typelibrary. // *********************************************************************// CoDAXDocSvr = class class function Create: IDAXDocSvr; class function CreateRemote(const MachineName: string): IDAXDocSvr; end; implementation uses ComObj; class function CoDAXDocSvr.Create: IDAXDocSvr; begin Result := CreateComObject(CLASS_DAXDocSvr) as IDAXDocSvr; end; class function CoDAXDocSvr.CreateRemote(const MachineName: string): IDAXDocSvr; begin Result := CreateRemoteComObject(MachineName, CLASS_DAXDocSvr) as IDAXDocSvr; end; end. 5. Include the ActiveX Document Support Unit ''AxDocs.pas'' (Author: Steve Teixeira) in the project. Here is the listing: {*******************************************************} { } { ActiveX Document Support Unit } { Copyright (c) 1999, Steve Teixeira } { } {*******************************************************} unit AxDocs; interface uses Windows, ComObj, ActiveX, AxCtrls, Controls, Classes, Menus, Messages, Variants; type TActiveXDocumentFactory = class; TActiveXDocument = class(TActiveXControl, IOleDocument, IOleDocumentView, IOleInPlaceActiveObject, IOleInPlaceObject) private FFactory: TActiveXDocumentFactory; FMenu: TMainMenu; FOleMenu: HMENU; FSharedMenu: HMENU; function GetAncestorValueByField(FieldNum: Cardinal): Cardinal; procedure SetAncestorValueByField(FieldNum, Value: Cardinal); function GetOleInPlaceSite: IOleInPlaceSite; procedure SetOleInPlaceSite(const Value: IOleInPlaceSite); procedure InPlaceMenuCreate; procedure InPlaceMenuDestroy; procedure MergeMenus(SharedMenu, SourceMenu: HMENU; MenuWidths: PInteger; WidthIndex: Integer); procedure UnmergeMenus(SharedMenu, SourceMenu: HMENU); protected { IOleDocument methods } 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 methods } 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; { IOleInPlaceActiveObject } function OnDocWindowActivate(fActivate: BOOL): HResult; stdcall; { IOleInPlaceObject } function InPlaceDeactivate: HResult; stdcall; { Overrides } procedure GetDocUIInfo(var Menu: TMainMenu); function InPlaceActivate(ActivateUI: Boolean): HResult; override; procedure WndProc(var Message: TMessage); override; public procedure Initialize; override; function ObjQueryInterface(const IID: TGUID; out Obj): HResult; override; property Menu: TMainMenu read FMenu write FMenu; property OleInPlaceSite: IOleInPlaceSite read GetOleInPlaceSite write SetOleInPlaceSite; end; TActiveXDocClass = class of TActiveXDocument; TActiveXDocumentFactory = class(TActiveXControlFactory) private FDocMiscStatus: DWORD; FHandler: string; public property DocMiscStatus: DWORD read FDocMiscStatus; constructor Create(ComServer: TComServerObject; ActiveXDocClass: TActiveXDocClass; WinControlClass: TWinControlClass; const ClassID: TGUID; ToolboxBitmapID, MiscStatus: Integer; ThreadingModel: TThreadingModel; const Handler: string; DocMiscStatus: DWORD); procedure UpdateRegistry(Register: Boolean); override; end; implementation uses ComServ, SysUtils, Forms; { TActiveXDocument } function TActiveXDocument.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 TActiveXDocument.GetOleInPlaceSite: IOleInPlaceSite; begin // Work around fact that FOleInPlaceSite is private in TActiveXControl // Note: this work around only guaranteed to work in Delphi 4 Result := IOleInPlaceSite(GetAncestorValueByField(9)); end; procedure TActiveXDocument.SetOleInPlaceSite(const Value: IOleInPlaceSite); begin // Work around fact that FOleInPlaceSite is private in TActiveXControl // Note: this work around only guaranteed to work in Delphi 4 SetAncestorValueByField(9, Cardinal(Value)); end; function TActiveXDocument.GetAncestorValueByField(FieldNum: Cardinal): Cardinal; var ParentInstanceSize, Ofs: Cardinal; begin // Nasty hack: this method returns the value of a particular field in the // ancestor class, with the assumption that the given field and all prior // fields are 4 bytes in size. ParentInstanceSize := ClassParent.ClassParent.InstanceSize; Ofs := ParentInstanceSize + ((FieldNum - 1) * 4); asm mov eax, Self add eax, Ofs mov eax, dword ptr [eax] mov @Result, eax end; end; procedure TActiveXDocument.SetAncestorValueByField(FieldNum, Value: Cardinal); var ParentInstanceSize, Ofs: Cardinal; begin // Nasty hack: this method sets the value of a particular field in the // ancestor class, with the assumption that the given field and all prior // fields are 4 bytes in size. ParentInstanceSize := ClassParent.ClassParent.InstanceSize; Ofs := ParentInstanceSize + ((FieldNum - 1) * 4); asm mov eax, Self add eax, Ofs mov ecx, Value mov dword ptr [eax], ecx end; end; procedure TActiveXDocument.Initialize; begin inherited Initialize; FFactory := Factory as TActiveXDocumentFactory; end; procedure TActiveXDocument.GetDocUIInfo(var Menu: TMainMenu); begin Menu := nil; end; function TActiveXDocument.InPlaceActivate(ActivateUI: Boolean): HResult; begin Result := inherited InPlaceActivate(ActivateUI); InPlaceMenuCreate; end; procedure TActiveXDocument.WndProc(var Message: TMessage); begin inherited WndProc(Message); if Message.Msg = WM_LBUTTONDBLCLK then InPlaceActivate(True); end; procedure TActiveXDocument.InPlaceMenuCreate; var IPFrame: IOleInPlaceFrame; IPSite: IOleInPlaceSite; IPUIWindow: IOleInPlaceUIWindow; omgw: TOleMenuGroupWidths; FrameInfo: TOleInPlaceFrameInfo; PosRect, ClipRect: TRect; begin OleCheck(ClientSite.QueryInterface(IOleInPlaceSite, IPSite)); FrameInfo.cb := sizeof(FrameInfo); IPSite.GetWindowContext(IPFrame, IPUIWindow, PosRect, ClipRect, FrameInfo); FillChar(omgw, SizeOf(omgw), 0); omgw.width[1] := 1; // Create a blank menu and ask the container to add it's menus into the // TOleMenuGroupWidths record FSharedMenu := CreateMenu; try OleCheck(IPFrame.InsertMenus(FSharedMenu, omgw)); if FMenu = nil then Exit; MergeMenus(FSharedMenu, FMenu.Handle, @omgw.width, 1); // Send the menu to the client FOleMenu := OleCreateMenuDescriptor(FSharedMenu, omgw); IPFrame.SetMenu(FSharedMenu, FOleMenu, Control.Handle); except DestroyMenu(FSharedMenu); FSharedMenu := 0; raise; end; end; procedure TActiveXDocument.InPlaceMenuDestroy; var IPFrame: IOleInPlaceFrame; IPSite: IOleInPlaceSite; IPUIWindow: IOleInPlaceUIWindow; FrameInfo: TOleInPlaceFrameInfo; PosRect, ClipRect: TRect; begin // Get the clients IOleInPlaceFrame so we can ask it to remove it's menu OleCheck(ClientSite.QueryInterface(IOleInPlaceSite, IPSite)); FrameInfo.cb := sizeof(FrameInfo); IPSite.GetWindowContext(IPFrame, IPUIWindow, PosRect, ClipRect, FrameInfo); if IPFrame <> nil then IPFrame.SetMenu(0, 0, 0); OleDestroyMenuDescriptor(FOleMenu); FOleMenu := 0; UnmergeMenus(FSharedMenu, FMenu.Handle); end; type PIntArray = ^TIntArray; TIntArray = array[0..0] of Integer; procedure TActiveXDocument.MergeMenus(SharedMenu, SourceMenu: HMENU; MenuWidths: PInteger; WidthIndex: Integer); var MenuItems, GroupWidth, Position, I, Len: Integer; MenuState: UINT; PopupMenu: HMENU; ItemText: array[0..255] of char; begin // Copy the popups from the pMenuSource MenuItems := GetMenuItemCount(SourceMenu); GroupWidth := 0; Position := 0; // Insert at appropriate spot depending on WidthIndex if (WidthIndex < 0) or (WidthIndex > 1) then Exit; if WidthIndex = 1 then Position := MenuWidths^; for I := 0 to MenuItems - 1 do begin // Get the HMENU of the popup PopupMenu := GetSubMenu(SourceMenu, I); // Separators move us to next group MenuState := GetMenuState(SourceMenu, I, MF_BYPOSITION); if (PopupMenu = NULL) and ((MenuState and MF_SEPARATOR) <> 0) then begin if WidthIndex > 5 then Exit; // Servers should not touch past 5 PIntArray(MenuWidths)^[WidthIndex] := GroupWidth; GroupWidth := 0; if WidthIndex < 5 then Inc(Position, PIntArray(MenuWidths)^[WidthIndex + 1]); Inc(WidthIndex, 2); end else begin // Get the menu item text Len := GetMenuString(SourceMenu, I, ItemText, SizeOf(ItemText), MF_BYPOSITION); // Popups are handled differently than normal menu items if PopupMenu <> 0 then begin if GetMenuItemCount(PopupMenu) <> 0 then begin // Strip the HIBYTE because it contains a count of items MenuState := LoByte(MenuState) or MF_POPUP; // Must be popup // Non-empty popup -- add it to the shared menu bar InsertMenu(SharedMenu, Position, MenuState or MF_BYPOSITION, PopupMenu, ItemText); Inc(Position); Inc(GroupWidth); end; end else if Len > 0 then begin // only non-empty items are added if ItemText <> '' then begin // here the state does not contain a count in the HIBYTE InsertMenu(SharedMenu, Position, MenuState or MF_BYPOSITION, GetMenuItemID(SourceMenu, I), ItemText); Inc(Position); Inc(GroupWidth); end; end; end; end; end; procedure TActiveXDocument.UnmergeMenus(SharedMenu, SourceMenu: HMENU); var TheseItems, MenuItems, I, J: Integer; PopupMenu: HMENU; begin MenuItems := GetMenuItemCount(SharedMenu); TheseItems := GetMenuItemCount(SourceMenu); for I := MenuItems - 1 downto 0 do begin // Check the popup menus PopupMenu := GetSubMenu(SharedMenu, I); if PopupMenu <> 0 then begin // If it is one of ours, remove it from the SharedMenu for J := 0 to TheseItems - 1 do begin if GetSubMenu(SourceMenu, J) = PopupMenu then begin // Remove the menu from SharedMenu RemoveMenu(SharedMenu, I, MF_BYPOSITION); Break; end; end; end; end; end; { TActiveXDocument.IOleDocument } function TActiveXDocument.CreateView(Site: IOleInPlaceSite; Stream: IStream; rsrvd: DWORD; out View: IOleDocumentView): HResult; var OleDocView: IOleDocumentView; begin Result := S_OK; try if View = nil then begin Result := E_POINTER; Exit; end; OleDocView := Self as IOleDocumentView; if (OleInPlaceSite = nil) or (OleDocView = nil) then begin Result := E_FAIL; Exit; end; // Use site provided if Site <> nil then OleDocView.SetInPlaceSite(Site); // Use stream provided for initialization if Stream <> nil then OleDocView.ApplyViewState(Stream); // Return the view View := OleDocView; except Result := E_FAIL; end; end; function TActiveXDocument.EnumViews(out Enum: IEnumOleDocumentViews; out View: IOleDocumentView): HResult; begin Result := S_OK; try // We only support one view View := Self as IOleDocumentView; except Result := E_FAIL; end; end; function TActiveXDocument.GetDocMiscStatus(var Status: DWORD): HResult; begin Status := (Factory as TActiveXDocumentFactory).DocMiscStatus; Result := S_OK; end; { TActiveXDocument.IOleDocument } function TActiveXDocument.ApplyViewState(pstm: IStream): HResult; begin Result := E_NOTIMPL; end; function TActiveXDocument.Clone(NewSite: IOleInPlaceSite; out NewView: IOleDocumentView): HResult; begin Result := E_NOTIMPL; end; function TActiveXDocument.CloseView(dwReserved: DWORD): HResult; begin Result := S_OK; try Show(False); SetInPlaceSite(nil); except Result := E_UNEXPECTED; end; end; function TActiveXDocument.GetDocument(out P: IUnknown): HResult; begin Result := S_OK; try P := Self as IUnknown; except Result := E_FAIL; end; end; function TActiveXDocument.GetInPlaceSite(out Site: IOleInPlaceSite): HResult; begin Result := S_OK; try Site := OleInPlaceSite; except Result := E_FAIL; end; end; function TActiveXDocument.GetRect(var View: TRECT): HResult; begin Result := S_OK; try View := Control.BoundsRect; except Result := E_UNEXPECTED; end; end; function TActiveXDocument.Open: HResult; begin Result := E_NOTIMPL; end; function TActiveXDocument.SaveViewState(pstm: IStream): HResult; begin Result := E_NOTIMPL; end; function TActiveXDocument.SetInPlaceSite(Site: IOleInPlaceSite): HResult; begin Result := S_OK; try if OleInPlaceSite <> nil then Result := InPlaceDeactivate; if Result <> S_OK then Exit; if Site <> nil then OleInPlaceSite := Site; except Result := E_UNEXPECTED; end; end; function TActiveXDocument.SetRect(const View: TRECT): HResult; begin // Implement using TActiveXControl's IOleInPlaceObject.SetObjectRects impl Result := SetObjectRects(View, View); end; function TActiveXDocument.SetRectComplex(const View; const HScroll; const VScroll; const SizeBox): HResult; begin Result := E_NOTIMPL; end; function TActiveXDocument.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 TActiveXDocument.UIActivate(fUIActivate: BOOL): HResult; begin Result := S_OK; try if FUIActivate then begin if OleInPlaceSite <> nil then InPlaceActivate(True) else Result := E_UNEXPECTED; end else begin UIDeactivate; InPlaceMenuDestroy; end; except Result := E_UNEXPECTED; end; end; { TActiveXDocument.IOleInPlaceActiveObject } function TActiveXDocument.OnDocWindowActivate(fActivate: BOOL): HResult; begin Result := inherited OnDocWindowActivate(fActivate); if fActivate then InPlaceMenuCreate else InPlaceMenuDestroy; end; { TActiveXDocument.IOleInPlaceObject } function TActiveXDocument.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; end; { TActiveXDocumentFactory } constructor TActiveXDocumentFactory.Create(ComServer: TComServerObject; ActiveXDocClass: TActiveXDocClass; WinControlClass: TWinControlClass; const ClassID: TGUID; ToolboxBitmapID, MiscStatus: Integer; ThreadingModel: TThreadingModel; const Handler: string; DocMiscStatus: DWORD); begin FDocMiscStatus := DocMiscStatus; if Handler <> '' then FHandler := Handler else FHandler := 'ole32.dll'; inherited Create(ComServer, ActiveXDocClass, WinControlClass, ClassId, ToolboxBitmapID, '', MiscStatus, ThreadingModel); end; procedure TActiveXDocumentFactory.UpdateRegistry(Register: Boolean); var ClassKey, ProgKey, MiscFlags: string; begin ClassKey := 'CLSID\' + GUIDToString(ClassID) + '\'; ProgKey := ProgID + '\'; if Register then begin inherited UpdateRegistry(Register); MiscFlags := IntToStr(FDocMiscStatus); // Add reg keys under CLSID CreateRegKey(ClassKey + 'DocObject', '', MiscFlags); CreateRegKey(ClassKey + 'Programmable', '', ''); CreateRegKey(ClassKey + 'Insertable', '', ''); CreateRegKey(ClassKey + 'InprocHandler32', '', FHandler); // Add reg keys under ProgID CreateRegKey(ProgKey + 'DocObject', '', MiscFlags); CreateRegKey(ProgKey + '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(ProgKey + 'DocObject'); DeleteRegKey(ProgKey + 'Insertable'); inherited UpdateRegistry(Register); end; end; end. 6. Create a customized ''AxCtrls.pas'' file: * Make a copy of Delphi unit ''AxCtrls.pas'' (found under ''C:\Program Files\Borland\Delphi7\Source\Vcl'') and place it under the project folder. * Edit the file ''AxCtrls.pas'' to make ''TActiveXControl.InPlaceActivate'' method ''Virtual''. * Include this file in the project. == Fitting Module Icon (Logo.DLL) == From the //NOAH 2.0 Framework System Architecture Specification//: We need a DLL file containing logos used by the NOAH Framework selection screen when the user chooses a piece of measurement equipment or a hearing instrument. The logo DLL file must contain the following resources for both measurement and fitting modules: * A bitmap named ''LOGO001'' of size 40x88 pixels by 16 colors. This bitmap will be shown by the NOAH Framework, when the user selects manufacturer. * A string table with an entry numbered 1001. This string entry must contain a text identifying the module. The text should not exceed 30 characters in length. * Optionally, the file may contain a bitmap name ''LOGO002'' of the same size as bitmap ''LOGO001'', but with 256 colors. The framework will automatically use this bitmap, if present, instead of ''LOGO001'' when running on a system with 256 or more colors. * The name of the logo DLL must be unique among all NOAH modules. ===== Basic Steps ===== 1. Create an icon file called ''logo16.bmp'' (16 colors Windows Bitmap) and ''logo256.bmp'' (256 colors Windows Bitmap). Each module must provide its icon, or logo, to NOAH upon installation. The icon must be 88x40 pixels (some other documentation specifies 90x40 pixels) and may use up to 256 colors. 2. Create a resource file ''LogoRes.RC''. NOTE: Do not ''#define'' the ''LOGO001'' and ''LOGO002'' resources because it then does not register the correct icon in Noah. Create file as follows: LOGO001 BITMAP "logo16.bmp" LOGO002 BITMAP "logo256.bmp" STRINGTABLE { 1001, "Audina ezFIT" } 3. Create a resource-only DLL project ''Logo044.dpr'' in Delphi: //------------------------------------------------------------------------------ // Unit Name: Logo044.dpr (for Logo044.dll) // Author: smayr // Date: 04-Sep-2007 // Purpose: // Resource only DLL to contain Audina icon for Noah Fitting Module. //------------------------------------------------------------------------------ library logo044; {$R 'LogoRes.res' 'LogoRes.rc'} // modify these files with images uses SysUtils, Classes; {$R *.res} begin end. For more information, refer to: * Section 6.7.1 of the //NOAH Framework System Architecture Specification// for a list of the necessary contents of the logo-DLL file. * Section 3.2.5 "Sub Modules Object" in //Programmers Guide to NOAH 3 Module Development// for an explanation on how to use the logo icons. == Tools == * Install NOAH 3.x SDK * Use Module Tester to test the fitting module. * Login using: User initials: adm, Password: Noah30 * No Login. Verify that the application icon properties have the "nologin" option to run without having to login: "C:\Program Files\HIMSA\NOAH 3.0 SDK\Tools\Module Tester\MODULETESTER.EXE" /nologin == Glossary == ====== ActiveX Document Server ====== An Automation Server that supports a number of specific interfaces (IPersistStorage, IPersistFile, IOleObject, IDataObject, IOleInPlaceObject, IOleInPlaceActiveObject, IOleDocument, IOleDocumentView, IOleCommandTarget (optional), IPrint (Optional)). It is made up of frames, documents and views. ((Teixeira, Steve. //COM Corner: ActiveX Documents, Part 1//. The Delphi Magazine, February 1999.)) * The frame is (IOleInPlaceFrame, IOleInPlaceSite, IOleContainer) the 'socket' provided by the container application in which the ActiveX Document resides. * The document (IOleDocument) is the server data being manipulated in the container. * The item (IOleDocumentView) represents a specific view of the document data. ====== ClassID ====== The GUID of an automation server or a COM interface. For example: '''{208464B8-70F5-4C7F-99B5-A8050138A54B}''' ====== Interface ====== "Conceptually, an interface is nothing more than a contract between the implementor of the interface and the user of the interface. By defining an interface, you are in effect saying, 'I see the need for this functionality. I recognize that this functionality could be implemented in many different ways. I don't really care how the functionality is physically implemented, but it had better adhere to these specifications.'" ((Harmon, Eric, //Delphi COM Programming//, Macmillan Technical Publishing, Indianapolis, IN, 2000.)) ====== ProgID ====== The automation server name and document. For example: ''ModProgID := 'GenericServer.Document';''