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;

 

 

评论 5
添加红包

请填写红包祝福语或标题

红包个数最小为10个

红包金额最低5元

当前余额3.43前往充值 >
需支付:10.00
成就一亿技术人!
领取后你会自动成为博主和红包主的粉丝 规则
hope_wisdom
发出的红包
实付
使用余额支付
点击重新获取
扫码支付
钱包余额 0

抵扣说明:

1.余额是钱包充值的虚拟货币,按照1:1的比例进行支付金额的抵扣。
2.余额无法直接购买下载,可以购买VIP、付费专栏及课程。

余额充值