           19 

        _ 

      


    ---    (Component Object Model) 

       . 

    ---  Delphi 

       inter- ' face,  Delphi,  
      . 

    --    

             
       -. 

    --   Windows 

        -   Windows 95  
Windows NT 4. 

               
  Delphi 3.     Component Object Model 
().         .  
         
  .        
,         
,   Delphi 2,      
        , 
  Delphi 3.        
   Windows.    ,   
  . 

       

     ,  Component Object Model,     
 ,    .  
             {Component 
Objects)       .  
        ^- ,: 
  . 
      (component object}      ( 
),      
 .       
 C++,    

    438 

       C++.    ,  
  Windows 95,      
,  ,    ActiveX,   
         . 
    I        .  ,  
   ,  ,   
   .    
 , ,   ,   
      . 
              
.  :       
, ,      
   . 
     ,        
    ,   .  
 (  )     
,    . 

         

              ? 
     ,     
  (DLL),   (). ,   
  ,   (in-process).  , 
  ,    .  
       ,     
 ,     , 
       
 . no^ro^nJiH'iiiHfi.JiQKaJibHbie    
.     (remote)  .  
 ,        
.       DCOM ( 
   DCOM  ). 
            Microsoft   
  ActiveX.      OLE,   
ActiveX   .    ,    
ActiveX,  DirectX.         
,         
,     . 

       

         ,    
    .      
.      Windows    
 Windows, ,   ,   Windows (Explorer.exe). 
 ,          
.  ,  " "      
  .   ,       . 
          -    
,     Windows     
.    Windows     ,  
     (    ). 
     :  Windows ,     
?      | Windows.  
         .  
,          , 
          .  
  Windows   ,    
  .     Windows , 
     .     
,       ,   
       . 
          .   
   4  ,    .   
  Microsoft     Distributed , 
      . - 
  (distributed)  ,  DCOM,   
   Visual Basic 4 Professional Edition.    
  DCOM,   Windows NT 4.  
 ,    Visual Basic,  
    Windows 95.  ,  
  OLE   ,  OLE Enterprise.   
    Borland  Open Environment. OLE 
Enterprise   ,     Win32. 

     19.                                     439 


       

         ,     
Windows,       .  Windows 
      (globally unique 
identifier),  GUID,     .   
  GUID       
   CLS/D.   ,  
  Windows     .  
     GUID,     
   IID.  IID   
  . 
       :    - 
  ,   . Windows  
     ,      . 
         , 
      . 
        , 
    . 

       

      :      
,   ?    , 
   ,   ,  
   ,       
  .  ,    
|   ^   
., ,^  .  
    ,      . 

       

         :   ,   
  .      OLE.  
   ,      
  ,  .    
         
  . 
    ,  IDataObject      
    OLE/COM .      
  Windows   .   OLE  
,     .     
,        .  
         
   (marshaling),   Windows   
  " .     
     .    
QLE-      ,    
   Windows. 

     -   

    ,        
.    () ,   
       ,   
Delphi.  ,    ,    
 .       
 .         
  ,   Delphi   
" " '       
Delphi 2.        651  
.          
 .      , 
     ,     
        . 
             
 ,    .  ,  
 ,    ,    
   .  ,    
     .   
         
   OLE.      
   . \     ,   
          . 

    440                                            V.   OLE 

      Delphi       
 . ,  ,    
TPureVirtualClass,       . 

    TPureVirtualClass = class 
    public 
    procedure Methodi; virtual; abstract; 
    function Method2: Longint; virtual; abstract
    end; 

        ,   
    . 
       Delphi       
  .        
  Delphi (Interface)    . 
      ,     (marshalling), 
       ,   
     .   
  ,    ,  
         ,  
          . 
     ,  
       . 
         
  OLE.        
  DCOM,      
   .      
        .    
    ,      
  ,        
     .     , 
  ,    ,    
 (multithreaded) ,      . 

        

           
   .      
,       1.   
 ,      ,  
 AddRef,      .  ,  
     ,   Release, 
      .     
Release ,       , ,   
,  Release   . 
          ?  ,  . 
,         IMalloc. 
    ,    IMalloc   
.       IMalloc,   
AddRef           
     .        
 IMalloc,        IMalloc. 
            
IMalloc             
     IMalloc (   
AddRef)        .  
 ,          IMalloc 
(    Release),     ,  
         (    
  Imalloc).   IMalloc  , 
       . 
             , 
       .  
      .    ,  
          
   ,      
  . 

     19.                                     441 


     (Unknown -    

     AddRef  Release       ,  
    .    Querylnterface.  
     lUnknown.    
 lUnknown,   Delphi 2. 

    lUnknown = class 
    public 
    function Querylnterface(const iid: TIID; var obj): HResult; 
    virtual; stdcall; abstract; 
    function AddRef: Longint; virtual; stdcall; abstract; 
    function Release: Longint; virtual; stdcall; abstract; 
    end; 

      TObject,      Delphi, 
 lUnknown       .  
,  ,    - ,  
    AddRef, Release  Querylnterface. 
       .    
   AddRef  Release,      Querylnterface. 
            , 
             
 ,    .    
      Querylnterface. ,    
   (IID)      (Obj). 
     ,   Obj 
      ,  
 .      
 ,    Obj   Nil.  
Querylnterface      
 ,      
     .   
(interface aggregation)         
       
.       .  Delphi   
 ,     ,  .      
          ,   
        .             
         ,    , 
 .  Delphi 2.X    OLE    
  (  lUnknown,    )  
 OLE2.   Delphi 3     , 
  OLE       ACTIVEX.   
       Delphi 2,  
  ,       
Delphi 2.      Interface   ACTIVEX. 

       " " 

          ,    
,   IMalloc.    ,   
  Interface,  ,       
 IMalloc     .     
  ,     ,   
     .      
        ,  
   .  ,      
 .    ,     
     . 

       

    ,     ,     
,    .   19.1 CLSID   
 Class_MallocComponentObject.     TCLSID, 
   . 

    TCLSID = TGUID; 
    TGUID = record 


    442                                            V.   OLE 


    Dl: Integer; 
    D2: Word; 
    D3: Word; 
    D4: array[0..7] of Byte; 
    end; 

       TGUID  ,   , , 
 Windows  GUID,     . 
 CLSID       ,  
 .           
,  CLSID    . 
      ,      
   .      
   (allocate),   (reallocate)  
 (free)   .   ,   
  OLE IMalloc,    
.  IMalloc    OLE2.PAS,   . 

    IMalloc = class(lUnknown) 
    public 
    function Alloc(cb: Longint): Pointer; virtual; stdcall; abstract; 
    function Reallocfpv: Pointer; cb: Longint): Pointer; virtual; stdcall; abstract; 
    procedure Free(pv: Pointer); virtual; stdcall; abstract; 
    function GetSizefpv: Pointer): Longint; virtual; stdcall; abstract
    function DidAlloc(pv: Pointer): Integer; virtual; stdcall; abstract
    procedure HeapMinimize; virtual; stdcall; abstract; 
    end; 

        OLE     Inside OLE 
(Second Edition, Kraig Brockschmidt, Microsoft Press) 
        ,     IMalloc. 
-,      lUnknown. -,  
    ,    
. ,  -      
 .  ,    OLE, 
   ,         
 . ,     , 
,       , 
        .   
       IMalloc,  
      19..     
    lUnknown.    AddRef  
Release,    . 

    TMallocComponentObject = class(IMalloc) private 
    FRefCount: Longint; //   ; 
    function TMallocComponentObject.AddRef: Longint; 
    begin 
    Inc(FRefCount) ; 
    Inc (Global_Object_Count) ; 
    Result := FRefCount; 
    end; 
    function TMallocComponentObject.Release: Longint; 
    begin 
    Dec(FRefCount) ; 
    Dec(Global_Object_Count) ; 
    Result := FRefCount; 
    //,     - . 
    // ,  . 
    if FRefCount = 0 then Destroy; 
    end; 

     AddRef  Release      
  ( FRefCount)  TMallocComponentObject.  , 
      Release   
    .    ,   
    Destroy. 

     19.                                     443 

     ,  ,    ,    
    ( Global_Object_Count).  
     .  Giobal_Object_Count 
   DllCanUnloadNow,    . 
    ,    19.1,     MALLOC1.   
  . 

     19.1. \UDELPHl3\CHPl9\MSERVERl\MALLOCl. .   
  iMalloc 

    unit Malloci; 
    interface 
    uses Windows, 01e2, SysUtils; 
    const 
    // {OAA17140-310E-11DO-A45E-444553540000} 
    Class_MallocComponentObject: TCLSID = ( 
    D1:$OAA17140; D2:$310E; D3:$11DO; D4:($A4,$5E,$44,$45,$53,$54,$00,$00));  . 
    type 
    TMallocComponentObject = class(IMalloc) 
    private 
    FRefCount: Longint; //   ; 
    FHeapHandle: THandle; 
    public 
    Constructor Create; 
    Destructor Destroy; override; 
    //   lUnknown (IMalloc   ). 
    function Querylnterface(const IID: TGUID; 
    var Obj): Integer; override; 
    function AddRef: Integer; override; 
    function Release: Integer; override; 
    //   Imalloc. 
    function Allocfcb: Longint): Pointer; override; 
    function Realloc(pv: Pointer; cb: Longint): Pointer; override; 
    procedure Freetpv: Pointer); override; 
    function GetSize(pv: Pointer): Longint; override; 
    function DidAlloc(pv: Pointer): Integer; override; 
    procedure HeapMinimize; override; 
    end; 
    var Global Object Count: Integer; 
    //  ,    .  
    // Global Object Count = 0,       
    //   DLL    . 
    implementation 
    const 
    //      Delphi 3.0; 
    //   HeapCreate  .. 
    HEAP_ZERO_MEMORY = $00000008; 
    Constructor TMallocComponentObject.Create; 
    //___ 
    // .     
    //  64  
    //   4   .   
    //  (heap)   HeapHandle. 


    444                                            V.   OLE 


    //         
    //   .  HeapHandle =0,      
    //  . 
    // 
    begin 
    Self.FHeapHandle := Windows.HeapCreate(0, 4096, 65535); 
    end; 
    Destructor TMallocComponentObject.Destroy; 
    // 
    // .  ,    . 
    // 
    begin 
    if FHeapHandle > 0 then 
    HeapDestroy(FHeapHandle) ; 
    Inherited Destroy; 
    end; 
    //=============================================^=================^^=== 
    //   lUnknown  TMallocComponentObject 
    / / ____________=:===__= _______________________________________ 
    function TMallocComponentObject.Querylnterface(const IID: TGUID; 
    var Obj): Integer; stdcall; 
    //-..--_^^____________.-_.- 
    // . ,     
    //    . 
    //  ,      . 
    // 
    begin 
    //  "out"    Nil. 
    Pointer (oBJ") := Nil; 
    Result := E_NOINTERFACE; //   
    //   . 
    //   lUnknown  IClassFactory. 
    if IsEqualCLSID(iid, IID_IUnknown) or 
    IsEqualCLSIDfiid, IID_IMalloc) then 
    begin 
    //    
    // , ,  
    //  FRefCount     . 
    TMallocComponentObject(obj) := Self; 
    TMallocComponentObject(obj).AddRef; 
    ' Result := S_OK; 
    end; 
    end; 
    function TMallocComponentObject.AddRef: Longint; 
    // 
    // .   1    
    //    .      
    //  . 
    // 
    begin 
    Inc(FRefCount) ; 
    Inc(Global_Object_Count) ; 
    Result := FRefCount; 
    end; 
    function TMallocComponentObject.Release: Longint; 
    // 
    // .   1    
    //    .      


     19.                                     445 


    // 0, ,         
    // .  ,   1   
    //  . 
    //___________ 
    begin 
    Dec(FRefCount) ; 
    Dec (Global_Object_Count); 
    Result := FRefCount; 
    // ,    . 
    //  ,   . 
    if FRefCount = 0 then Destroy; 
    end; 
    // 
    //   IMalloc  TMallocComponentObject. 
    function TMallocComponentObject.Alloc(cb: Longint): Pointer; 
    // 
    // .   . 
    // 
    begin 
    Result := HeapAlloc(FHeapHandle, HEAP_ZERO_MEMORY, cb) ; 
    end; 
    function TMallocComponentObject.Realloc(pv: Pointer; cb: Longint): Pointer; 
    // 
    // .     . 
    // 
    begin 
    Result := HeapReAlloc(FHeapHandle, HEAP_ZERO_MEMORY, pv, cb) ; 
    end; 
    procedure TMallocComponentObject.Free(pv: Pointer); 
    // 
    // .    . 
    // 
    begin 
    HeapFree(FHeapHandle, 0, pv) ; 
    end; 
    function TMallocComponentObject.GetSize(pv: Pointer): Longint; 
    // 
    // .   ( )  , 
    //     Alloc  Realloc. 
    // 
    begin 
    Result := HeapSize(FHeapHandle, 0, pv); 
    end; 
    function TMallocComponentObject.DidAlloc(pv: Pointer): Integer; 
    // 
    // .   ,.    . 
    // 
    var 
    phe: TProcessHeapEntry; 
    begin 
    Result := -1; // -1 -  . 
    // ,    Nil. 
    if pv s= Nil then Exit; 
    . 
    //   ,   Windows 95 
    //    HeapWalk. 


    446                                            V.   OLE 


    if Win32Platform = VER_PLATFORM_WIN32_WINDOWS then Exit; 
    Result := 0; // 0 -  . 
    ZeroMemory(@phe, sizeof(TProcessHeapEntry)) ; 
    //   Result  1    // . 
    while HeapWalk(FHeapHandle, phe) do 
    if phe.lpData = pv then 
    Result := 1; 
    end; 
    procedure TMallocComponentObject.HeapMinimize; 
    // 
    // .      , 
    //      , 
    //        
    //  . 
    // 
    begin 
    HeapCompact(FHeapHandle, 0) 
    end; 
    /initialization 
    Global_Object_Count := 0;  ) 
    .end. 
    

       

             
(DllRegisterServer  DllUnregisterServer),    DLL 
 .       ,  
 InstallShield Express,    Delphi 3.   
  REGSVR32 . ,    Windows NT  3.51  
4.       Windows 95! ,    
 Microsoft      Windows 95.   
       Windows,  
   . 

      1 
           REGEDIT.EXE  
Windows 95  Windows NT 4.0   REGEDT32 .    Windows NT 3.51. 

    LJ 
         REG- Windows.  19.2 
   MSERVER1. REG.    ,   
     REG-. 

    HKEY_CLASSES_ROOT 
    CLSID 
    {OAA17140-310-11DO-A45E-444553540000} = "Using Delphi 3 IMalloc Example" 
    InProcServeer32 = < DLL>\MServerl.dll 

            
 ,       HKEY_CLASSES_ROOT\CLSID. 
 ,         
    InProcServer32,  ,   
        . 
       IMalloc  
     Windows.     
           
.        REG-  
 Windows Explorer    File Manager,     
 '; " 

    ^Ilk     MSERVER1. REG      . 


     19.                                    447 


     19.2. \UDELPHl3\CHPl9\MSERVERl\MSERVERl. REG.  
REG-,       IMAIIOC  
 MServeri. dll 

    REGEDIT4 '" 
    [HKEY_CLASSES_ROOT\CLSID\{OAA17140-310E-11DO-A45E-444553540000)] 
    @="Using Delphi 3 IMalloc Example" 
    [HKEY_CLASSES_ROOT\CLSID\{OAA17140-310E-llDO-A45E-444553540000}\InProcServer32] 
    @="C:\\UDelphi3\\Chapl9\\MServerl\\MServerl.dll" 
    
              
    Windows ,     . 
        . 
-,      Windows   
    . -, ,    
   Windows ,    ,   
   . 

     Windows    

     Windows        
,        .  
  DllCanUnloadNow.    Windows,  
           
CoFreeUnusedLibraries.  4> DllCanUnloadNow,  , 
   19.3,    . 

    function DllCanUnloadNow: HResult; stdcall;                                
    begin                                                                      
    if Global_Object_Count > 0 then                                            
    Result := S_FALSE                                                          
    else                                                                       
    Result := S_OK;                                                            
    end; 

             S_OK  
HRESULT,      ,   S_FALSE   
 .        Global 
Object Count.        
        AddRef  
Release . 
     (  )      
DllGetClassObject,        . 
  19.3   MServeri,    
DllGetClassObject.   Windows    (CLS1D), 
  .  ,   ,  
   .       
 ,      , 
   ,    if. 

    if not IsEqualCLSID(CLSID, Class_MallocComponentObject) then 
    begin 
    Result := CLASS_E_CLASSNOTAVAILABLE; 
    Exp
    end; 

        ,     
OLE,  ,        
.   ,    
 ,    Windows   , 
    ?      , 
      ?   ,   
         , ,  
     .       
 ,   .    
   . 
        ,    CLSID  
,        
IClassFactory.     Windows  
     ,  
 .  IClassFactory    .  
 19.4     IClassFactory,   
  .     ,   
   

    448                                            V.   OLE 

      .  ,     
  IClassFactory,  , ,      
TClassFactory           
 ,     Querylnterface  
,  ,    Windows  
.      Self. 

    with TClassFactory.Create do 
    try 
    AddRef; 
    Result := Querylnterface(IID, InterfaceObject); 
    finally 
    Release; 
    end; 

             
Querylnterface,      lUnknown.  ,  
  TClassFactory       IUnknown 
 ,      Querylnterface,  
    .      
   ,   .  
   19.3   , DllCanUnloadNow 
 DllGetClassObject,   . 
    ,    19.3,    MSERVER1. DPR  
  . 

    1  19.3. \UDELPHI3\CHP19\MSERVER1\MSERVER1. DPR.   
  ZMalloc 

    library MServerI; 
    uses 
    Windows, 
    01e2, 
    CIsFactI in 'CIsFactI.pas', 
    Malloci in 'Malloci.pas'; 
    function DllGetClassObject(const CLSID: TGUID; const IID: TIID; 
    var InterfaceObject): HResult; stdcall; 
    begin 
    Pointer(InterfaceObject) := Nil; 
    if not IsEqualCLSID(CLSID, Class_MallocComponentObject) then 
    begin 
    Result := CLASS_E_CLASSNOTAVAILABLE; 
    Exit; 
    end; 
    try 
    with TClassFactory.Create do 
    try 
    AddRef; 
    Result := Querylnterface(IID, InterfaceObject); 
    finally 
    Release; 
    end; 
    except 
    Result := E_OUTOFMEMORY 
    end; 
    end; 
    function DLLCanUnloadNow: HResult stdcall; 
    begin 
    if Global_Object_Count > 0 then 
    Result := S_FALSE 


     19.                                    449 


    else 
    Result := S_OK; 
    end;                                                                       
    exports.,..    -    ,.., 
    DllGetClassObject, . 
    DllCanUnloadNow; 
    begin end. 


    ICIassFactory -    

             
 ,       ,  
 ' 19.4.   lass Factory    
      Createlnstance.     
 DUGetClassObject  Windows   ICIassFactory, 
   Createlnstance  ICIassFactory.  , 
,      ,   
 Createlnstance,      . 
     CLSFACT1. ,    19.4,   
   

     19.4. \UDELPHI3\CHP19\MSERVER1\CLSFACT1. .   
  ICIass

    Factory,  Windows     
    unit CIsFacti; ' 
    interface 
    uses 
    Windows, SysUtils, 01e2; 
    type 
    TClassFactory = class (ICIassFactory) 
    private 
    FRefCount: Longint; //   ; 
    public 
    //   lUnknown 
    // (ICIassFactory   lUnknown). 
    function Querylnterface(const iid: TIID; var obj): HResult; override; 
    function AddRef: Longint; overrider
    function Release: Longint; override; 
    //   ICIassFactory. 
    function Createlnstance(unkOuter: lUnknown; const iid: TIID; 
    var obj): HResult; overrider
    function LockServer(fLock: BOOL): HResult; overrider
    end; 
    implementation 
    uses Malloci, dialogs; 
    //   IMalloc  TClassFactory. 
    function TClassFactory.Querylnterface(const IID: TGUID; 
    var Obj): Integer; 
    // 


    450                                            V.   OLE 


    // . ,     
    //    . 
    //  ,      . 
    // 
    begin 
    //  "out"    Nil. 
    Pointer(obj) := Nil; 
    Result := E_NOINTERFACE; //  
    //   . 
    //   lUnknown  IClassFactory. 
    if IsEqualCLSID(iid, IID_IUnknown) or 
    IsEqualCLSID(iid, IID_IClassFactory) then 
    begin 
    lUnknown(obj) := Self; 
    lUnknown(obj).AddRef; 
    Result := S_OK; 
    end; 
    end; 
    function TClassFactory.AddRef: Longint; 
    // 
    // .   1    
    //    .      
    //  . 
    // 
    begin 
    Inc (FRef Count) ; 
    Inc(Global_Object_Count) ; 
    Result := FRefCount; 
    end; 
    function TClassFactory.Release: Longint; 
    // 
    // .   1    
    //    .    0, , 
    //          
    // .  ,   1   
    //  . 
    // 
    begin 
    Dec(FRefCount) ; 
    Dec(Global__Object_Count) ; 
    Result := FRefCount; 
    // ,    . 
    //  ,   . 
    if FRefCount = 0 then Destroy; 
    end; 
    //   IClassFactory  TClassFactory 
    // 
    function TClassFactory.Createlnstance(unkOuter: lUnknown; 
    const iid: TIID; var obj): HResult; 
    // 
    // .     , 
    //    ,     
    //         
    // . 
    // 
    var 
    MallocComponentObject: TMallocComponentObject; 
    begin 


     19.                                     451 


    //  "out"    Nil. 
    Pointer(Obj):= Nil; 
    //    . 
    if (UnkOuter <> Nil) then 
    begin 
    Result := CLASS_E_NOAGGREGATION; 
    Exit; 
    end; 
    //    . 
    try 
    MallocComponentObject := TMallocComponentObject.Create; 
    try 
    AddRef; 
    //   ,   . 
    Result := MallocComponentObject.Querylnterface(IID, Obj); 
    finally 
    Release; 
    end; 
    except 
    //     . 
    Result := E_OUTOFMEMORY; 
    end; 
    end; 
    function TClassFactory.LockServer(fLock: Bool): HResult; 
    // 
    // .        
    // ,    . 
    //        , 
    //     . 
    // 
    begin 
    if fLock then 
    Inc(Global_Object_Count) 
    else 
    Dec(Global_Object_Count) ; 
    Result := NOERROR; 
    end; 
    end. 

            .   
  ,        
,      .   
,   MServerl.dpr     
,   MServerl.reg     .  
        d: \UDELPHI3 . . . 
,          
   MServerI. reg.      
  . 

        IMalloc 

      19.5     ,  
  IMalloc    Malloci,     
.       Colnitialize, 
   .       
     ,      
 ,        CoUninitialize. 
           4) Colnitialize  
  Olelnitialize.    OLE   
  OleUninitialize.  

    452                                            V.   OLE 

             
  CoCreateInstance.       
      ,   , 
   (I1D)     ,  
       IMalloc,  
 . 

    OleCheck(CoCreateInstance(Class Malloc ComponentObject, 
    Nil, CLSCTX^NPROC^SERVER^IDD^Malloc, Malloc)); 

       CoCreateInstance  Windows  
    ,  .      
oieCheck,    OLE/COM,   .  
    OleCheck   . 
            
CoGetClassObject.        
   ,  "     
 Windows.        
    IClassFactory. Createlnstance. He   
   .       
 CoCreateInstance. 
           IMalloc   
       Delphi,   
    .    
   Delphi   ,       
,     . 
            
     IMalloc  . 
    ,   Windows 95  IMalloc . DidAlloc 
 ,    HeapWalk,    ,  
  Windows 95. 
     MCLIENT. DPR,      19.5, 
    . 

     19.5. \UDELPHi\CHPl9\MCLiENT\MCLiENT. DPR.  , 
    

    IMalloc 
    program MClient; 
    uses Windows, OLE2, Dialogs, ComObj; 
    const 
    // (OAA17140-310E-11DO-A45E-444553540000) 
    Class_MallocComponentObject: TCLSID = ( 
    D1:$OAA17140; D2:$310E; D3:$11DO; D4 : ($A4, $5E, $44 , $4-5, $53, $54 , 
$00, $00) ) ; 
    // 
    // .    Imalloc. // 
    var 
    Malloc: IMalloc; 
    Str: PChar; 
    begin 
    //  , ,     
    //   Microsoft . 
    if Succeeded(Colnitialize(Nil)) then 
    try 
    OleCheck( CoCreateInstance( 
    Class MallocComponentObject, Nil, 
    CLSCTX_INPROC_SERVER, 
    IID_IMalloc, 
    Malloc) ) ; 
    try 
    Str := Malloc.Alloc(4096); 
    if Assigned(Str) then 
    try 
    if Malloc.DidAlloc(Str) = 1 then // He  
    //  Windows 95. 


     19.                                    453 


    ShowMessage('Memory was definately allocated'); 
    ZeroMemoryfStr,4096) ; 
    ShowMessage('4096 bytes allocated and zeroed out.'); 
    Malloc.ReAlloc(Str, 8192); 
    if Assigned(Str) then 
    begin 
    ZeroMemoryfStr, 8192); 
    ShowMessage('8192 bytes reallocated and zeroed out.'); 
    end; 
    finally 
    Malloc.Free(Str) ; 
    end; 
    finally 
    Malloc.Release; //    IMalloc 
    //  . 
    end; 
    finally 
    CoUnInitialize; //     
    //    Microsoft. 
    end; 
    end. 


        Delphi 

       ,        
 .         
        
Delphi 3     ,     
 .  Delphi 3   ,    
. -,   Delphi     , 
          
,   . -,  Delphi 3   
 ActiveX (Delphi ActiveX, DAX),     
 ,    , ,   
  ..  "      
 Delphi 3,          
IMalloc     Interface  Delphi   DAX. 
    . 

      Interface 

      IMalloc,      
 interface,   . 

    IMalloc = interface(IDnknown) 
    ['{0000002-0000-0000-COOO-000000000046}'] 
    function Alloc(cb: Longint): Pointer; stdcall; 
    function Realloc(pv: Pointer; cb: Longint): Pointer; stdcall; 
    procedure Freefpv: Pointer); stdcall; 
    function GetSizetpv: Pointer): Longint; stdcall; 
    function DidAllocfpv: Pointer): Integer; stdcall; 
    procedure HeapMinimize; stdcall; 
    end; 

     , ,       
 abstract; virtual;.     ,   
        . 
           
 ' ^    ,    , 
         
 (CLSID).     CLSID  
  IsEqualCLSID,   . 

    if IsEqualCLSID(iid, IMalloc) then ... 


    454                                            V.   OLE 


       lUnknown,     IMalloc. 
    lUnknown = interface 
    ['{----000000000046)'] 
    function Querylnterface(const IID: TGUID; out Obj): Integer; stdcall; 
    function _AddRef: Integer; stdcall; 
    function _Release: Integer; stdcall; 
    end; 

      lUnknown ( ),    
  Malloci,    OLE2.     Delphi  
  .     
HHTep$e"RcaTUnknown    System.     
 lUnknown      ,   
 OLE2,      . 
  AddRef  Release     
(_AddRef  _Release).   ,     
,~" 151>   AddRef  Release,  
         
 .         Object Pascal. 
    Delphi 3   OLE    interface   
ActiveX.  lUnknown  IDispatch    System. 

    TComObject -    DAX 

             
,         .   
,    IClassFactory    MServerI  
  AddRef  Release  lUnknown.  ,  
,     ,   
 Querylnterface  lUnknown.   TComObject,  
    DAX,  -,_.. 
 lUnknown.  TComObject   lUnknown,  
      "   
 Delphi 3.    IMalloc   , 
 . 

    type 
    TMallocComponentObject = class(TComObject, IMalloc) private 
    FHeapHandle: THandle; 
    public 
    //  TComObject,    Create. 
    procedure Initialize; override; 
    Destructor Destroy; override; 
    //   Imalloc. 
    function Alloc(cb: Longint): Pointer; stdcall; 
    function Realloc(pv: Pointer; cb: Longint): Pointer; stdcall; 
    procedure Freetpv: Pointer); stdcall; 
    function GetSize(pv: Pointer): Longint; stdcall; 
    function DidAlloc(pv: Pointer): Integer; stdcall; 
    procedure HeapMinimize; stdcall; 
    end; 

           . 
-,   _... Delphi 3 ,  
    ,   KnaccsTTbbject,   
     .   
  ,  .     
  ActiveX ,      
.       TComObject,  
      Querylnterface  . 
,        
IMalloc,       ,  . 
    ,  ,      
      Initialize 
 TComObject.    ,    
  ,    ~5 
TComObjectFactory.   19.6      
 TMallocComponentObject.      MALLOC2.   
  . 

     19.                                     455 


    ,:  19.6. \UDELPHl3\CHP19\MSERVER2\MALLOC2. PAS.  
 iMalloc    DAX 

    unit Malloc2; 
    interface uses Windows, SysUtils, Classes, ActiveX, ComObj, ComServ; 
    const 
    Class MallocComponentObject: 
    TCLSID = 40AA17140-310E-11DO-A45E-444553540000); 
    type 
    TMallocComponentObject = class(TComObject, IMalloc) private 
    FHeapHandle: THandle; 
    public 
    //  TComObject,   
    //  Create. 
    procedure Initialize; override; 
    Destructor Destroy; override; 
    //   Imalloc. 
    function Allocfcb: Longint): Pointer; stdcall; 
    function Realloc(pv: Pointer; cb: Longint): Pointer; stdcall; 
    procedure Free(pv: Pointer); stdcall; 
    function GetSizefpv: Pointer): Longint; stdcall; 
    function DidAlloc(pv: Pointer): Integer; stdcall; 
    procedure HeapMinimize; stdcall; 
    end; 
    implementation 
    const 
    //      Delphi 3.0; 
    //   HeapCreate  .. 
    HEAP_ZERO_MEMORY = $00000008; 
    procedure TMallocComponentObject.Initialize; 
    //-____-_-__-_-__-_-_____-_-______-_____________________ 
    // .     
    //  64  
    //  4   .   
    //  (heap)   HeapHandle. 
    //         
    //   .  HeapHandle = 0,      
    //  . 
    // 
    begin 
    FHeapHandle := HeapCreate (0, 4096, 65535); 
    end; 
    Destructor TMallocComponentObject.Destroy; 
    // 
    // .  ,    . 
    // 
    begin 
    if FHeapHandle > 0 then HeapDestroy(FHeapHandle) ; 
    Inherited Destroy; 
    end; 


    456                                            V.   OLE 


    //   IMalloc  TMallocComponentObject. 
    function TMallocComponentObject.Alloc(cb: Longint): Pointer; 
    // 
    // .   . // 
    begin 
    Result := HeapAlloc(FHeapHandle, HEAP_ZERO_MEMORY, cb); 
    end; 
    function TMallocComponentObject.Realloc(pv: Pointer; 
    cb: Longint): Pointer; 
    // 
    // .     . 
    // 
    begin 
    Result := HeapReAlloc(FHeapHandle, HEAP_ZERO_MEMORY, pv, cb); 
    end; 
    procedure TMallocComponentObject.Free(pv: Pointer); 
    // 
    // .    . 
    // 
    begin 
    HeapFree(FHeapHandle, 0, pv); 
    end; 
    function TMallocComponentObject.GetSize(pv: Pointer): Longint; 
    // 
    // .   ( )  , 
    //     Alloc  Realloc. 
    // 
    begin 
    Result := HeapSize(FHeapHandle, 0, pv); 
    end; 
    function TMallocComponentObject.DidAlloc(pv: Pointer): Integer; 
    // 
    // .   ,     . 
    // 
    var 
    phe: TProcessHeapEntry; 
    begin 
    Result := -1; // -1 -  . 
    // ,    Nil. 
    if pv = Nil then Exit; 
    /'/   ,   Windows 95 
    //   HeapWalk. 
    if Win32Platform = VER_PLATFORM_WIN32_WINDOWS then Exit; 
    Result := 0; // 0 -  . 
    ZeroMemory(@phe, sizeof(TProcessHeapEntry)) ; 
    //   Result  1    
    // . 
    while HeapWalk(FHeapHandle, phe) do 
    if phe.lpData = pv then 
    Result := 1; 
    end; 
    procedure TMallocComponentObject.HeapMinimize; 
    // 
     19.                                    457 

    // .      , 
    //      , 
    //        
    //  . 
    // 
    begin 
    HeapCompact(FHeapHandle, 0) 
    end; 
    end. 


    TComObjectFactory    Delphi 

    ,  ,     Delphi   
TComObject    DAX     
 ,     .   
      IClassFactory   
 .    TComObjectFactory    
  IClassFactory.   , , DAX 
   ,     
       : DllRegisterServer  
DllUnregisterServer.         
,      ,     
.     - ,   
 .    , ,  
,         .  
   ,        
Windows,          
      .  DllRegisterServer 
 MServer2      ,  . 

    HKEY_CLASSES_ROOT 
    CLSID 
    {OAA1740-310E-11DO-A45E-444553540000} = "Using Delphi 2 IMalloc Example" 
    InProcServer32 = <  D11> 
    ProgID = MSERVER2.IMalloc 
    HKEY_CLASSES_ROOT 
    MSERVER2.IMalloc = "Using Delphi 3 IMalloc Example" 
    CLSID = {OAA1740-310E-11DO-A45E-444553540000} 

            , ,  
      ,    
ComServ.      ,  
,      TComObjectFactory.   
19.7 ,       MServer2. 
,     19.7      ( 
   ComServ). 
      (ProgID),    ,   
         , 
 ,    -   
TComObjectFactory  TComObject     
COMServer. ,     ProgID,  
MSERVER. IMalloc.  ProgID      
    . 
     MSERVER2. DPR,      19.7, 
    . 

     19,7. \UDELPHI3\CHP19\MSERVER2\MSERVER2. DPR.   , 
  

    j  IMalloc 
    library MServer2; 
    uses 
    ComObj, ComServ, 
    Malloc2 in 'Malloc2.pas'; 


    458                                            V.   OLE 


    exports 
    DllGetClassObject, 
    DllCanUnloadNow, 
    DllRegisterServer, 
    DllUnregisterServer; 
    begin 
    TComObjectFactory.Create( 
    ComServer,                        //   Delphi 
    //  ComServ.pas. 
    TMallocComponentObject,           //   TComObject. 
    Class MallocComponentObject,      //   
    //  . 
    'IMalloc',                        //    
    //  ProgID. 
    'Using Delphi 3 IMalloc Example', //   . 
    cisinglelnstance);                //     . 
    end. 


     

            , 
    ,  
.    ,     
   Windows.  ,     
 ,     Windows.   
   Windows,         
 .      ,   
           .   
  ,     ,  
        DLL-  - 
      .  , 
   ,    . 

        AXReg 

       ,     
  : 

    IShellExtInit  IContextMenu.      ShIObj. 
  TContextMenu   4),   . 
    TContextMenu = class(TComObject, IShellExtInit, IContextMenu) 
    //  private . 
    public 
    //      
    //  IContextMenu. 
    function QueryContextMenu(Menu: HMENU; indexMenu, idCmdFirst, 
    idCmdLast, uFlags: UINT): HReault; StdCall; 
    function InvokeCommand(var Ipici, uType: UINT; pwReserved: PUINT; 
    pszName: LPSTR; cchMax: UINT): HResult; StdCall; 
    //      
    //  IShellExtInit. 
    function Initialize(pidFolder: PItemDList; Ipdobj: IDataObject; 
    hKeyProgID: HKEY): HResult; StdCall; 
    end; 

           19.8. ,   
      ,   , 
     .  Windows  
  IShellExtInit      
    ,  .    
    .       
Initialize  IShellExtInit,     
,          IContextMenu. 
          Initialize   
  IDataObject,    Windows.  
   IDataObject     ,  

     19.                                    459 

     .      Windows   
  Windows       ,   
,   ,    . 
     IContextMenu   : QueryContextMenu, 
InvokeCommand  GetCommandString.  QueryContextMenu   
Windows    ,      . 
 InvokeCommand    Windows,   
     ,     
 .  GetCormnandString   Windows,  
         ,   
      .  ,  
  ,    Windows,   , 
      . 
     CONTEXTM. ,      19.8, 
    . 

     19.8. \UDELPHl3\CHPl9\AXREG\coNTEXTM. PAS.   
   Windows -   , 
   ActiveX 

    unit ContextM; 
    interface 
    uses 
    Windows, SysUtils, ComObj, ComServ, ShIObj, ActiveX, ShellApi; 
    Const 
    Class_ContextMenu: TGUID = '(A0516FEO-2F5D-11DO-A45E-444553540000}'; 
    Class_ContextMenuString = '(A0516FEO-2F5D-11DO-A45E-444553540000)' ; 
    type 
    TContextMenu = class(TComObject, IShellExtInit, IContextMenu) 
    private 
    szFile: array[0..MAX_PATH] of Char; 
    //   . 
    function CallActiveXServerProc(ProcName : String): Boolean; 
    public 
    //      
    //  IContextMenu. 
    function QueryContextMenu(Menu: HMENU; indexMenu, idCmdFirst, 
    idCmdLast, uFlags: UINT): HResult; StdCall; 
    function InvokeCommand(var Ipici: TCMInvokeCommandInfo) 
    :HResult; StdCall; 
    function GetCommandString(idCmd, uType: UINT; pwReserved: POINT; 
    pszName: LPSTR; cchMax: UINT): HResult; StdCall; 
    //      
    //  IShellExtInit. 
    // .      Initialize 
    //  TComObject. 
    function Initialize(pidlFolder: PItemIDList; Ipdobj: IDataObject; 
    hKeyProgID: HKEY): HResult; StdCall; 
    end; 
    implementation 
    const 
    ID_REGISTER = 0; 
    ID_UNREGISTER = 1; 
    function TContextMenu.CallActiveXServerProc(ProcName : String): Boolean; 
    //.--__-
    // .    /DLL   
    //    DllRegisterServer  


    460                                            .   OLE 


    // DllUnregisterServer.    , , 
    //      ActiveX. 
    // 
    type 
    TProcStdCall = procedure; StdCall; 
    var 
    DllHandle : THandle; 
    DllProc   : TProcStdCall; 
    begin 
    Result := False; 
    try 
    DllHandle := LoadLibrary(szFile); 
    if DllHandle <> 0 then 
    try 
    @DllProc := GetProcAddress(DllHandle, PChar(ProcName)) ; 
    if @DllProc <> Nil then 
    begin 
    DllProc; 
    Result := True; 
    end; 
    finally 
    FreeLibrary(DllHandle) ; 
    end; 
    except 
    end; 
    end; 
    function TContextMenu.QueryContextMenu(Menu: HMENU; indexMenu, 
    idCmdFirst, idCmdLast, uFlags: UINT): HResult; 
    // 
    // .       
    //   . 
    // 
    begin 
    //          DLL. 
    InsertMenu (Menu, indexMenu, MF_STRING or MF_BYPOSITION, 
    idCmdFirst + ID_REGISTER, 'Register Active X Server'); 
    InsertMenu (Menu, indexMenu + 1, MFJ3TRING or MF_BYPOSITION, 
    idCmdFirst + ID_UNREGISTER, 'Unrregister Active X Server'); 
    //    . 
    Result := 2; 
    end; 
    function TContextMenu.InvokeCommand(var Ipici: TCMInvokeCommandInfo) 
    :HResult; 
    // 
    // .  ,  
    //   . 
    // 
    const 
    SuccessStringTemplate = 'The Active X server was %s successfully.'; 
    FailStringTemplate = 
    'Attempt to register/unregister the selected OCX/DLL server failed.'; 
    var 
    MessageString : String; 
    begin 
    // ,     . 
    if HiWord(Integer(Ipici.IpVerb)) <> 0 then 
    begin 
    Result := E_FAIL; 
    Exit; 
    end; 


     19.                                     461 


    Result := NOERROR; 
    //  ,    Ipici.IpVerb. 
    MessageString := FailStringTemplate; //   
    //    
    // . 
    case LoWord(Ipici.IpVerb) of 
    ID_REGISTER: 
    if CallActiveXServerProc('DllRegisterServer') then 
    MessageString := Format(SuccessStringTemplate, ['registered']) 
    else 
    Result := E_FAIL; 
    IDJJNREGISTER: 
    if CallActiveXServerProc('DllUnregisterServer') then 
    MessageString := Format(SuccessStringTemplate, ['unregistered']) 
    else 
    Result := E_FAIL; 
    else 
    //    . 
    Result := E_INVALIDARG; 
    Exit; 
    end; 
    if Result = E_FAIL then MessageString := 'Operation failed'; 
    MessageBox(Ipici.hWnd, PChar(MessageString) , 'Information', 
    MB_ICONINFORMATION or MB_OK) ; 
    end; 
    function TContextMenu.GetCommandString(idCmd, uType: UINT; pwReserved: PUINT; 
    pszName: LPSTR; cchMax: UINT): HRESULT; 
    // 
    // .      
    //    . 
    // 
    const 
    HelpStringTemplate = '%s an OCX/DLL Active X server'; 
    var 
    HelpString : String; 
    begin 
    Result := NOERROR; 
    HelpString := ''; 
    //   . 
    case idCmd of 
    ID_REGISTER:   HelpString := Format(HelpStringTemplate, ['Registers']); 
    ID_UNREGISTER: HelpString := Format(HelpStringTemplate, ['Unregisters' ] ) ; 
    else 
    Result := E_INVALIDARG; 
    Exit; 
    end; 
    StrCopyfpszName, PChar(HelpString)) ; 
    end; 
    function TContextMenu.Initialize(pidlFolder: PItemIDList; Ipdobj: IDataObject; 
    hKeyProgID: HKEY): HResult; 
    // 
    // .      
    //      IDataObject. 
    // 
    var 
    StgMedium: TStgMedium; 
    FormatEtc: TFormatEtc; 
    begin 
    //  ,  Ipdobj    


    462                                            V.   OLE 


    //  IDataObject. 
    if Ipdobj = Nil then 
    begin 
    Result := E_FAIL; 
    Exit; 
    end; 
    with FormatEtc do 
    begin 
    cfFormat := CF_HDROP;         //   , 
    //   . 
    ptd      := Nil;              //    
    //   . 
    dwAspect := DVASPECT_CONTENT; //  . 
    lindex   := -1;               //   . 
    tymed    := TYMED_HGLOBAL;    //     
    //  . 
    end; 
    //     IDataObject    
    // HGLOBAL   CF HDROP ( ,  
    //  ). 
    Result := Ipdobj.GetData(FormatEtc, StgMedium); 
    if Succeeded(Result) then 
    try 
    //     ,     
    //     szFile. 
    //       . 
    if DragQueryFile(StgMedium.hGlobal, $FFFFFFFF, Nil, 0) <> 1 then 
    Result := E_FAIL 
    else 
    begin 
    DragQueryFile(StgMedium.hGlobal, 0, szFile, SizeOf(szFile)); 
    Result := NOERROR; 
    end; 
    finally 
    ReleaseStgMedium(StgMedium) ; 
    end; 
    end; 
    initialization 
    TComObjectFactory.Create( 
    ComServer, 
    TContextMenu, 
    Class_ContextMenu, 
    'Delphi 3.0 ContextMenu Example', ciMultiInstance) ; 
    end. 

      19.9 ,     AXRegl     
.  AXREG1. DPR     . 

     19.9. \UDELPHI\CHP19\AXREG\AXREG1. DPR.    
   ,   ActiveX 

    library AXRegl; 
    uses 
    ComServ, ContextM in 'ContextM.pas' ; 
    exports 
    DllGetClassObject,    //    ComServ. 


     19.                                    463 


    DllCanUnloadNow,      //    ComServ. 
    DllRegisterServer,    //    ComServ. 
    DllUnregisterServer; //    ComServ. 
    begin 
    TComObjectFactory.Create( 
    ComServer,          //   Delphi   ComServ.pas. 
    TContextMenu,       //   TComObject . 
    Class_ContextMenu, //    
    // . 
    //  ProgID . 
    'Delphi 3.0 ContextMenu Example',    //  
    //  . 
    ciMultiInstance); //   . 
    end. 


        AXReg 

           Windows  
      .    
  ,   . 

    HKEY_CLASSES_ROOT 
    CLSID 
    {A0516FE1-2F5D-11DO-A45E-444553540000} = "Using Delphi 3 - AXReg 1.0" 
    InProcServer32 = <Path of AXRegl.dll> 
    "ThreadingModel" = "Apartment" 

           (  ThreadingModel = 
Apartment,        InProcServer32). 
        ,    
  .      . 

    ...Add context menu support for  files ----------------------
    HKEY_CLASSES_ROOT 
    .OCX = "OcxFile" 
    OcxFile 
    shellex 
    ContextMenuHandlers 
    {A0516FE1-2F5D-11DO-A45E-444553540000} = "" 

     ,        
  (DllFile),     . 

    ...Add context menu support for DLLs ---------------------------
    HKEY_CLASSES_ROOT 
    DllFile 
    shellex 
    ContextMenuHandlers 
    {A0516FE1-2F5D-11DO-A45E-444553540000} 

      19.10  REG- (AXREG1. REG),    
       Windows.     
      AXReg (AXREG2 . DPR),     
  .      
  DllRegisterServer  DllUnregisterServer.  
DllRegisterServer     ,    
     . 

     19.10. \UDELPHl3\CHpl9\AXREG\AXREGl.REG. ,  
,    Windows 95  Windows NT 4  
    

    REGEDIT4 
    [HKEY_CLASSES_ROOT\DllFile\shellex\ContextMenuHandlers\ 
    (A0516FEO-2F5D-11DO-A45E-444553540000)] ="" 
    [HKEY_CLASSES_ROOT\CLSID\{A0516FEO-2F5D-11DO-A45E-444553540000}] 
    @="D11 Server Register" 
    [HKEY_CLASSES_ROOT\CLSID\{A0516FEO-2F5D-11DO-A45E-444553540000}\InProcServer32] 


    464                                            V.   OLE 


    @="C:\\UDelphi3\\Chapl9\\AXReg\\AXRegl.dll" 
    "ThreadingModel"="Apartment" 
    [HKEY_CLASSES_ROOT\.OCX] 
    @="OcxFile" 
    [HKEY_CLASSES_ROOT\OcxFile\shellex\ContextMenuHandlers\ 
    {A0516FEO-2F5D-11DO-A45E-444553540000}] ="" 

       ActiveX (    AXREG1. DLL)  
   AXRegl. reg,      ,   
 AXRegl.          , 
   \UDELPHI3 . . .,    AXRegl. reg   
       AXREG1. DLL. 
              
   ,    . 
 ,      ,  Windows 
   .  ,      
    Windows.     
      , 
  . 
        ,     Delphi 3  
  . 

     19.                                     465