Delphi读写COM复合文档用户自定义属性参考代码

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_SHARE_EXCLUSIVE,nil,0,Storage)<>S_OK then Exit;
  PSStorage:=Storage as IPropertySetStorage;
  if PSStorage.Open(FMTID_UserDefinedProperties,STGM_READ or STGM_SHARE_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 of
      //整数
      VT_I4:FNameValues[FCount-1].Value:=PVArray[0].lVal;
      //实数
      VT_R8:FNameValues[FCount-1].Value:=PVArray[0].dblVal;
      //是否
      VT_BOOL:FNameValues[FCount-1].Value:=PVArray[0].boolVal;
      //字符
      VT_LPSTR:FNameValues[FCount-1].Value:=UTF8Decode(PVArray[0].pszVal);//一定要解码
      //日期
      VT_FILETIME:
        begin
          //日期要转换到当前时区
          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_SHARE_EXCLUSIVE,nil,0,Storage)<>S_OK then Exit;
  PSStorage:=Storage as IPropertySetStorage;
  if PSStorage.Open(FMTID_UserDefinedProperties,STGM_READWRITE or STGM_SHARE_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 of
      //整数
      VT_I4:PVArray[0].lVal:=Value;
      //实数
      VT_R8:PVArray[0].dblVal:=Value;
      //是否
      VT_BOOL:PVArray[0].boolVal:=Value;
      //字符
      VT_LPSTR:PVArray[0].pszVal:=PAnsiChar(UTF8Encode(Value));
      //日期
      VT_FILETIME:
      begin
        DateTimeToSystemTime(Value,Systime);
        SystemTimeToFileTime(Systime,LocalFileTime);
        LocalFileTimeToFileTime(LocalFileTime,PVArray[0].filetime);
      end;
  end;
  case PVArray[0].vt of
    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.