User-Defined attributes reference code

Unit userdefinedproperties;

{$ Warn symbol_platform off}

Interface

Uses
Comobj, ActiveX, localfiles_tlb, stdvcl;

Type

Tvariantnamevalue = packed record
Name: string;
Value: variant;
End;

Tvariantnamevaluelist = array of tvariantnamevalue;

Tuserdefinedproperties = Class (tautoobject, iuserdefinedproperties)
Private
Ffilepath: widestring;
Fnamevalues: tvariantnamevaluelist;
Fcount: integer;
Private
Procedure set_filepath (value: widestring );
Procedure getproperties;
Public
Procedure initialize; override;
Protected
Function get_count: integer; safecall;
Function get_name (Index: integer): widestring; safecall;
Function get_value (Index: integer): olevariant; safecall;
Function get_getvaluebyname (const name: widestring): olevariant; safecall;
Procedure setvaluebyname (const name: widestring; Value: olevariant );
Safecall;
Public
Property filepath: widestring read ffilepath write set_filepath;
End;

Implementation

Uses comserv, dialogs, sysutils, variants, windows, classes;

{Tuserdefinedproperties}

Procedure tuserdefinedproperties. getproperties;
Const
Fmtid_userdefinedproperties: tguid = '{D5CDD505-2E9C-101B-9397-08002B2CF9AE }';
Type
Tpropspecarray = array [0 .. 0] of tpropspec;
Ppropspecarray = ^ tpropspecarray;
Tpropvariantarray = array [0 .. 0] of tpropvariant;
Ppropvariantarray = ^ tpropvariantarray;
Tstatpropstgarray = array [0 .. 0] of tstatpropstg;
Pstatpropstgarray = ^ tstatpropstgarray;
VaR
Storage: istorage;
Psstorage: ipropertysetstorage;
PS: ipropertystorage;
Enum: ienumstatpropstg;
Psarray: ppropspecarray;
Pvarray: ppropvariantarray;
SPS: pstatpropstgarray;
Localfiletime: tfiletime;
Systime: tsystemtime;
Begin
If stgopenstorage (stringtoolestr (ffilepath), nil, stgm_read or stgm_clu_exclusive, nil, 0, storage) <> s_ OK then exit;
Psstorage: = storage as ipropertysetstorage;
If psstorage. Open (fmtid_userdefinedproperties, stgm_read or stgm_clu_exclusive, PS) <> s_ OK then exit;
//
Getmem (psarray, sizeof (tpropspec ));
Getmem (pvarray, sizeof (tpropvariant ));
Getmem (SPS, sizeof (tstatpropstg ));
//
If ps. Enum (Enum) <> s_ OK then exit;
While enum. Next (1, SPS [0], nil) = s_ OK do
Begin
INC (fcount );
Psarray [0]. ulkind: = prspec_propid;
Psarray [0]. propid: = SPS [0]. propid;
PS. readmultiple (1, @ psarray [0], @ pvarray [0]);
Setlength (fnamevalues, fcount );
Fnamevalues [FCount-1]. Name: = widechartostring (SPS [0]. lpwstrname );
Case pvarray [0]. Vt
// Integer
Vt_i4: fnamevalues [FCount-1]. Value: = pvarray [0]. lval;
// Real number
Vt_r8: fnamevalues [FCount-1]. Value: = pvarray [0]. dblval;
// Whether
Vt_bool: fnamevalues [FCount-1]. Value: = pvarray [0]. boolval;
// Character
Vt_lpstr: fnamevalues [FCount-1]. Value: = utf8decode (pvarray [0]. pszval); // be sure to decode
// Date
Vt_filetime:
Begin
// Convert the date to the current time zone
Filetimetolocalfiletime (pvarray [0]. filetime, localfiletime );
Filetimetosystemtime (localfiletime, systime );
Fnamevalues [FCount-1]. Value: = systemtimetodatetime (systime );
End;
End;
End;
//
If psarray <> nil then freemem (psarray );
If pvarray <> nil then freemem (pvarray );
If SPS <> nil then freemem (SPS );
//
PS: = nil;
Psstorage: = nil;
End;

Procedure tuserdefinedproperties. initialize;
Begin
Inherited;
Fcount: = 0;
End;

Procedure tuserdefinedproperties. set_filepath (value: widestring );
Begin
Ffilepath: = value;
Getproperties;
End;

Function tuserdefinedproperties. get_count: integer;
Begin
Result: = fcount;
End;

Function tuserdefinedproperties. get_name (Index: integer): widestring;
Begin
If (index> = 0) and (index <fcount) then result: = fnamevalues [Index]. Name
Else result: = '';
End;

Function tuserdefinedproperties. get_value (Index: integer): olevariant;
Begin
If (index> = 0) and (index <fcount) then result: = fnamevalues [Index]. Value
Else result: = NULL;
End;

Function tuserdefinedproperties. get_getvaluebyname (
Const name: widestring): olevariant;
VaR
Counter: integer;
Begin
For counter: = 0 to FCount-1 do
If widecomparetext (name, fnamevalues [Counter]. Name) = 0 then
Begin
Result: = fnamevalues [Counter]. value;
Exit;
End;
Result: = NULL;
End;

Procedure tuserdefinedproperties. setvaluebyname (const name: widestring;
Value: olevariant );
Const
Fmtid_userdefinedproperties: tguid = '{D5CDD505-2E9C-101B-9397-08002B2CF9AE }';
Type
Tpropspecarray = array [0 .. 0] of tpropspec;
Ppropspecarray = ^ tpropspecarray;
Tpropvariantarray = array [0 .. 0] of tpropvariant;
Ppropvariantarray = ^ tpropvariantarray;
Tstatpropstgarray = array [0 .. 0] of tstatpropstg;
Pstatpropstgarray = ^ tstatpropstgarray;
VaR
Storage: istorage;
Psstorage: ipropertysetstorage;
PS: ipropertystorage;
Psarray: ppropspecarray;
Pvarray: ppropvariantarray;
Localfiletime: tfiletime;
Systime: tsystemtime;
Begin
If stgopenstorage (stringtoolestr (ffilepath), nil, stgm_readwrite or stgm_clu_exclusive, nil, 0, storage) <> s_ OK then exit;
Psstorage: = storage as ipropertysetstorage;
If psstorage. Open (fmtid_userdefinedproperties, stgm_readwrite or stgm_clu_exclusive, PS) <> s_ OK then exit;
//
Getmem (psarray, sizeof (tpropspec ));
Getmem (pvarray, sizeof (tpropvariant ));
//
Psarray [0]. ulkind: = prspec_lpwstr;
Psarray [0]. lpwstr: = pwidechar (name );
Pvarray [0]. Vt: = vartype (value );
If pvarray [0]. Vt = vt_bstr then pvarray [0]. Vt: = vt_lpstr;
If pvarray [0]. Vt = vt_date then pvarray [0]. Vt: = vt_filetime;
//
Case pvarray [0]. Vt
// Integer
Vt_i4: pvarray [0]. lval: = value;
// Real number
Vt_r8: pvarray [0]. dblval: = value;
// Whether
Vt_bool: pvarray [0]. boolval: = value;
// Character
Vt_lpstr: pvarray [0]. pszval: = pansichar (utf8encode (value ));
// Date
Vt_filetime:
Begin
Datetimetosystemtime (value, systime );
Systemtimetofiletime (systime, localfiletime );
Localfiletimetofiletime (localfiletime, pvarray [0]. filetime );
End;
End;
Case pvarray [0]. Vt
Vt_i4, vt_r8, vt_bool, vt_lpstr, vt_filetime:
PS. writemultiple (1, @ psarray [0], @ pvarray [0], 2 );
End;
//
If psarray <> nil then freemem (psarray );
If pvarray <> nil then freemem (pvarray );
//
PS: = nil;
Psstorage: = nil;
End;

Initialization
Tautoobjectfactory. Create (comserver, tuserdefinedproperties, class_userdefinedproperties,
Cimultiinstance, tmapartment );
End.