Delphi版Ocx制作CAB

最新推荐文章于 2019-01-08 00:56:38 发布

僵哥

最新推荐文章于 2019-01-08 00:56:38 发布

阅读量4.6k

点赞数

CC 4.0 BY-SA版权

分类专栏： COM Delphi 文章标签： delphi string api 工具 c

本文链接：https://blog.youkuaiyun.com/unsigned/article/details/2480885

Delphi 同时被 2 个专栏收录

16 篇文章

订阅专栏

COM

4 篇文章

订阅专栏

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;

//取得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;

//取得文件版本

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;

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,

False,

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.

示例代码：

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;