mycomserver.pas

用delphi7开发Com步骤 及所所有到的windowapi 函数

unit MyComServer;
interface
uses Windows,Registry, SysUtils,ComDef;
type

IMyCOMTest = interface(IUnknown)
['{D1C4A022-7F6F-42F0-A9B0-4A91703EB124}']
    function  msg: integer;stdcall;
  end;

  TMyCOMServer   =   class(TObject,   IMyCOMTest)
  protected
    FLock:   integer;
    function   QueryInterface(const   IID:   TGUID;   out   Obj):   HResult;   stdcall;
    function   _AddRef:   Integer;   stdcall;
    function   _Release:   Integer;   stdcall;
  public
     Constructor   Create;
     function  msg:integer;stdcall;
  end;

 IClassFactory = interface(IUnknown)
 ['{00000001-0000-0000-C000-000000000046}']

    function   CreateInstance(const UnkOuter:IUnknown;const IID:TGUID;out Obj):HResult;stdcall;
    function   LockServer(fLock:   Boolean):   HResult;   stdcall;
  end;


  TClassFactory = class(TObject,IClassFactory)
  protected
    FLock:   integer;
    function QueryInterface(const IID:TGUID;out Obj):HResult;stdcall;
    function   _AddRef:Integer;stdcall;
    function   _Release:Integer;stdcall;
  public
    Constructor Create;
    function CreateInstance(const UnkOuter:IUnknown;const IID:TGUID;out Obj):HResult;stdcall;
    function LockServer(fLock:Boolean):HResult;stdcall;
  end;

  function   DllGetClassObject(const CLSID,IID:TGUID;var Obj):HResult;stdcall;
  function   DllCanUnloadNow: HResult;stdcall;
  function   DllRegisterServer: HResult;stdcall;
  function   DllUnregisterServer: HResult;stdcall;

implementation
var
  MC:IMyCOMTest;
  CF:IClassFactory;

  function   TMyCOMServer._AddRef:   Integer;
  begin
    Inc(FLock);
  end;

  function TMyCOMServer._Release:Integer;
  begin
    Dec(FLock);
    if FLock = 0 then
    Free;
  end;

  function TMyCOMServer.QueryInterface(const IID:TGUID; out Obj):HResult;
  begin
    Pointer(Obj) := Pointer(MC);
    Result := S_OK;
  end;

  constructor TMyCOMServer.Create;
  begin
    Inc(FLock);
  end;

  function TMyCOMServer.msg:integer;
  begin
    result := 1978;
  end;

  function TClassFactory.CreateInstance(const UnkOuter:IInterface;const IID:TGUID;out Obj):HResult;
  begin
    //我们的自定义接口，就是在这里被创建的。
    MC   :=   TMyCOMServer.Create;
    Pointer(Obj)   :=   Pointer(MC);
  end;

  function   TClassFactory.LockServer(fLock:   Boolean):   HResult;
  begin

  end;

  function   TClassFactory._AddRef:   Integer;
  begin
    Inc(FLock);
  end;

  function TClassFactory._Release:   Integer;
  begin
    Dec(FLock);
    if   FLock   =   0   then
    Free;
  end;

  function   TClassFactory.QueryInterface(const   IID:   TGUID;   out   Obj):   HResult;
  begin

  end;

 constructor   TClassFactory.Create;
 begin
  Inc(FLock);
 end;


 function   DllGetClassObject(const   CLSID,   IID:   TGUID;   var   Obj):   HResult;   
 begin
   CF   :=   TClassFactory.Create;
   Pointer(obj) := Pointer(CF);
   Result := S_OK;
 end;

 function   DllCanUnloadNow:   HResult;   
 begin
    Result := S_OK;
 end;

  function DllRegisterServer:HResult;
  var
   lp:   pchar;
   ns:   Dword;
   Reg : TRegistry;
  begin
    Result := S_FALSE;
    Reg := TRegistry.Create;
    GetMem(lp,255);
  try
    Reg.RootKey   :=   HKEY_CLASSES_ROOT;
    if   Reg.OpenKey('.MyCOMTest',true)   then
    begin
      Reg.CreateKey('CLSID');
      if   Reg.OpenKey('CLSID',true)   then
        Reg.WriteString('',GUIDToString(Class_MyCOM));
    end;
    if Reg.OpenKey(''+ GUIDToString(Class_MyCOM),true) then
    begin
      if   Reg.CreateKey('InprocServer32')   =   false   or
        Reg.CreateKey('ProgID') = false or
        Reg.CreateKey('TypeLib')   =  false or
        Reg.CreateKey('Version')   =   false   then
          Exit;

      Reg.WriteString('','MyCOM');

      if   Reg.OpenKey(''   +   GUIDToString(Class_MyCOM)   + '',   false)   then
      begin
        Windows.GetModuleFileName(HInstance,lp,   255);
        Reg.WriteString('',   lp);
        Reg.WriteString('ThreadingModel',   'Single');
      end;

      if   Reg.OpenKey(''   +   GUIDToString(Class_MyCOM)   +   '',   false)   then
         Reg.WriteString('','MyCOM.MyCOMTest');

      if Reg.OpenKey(''   +   GUIDToString(Class_MyCOM)   +   '',   false)   then
        Reg.WriteString('','1.0');

      if   Reg.OpenKey(''   +   GUIDToString(Class_MyCOM)   +   '',   false)   then
        Reg.WriteString('',GUIDToString(LIBID_MyCOM));

      Reg.CloseKey;

      Result := S_OK;

    end;

   finally
   begin
      FreeMem(lp);
      Reg.Free;
  end;

  end;

  end;

  function   DllUnRegisterServer:   Hresult;
  var
    Reg : TRegistry;
  begin
    Result := S_False;
    Reg := TRegistry.Create;

    try
      Reg.RootKey   :=   HKEY_CLASSES_ROOT;
      Reg.DeleteKey(''+   GUIDToString(Class_MyCOM));
      Reg.CloseKey;

    Finally
       Reg.Free;
    end;

  end;

end.