Delphi版Ocx制作CAB

unit UnitMakeCAB;

interface
  uses
      ActiveX
    , SysUtils
    , Classes
    , Windows;

// .inf文件模板
const
  Templete  =
     ' ; %Title% ' # 13 # 10 +
     ' ; File Name %DLLName%  File Version= %DllVersion% ' # 13 # 10 +
     ' ; ProgId= %ProgId% ClassId= %DLLClsid% ' # 13 # 10 # 13 # 10 +
     ' [version] ' # 13 # 10 +
     ' signature="$CHICAGO$" ' # 13 # 10 +
     ' AdvancedINF=2.0 ' # 13 # 10 # 13 # 10 +
     ' [Add.Code] ' # 13 # 10 +
     ' %DLLName%=%DLLName% ' # 13 # 10 # 13 # 10 +
     ' [%DLLName%] ' # 13 # 10 +
     ' file-win32-x86=thiscab ' # 13 # 10 +
     ' RegisterServer=yes ' # 13 # 10 +
     ' clsid=%DLLClsid% ' # 13 # 10 +
     ' DestDir= ' # 13 # 10 +
     ' FileVersion=%DLLVersion% ' # 13 # 10 # 13 # 10 +
     ' [Setup Hooks] ' # 13 # 10 +
     ' AddToRegHook=AddToRegHook ' # 13 # 10 # 13 # 10 +
     ' [AddToRegHook] ' # 13 # 10 +
     ' InfSection=DefaultInstall ' # 13 # 10 # 13 # 10 +
     ' [DefaultInstall] ' # 13 # 10 +
     ' AddReg=AddToRegistry ' # 13 # 10 # 13 # 10 +
     ' [AddToRegistry] ' # 13 # 10 +
     ' HKLM,"SOFTWAREClassesCLSID%DLLClsid%Implemented Categories{7DD95801-9882-11CF-9FA9-00AA006C42C4}" ' # 13 # 10 +
     ' HKLM,"SOFTWAREClassesCLSID%DLLClsid%Implemented Categories{7DD95802-9882-11CF-9FA9-00AA006C42C4}" ' ;

// MackCab 用的中间文件模板,文件附加在后面，不能带路径（估计可以支持8.3短路径)
  MakeCabDirective  =
     ' .OPTION EXPLICIT     ; Generate errors ' # 13 # 10 +
     ' .Set CabinetNameTemplate=%CABFile% ' # 13 # 10 +
     ' .set DiskDirectoryTemplate=CDROM ; All cabinets go in a single  directory ' # 13 # 10 +
     ' .Set CompressionType=MSZIP;** All files are compressed in cabinet files ' # 13 # 10 +
     ' .Set UniqueFiles="OFF" ' # 13 # 10 +
     ' .Set Cabinet=on ' # 13 # 10 +
     ' .Set DiskDirectory1=%CABFilePath% ' # 13 # 10 ;

// 取得CoClass的ClassID
function  GetCLSID(FileName: String): WideString;
// 取得ProgID
function  GetProgID(FileName: String): String;
// 制作用于发布的CAB包
procedure  MakeCAB(FileName: String);

implementation

// 取得CoClass的ClassID
function  GetCLSID(FileName: String): WideString;
var
  spTypeLib: ITypeLib;
  spTypeInfo: ITypeInfo;
  pta: PTypeAttr;
  hr: HRESULT;
   Count , I: UINT;

begin
  Result : =   ' {00000000-0000-0000-0000-000000000000} ' ;
  hr : =  LoadTypeLib(PWideChar(WideString(FileName)),spTypeLib);
   if  Failed(hr)  then   Exit ;
   Count  : =  spTypeLib.GetTypeInfoCount;
  I : =   0 ;
   while  I  <   Count  do  begin
    hr : =  spTypeLib.GetTypeInfo(I, spTypeInfo);
     if  Failed(hr)  then   Exit ;
    hr : =  spTypeInfo.GetTypeAttr(pta);
     if  Failed(hr)  then   Exit ;
     if  TKIND_COCLASS  =  pta.typekind  then   begin
      StringFromGUID2(pta.guid, PWideChar(Result), Length(Result) *  sizeof(WideChar));
      spTypeInfo.ReleaseTypeAttr(pta);
      pta : =  Nil;
       Exit ;
     end ;
    spTypeInfo.ReleaseTypeAttr(pta);
    pta : =  Nil;
    Inc(I);
   end ;
end ;

// 取得ProgID
function  GetProgID(FileName: String): String;
var
  spTypeLib: ITypeLib;
  spTypeInfo: ITypeInfo;
  pta: PTypeAttr;
  hr: HRESULT;
   Count , I: UINT;
  bstrName0, bstrName: WideString;
begin
  Result : =   '' ;
  hr : =  LoadTypeLib(PWideChar(WideString(FileName)),spTypeLib);
   if  Failed(hr)  then   Exit ;
   Count  : =  spTypeLib.GetTypeInfoCount;
  hr : =  spTypeLib.GetDocumentation(    - 1
                                    ,  @bstrName0
                                    , Nil
                                    ,  0
                                    , Nil
                                    );
   if  Failed(hr)  then   Exit ;
  I : =   0 ;
   while  I  <   Count  do  begin
    hr : =  spTypeLib.GetTypeInfo(I, spTypeInfo);
     if  Failed(hr)  then   Exit ;
    hr : =  spTypeInfo.GetDocumentation(   - 1
                                      ,  @bstrName
                                      , Nil
                                      ,  0
                                      , Nil
                                      );
     if  Failed(hr)  then   Exit ;
    hr : =  spTypeInfo.GetTypeAttr(pta);
     if  Failed(hr)  then   Exit ;
     if  TKIND_COCLASS  =  pta.typekind  then   begin
      Result : =  WideString(bstrName0)  +   ' . '   +  WideString(bstrName);
      spTypeInfo.ReleaseTypeAttr(pta);
      pta : =  Nil;
       Exit ;
     end ;
    spTypeInfo.ReleaseTypeAttr(pta);
    pta : =  Nil;
    Inc(I);
   end ;
end ;

// 取得文件版本
function  GetVersion(FileName: String): String;
var
    dwHandle: DWORD ;
    m_szVersion: array [ 0..255 ]   of   char ;
    dwVerSize: DWORD;
    pbBuffer: PChar;
    lpVSInfo: PVSFixedFileInfo;
    uiVerSize: UINT;
begin
  Result : =   ' 0,0,0,0 ' ;
  uiVerSize : =   0 ;
  dwVerSize  : =  GetFileVersionInfoSize(PChar(FileName),  & dwHandle);
  lpVSInfo : =  Nil;
  pbBuffer : =  AllocMem( dwVerSize);
     if  (pbBuffer  =  Nil)  then   Exit ;
     if  (GetFileVersionInfo(PChar(FileName),  0 , dwVerSize, pbBuffer))  then   begin
         if  (VerQueryValue(pbBuffer,  ' ' , Pointer(lpVSInfo), uiVerSize))  then   begin
            Result : =  Format(  ' %d,%d,%d,%d ' ,
                                     [  (lpVSInfo^.dwFileVersionMS shr 16) and $FFFF,
                                      lpVSInfo^.dwFileVersionMS and $FFFF,
                                      (lpVSInfo^.dwFileVersionLS shr 16) and $FFFF,
                                      lpVSInfo^.dwFileVersionLS and $FFFF
                         ]
                                  );
     end ;
   end ;

    FreeMem(pbBuffer);
end ;

// 制作用于发布的CAB包
procedure  MakeCAB(FileName: String);
var
  CABFileName, DDFFileName, InfFileName: String;
  F: TFileStream;
  P: PChar;
  iLen, iWrote:  Integer ;

  Title, DLLName, ProgID, ClsID, FileVer: String;

  CABDirective, InfFile: String;

  _hfile: HFILE;
    mCreationTime, mLastAccessTime, mLastWriteTime: FILETIME;

    StartInfo: STARTUPINFO ;  //  name structure
    ProcInfo: PROCESS_INFORMATION ;  //  name structure
begin
  CoInitialize(Nil);
  try
    FileVer : =  GetVersion(FileName);
    ClsID : =  GetCLSID(FileName);
    DLLName : =  ExtractFileName(FileName);
    ProgID : =  GetProgID(FileName);
    Title : =   ' Ocx Inf file Maker ' ;
    InfFileName : =  ChangeFileExt(FileName,  ' .inf ' );
    CabFileName : =  ChangeFileExt(FileName,  ' .cab ' );
    DDFFileName : =  ChangeFileExt(FileName,  ' .ddf ' );

    CABDirective : =     StringReplace(    MakeCabDirective,
                                     ' %CABFile% ' ,
                                    ExtractFileName(CabFileName),
                                     [ rfReplaceAll, rfIgnoreCase ]
                                    );
    CABDirective : =     StringReplace(    CABDirective,
                                     ' %CABFilePath% ' ,
                                    ExtractFilePath(CabFileName),
                                     [ rfReplaceAll, rfIgnoreCase ]
                                    )
                     +   ' " '   +  FileName  +   ' " '
                     +     # 13 # 10 ' " '   +  InfFileName  +   ' " ' ;

     // 如果还有其它附加文件需要打包请在这里增加一个CallBack
     // 直接按每文件一行往上附加

    InfFile : =  StringReplace(  Templete,
                               ' %Title% ' ,
                              Title,
                               [ rfReplaceAll, rfIgnoreCase ]
                              );
    InfFile : =  StringReplace(    InfFile,
                               ' %DLLName% ' ,
                              DLLName,
                               [ rfReplaceAll, rfIgnoreCase ]
                              );
    InfFile : =  StringReplace(    InfFile,
                               ' %DllVersion% ' ,
                              FileVer,
                               [ rfReplaceAll, rfIgnoreCase ]
                              );
    InfFile : =  StringReplace(    InfFile,
                               ' %ProgId% ' ,
                              ProgID,
                               [ rfReplaceAll, rfIgnoreCase ]
                              );
    InfFile : =  StringReplace(    InfFile,
                               ' %DLLClsid% ' ,
                              ClsID,
                               [ rfReplaceAll, rfIgnoreCase ]
                              );

     // 写入INF文件
    f : =  TFileStream. Create (InfFileName,fmCreate);
    try
      p : =  PChar(InfFile);
      iLen : =  Length(InfFile);
       while  (iLen  >   0 ) do  begin
        iWrote : =  f.Write(p ^ , iLen);
        Inc(p, iWrote);
         Dec (iLen, iWrote);
       end ;
    finally
      f.Free;
     end ;

     // 如果还有其它附加文件请在这里增加一个CallBack
     // 文件通常有两类: 1 .需要注册的; 2 .不需要注册的.
     // 另外就是文件可能安装目录有两种: 1 .当前目录（即随机目录）; 2 .特定目录(可以使用环境变量)
     // 写Inf文件请按照.Ini格式，比如TIniFile类或者API来操作等


     // 更新.INF的文件时间为.OCX的时间
    _hFile : =  _lopen(PChar(FileName), OF_READWRITE);
    GetFileTime(  THANDLE(_hFile),
                   @mCreationTime ,
                   @mLastAccessTime ,
                   @mLastWriteTime
                  );
    _lclose(_hFile);

    _hFile : =  _lopen(PChar(InfFile), OF_READWRITE);
    SetFileTime(    THANDLE(_hFile),
                   @mCreationTime ,
                   @mLastAccessTime ,
                   @mLastWriteTime
                  );
    _lclose(_hFile);

     // 写入DDF文件,供工具程序MakeCab.exe使用
    f : =  TFileStream. Create (DDFFileName,fmCreate);
    try
      p : =  PChar(CABDirective);
      iLen : =  Length(CABDirective);
       while  (iLen  >   0 ) do  begin
        iWrote : =  f.Write(p ^ , iLen);
        Inc(p, iWrote);
         Dec (iLen, iWrote);
       end ;
    finally
      f.Free;
     end ;

     // 执行MakeCAB创建CAB包

    fillchar(ProcInfo, sizeof(ProcInfo),  0 );  //   Set  up memory block
    fillchar(StartInfo, sizeof(StartInfo),  0 );  //   Set  up memory block
    StartInfo.cb : =  sizeof(StartInfo);  //   Set  structure size
     if   Not  CreateProcess( Nil,
                          PChar( ' makecab /f " '   +  DDFFileName  +   ' " ' ),
                          Nil,
                          Nil,
                          False,
                           0 ,
                          Nil,
                          PChar(ExtractFilePath(FileName)),
                          StartInfo,
                          ProcInfo)  then
       Exit ;

    WaitForSingleObject(ProcInfo.hProcess, INFINITE);
    CloseHandle(ProcInfo.hThread);
    CloseHandle(ProcInfo.hProcess);

     // 更新CAB的文件时间为.OCX的时间
    _hFile : =  _lopen(PChar(FileName), OF_READWRITE);
    GetFileTime(  THANDLE(_hFile),
                   @mCreationTime ,
                   @mLastAccessTime ,
                   @mLastWriteTime
                  );
    _lclose(_hFile);

    _hFile : =  _lopen(PChar(CabFileName), OF_READWRITE);
    SetFileTime(    THANDLE(_hFile),
                   @mCreationTime ,
                   @mLastAccessTime ,
                   @mLastWriteTime
                  );
    _lclose(_hFile);
  finally
    CoUninitialize;
   end ;

end ;
end .

示例代码：

uses
    UnitMakeCAB;
procedure TForm3.Button1Click(Sender: TObject);
var
  FileName: String;
begin
   if  OpenDialog1.Execute then begin
    FileName : =  OpenDialog1.FileName;
     if  SameText(ExtractFileExt(FileName),  ' .ocx ' ) then begin
      MakeCAB(FileName);
    end;
  end;
end;