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;
