unit UnitPropertySet;
interface
uses Windows, SysUtils, ComObj, ActiveX;
type
TPropertySet = class
private
FFileName: WideString;
FActive: Boolean;
FPropertySetStorage: IPropertySetStorage;
FPropertyStorage: IPropertyStorage;
FStorage: IStorage;
FStreamGUID: TGUID;
procedure SetActive(const Value: Boolean);
procedure SetFileName(const Value: WideString);
procedure SetStreamGUID(const Value: TGUID);
protected
procedure InternalOpen; dynamic;
procedure InternalClose; dynamic;
public
constructor Create;
destructor Destroy; override;
procedure Open;
procedure Close;
function GetPropertyByName(APropertyName: WideString): TPropVariant;
function GetPropertyByID(APropertyID: Integer): TPropVariant;
property Active: Boolean read FActive write SetActive;
property FileName: WideString read FFileName write SetFileName;
property StreamGUID: TGUID read FStreamGUID write SetStreamGUID;
end;
const
FMTID_SummaryInformation: TGUID = '{F29F85E0-4FF9-1068-AB91-08002B27B3D9}';
FMTID_DocumentSummaryInformation: TGUID = '{D5CDD502-2E9C-101B-9397-08002B2CF9AE}';
FMTID_UserDefinedProperties: TGUID = '{D5CDD505-2E9C-101B-9397-08002B2CF9AE}';
IID_IPropertySetStorage : TGUID = '{0000013A-0000-0000-C000-000000000046}';
implementation
type
TPropSpecArray = array [0..1000] of TPropSpec;
PPropSpecArray = ^TPropSpecArray;
TPropVariantArray = array [0..1000] of TPropVariant;
PPropVariantArray = ^TPropVariantArray;
tagSTGOPTIONS = record
usVersion: ShortInt;
reserved: Short;
ulSectorSize: LongInt;
pwcsTemplateFile: PWideChar;
end;
STGOPTIONS = ^tagSTGOPTIONS;
const
STGFMT_STORAGE = 0;
STGFMT_FILE = 3;
STGFMT_ANY = 4;
STGFMT_DOCFILE = 5;
function StgOpenStorageEx(const pwcsName: POleStr; grfMode: Longint;
stgfmt: DWORD; grfAttrs: DWORD; pStgOptions: STGOPTIONS; reserved2: Pointer;
riid: PGUID; out ppObjectOpen: IStorage): HResult; stdcall;
external 'ole32.dll';
constructor TPropertySet.Create;
begin
inherited;
FStreamGUID := FMTID_SummaryInformation;
end;
destructor TPropertySet.Destroy;
begin
Close;
end;
procedure TPropertySet.Open;
begin
Active := True;
end;
procedure TPropertySet.Close;
begin
Active := False;
end;
function TPropertySet.GetPropertyByName(APropertyName: WideString): TPropVariant;
var
ps: PPropSpecArray;
pv: PPropVariantArray;
begin
ps := nil;
pv := nil;
try
GetMem(ps, sizeof(TPropSpec));
GetMem(pv, sizeof(TPropVariant));
ps[0].ulKind := PRSPEC_LPWSTR;
ps[0].lpwstr := PWideChar(APropertyName);
OleCheck(FPropertyStorage.ReadMultiple(1, @ps[0], @pv[0]));
Result := pv[0];
finally
if ps <> nil then
FreeMem(ps);
if pv <> nil then
FreeMem(pv);
end;
end;
function TPropertySet.GetPropertyByID(APropertyID: Integer): TPropVariant;
var
ps: PPropSpecArray;
pv: PPropVariantArray;
begin
ps := nil;
pv := nil;
try
GetMem(ps, sizeof(TPropSpec));
GetMem(pv, sizeof(TPropVariant));
ps[0].ulKind := PRSPEC_PROPID;
ps[0].propid := APropertyID;
OleCheck(FPropertyStorage.ReadMultiple(1, @ps[0], @pv[0]));
Result := pv[0];
finally
if ps <> nil then
FreeMem(ps);
if pv <> nil then
FreeMem(pv);
end;
end;
procedure TPropertySet.InternalOpen;
begin
if FFileName = '' then
raise Exception.Create('文件名必须设置!');
OleCheck(StgOpenStorageEx(PWChar(FFileName), STGM_READ or STGM_SHARE_DENY_WRITE,
STGFMT_ANY, 0, nil, nil, @IID_IPropertySetStorage, FStorage));
FPropertySetStorage := FStorage as IPropertySetStorage;
OleCheck(FPropertySetStorage.Open(FStreamGUID, STGM_READ or STGM_SHARE_EXCLUSIVE,
FPropertyStorage));
end;
procedure TPropertySet.InternalClose;
begin
FPropertyStorage := nil;
FPropertySetStorage := nil;
FStorage := nil;
end;
procedure TPropertySet.SetActive(const Value: Boolean);
begin
if FActive <> Value then
begin
if Value then
InternalOpen
else
InternalClose;
FActive := Value;
end;
end;
procedure TPropertySet.SetFileName(const Value: WideString);
begin
if FFileName <> Value then
begin
if FActive then
begin
InternalClose;
FFileName := Value;
InternalOpen;
end
else
FFileName := Value;
end;
end;
procedure TPropertySet.SetStreamGUID(const Value: TGUID);
begin
if (FStreamGUID<>Value) then
begin
if FActive then
begin
InternalClose;
FStreamGUID := Value;
InternalOpen;
end
else
FStreamGUID := Value;
end;
end;
end.
-------------------------------------
String再转换回来呗!