unit MainUnit;

{
Пример работы с наборами свойств NTFS и Structured Storage

Autor: Набережных С.Н.
Creation:       21/01/2006
Last modified:  -
}

interface

uses
  Windows, Messages, SysUtils, Variants,
  Classes, Graphics, Controls, Forms,
  Dialogs, StdCtrls, ComCtrls, ExtCtrls,
  PropSets, XPMan, Menus, ActnList, ActiveX;

type
  TMainForm = class(TForm)
    OpenDialog1: TOpenDialog;
    XPManifest1: TXPManifest;
    Panel1: TPanel;
    lvProps: TListView;
    MainMenu1: TMainMenu;
    rmiFile: TMenuItem;
    rmiSets: TMenuItem;
    miOpenFile: TMenuItem;
    miCloseFile: TMenuItem;
    N1: TMenuItem;
    miExit: TMenuItem;
    StatusBar1: TStatusBar;
    lvPropSets: TListView;
    Splitter1: TSplitter;
    rmiProperties: TMenuItem;
    miAddPropSet: TMenuItem;
    miDeletePropSet: TMenuItem;
    miAddProp: TMenuItem;
    miDeleteProp: TMenuItem;
    miEditProp: TMenuItem;
    ActionList1: TActionList;
    actOpen: TAction;
    actClose: TAction;
    actExit: TAction;
    actAddPropSet: TAction;
    actDeletePropSet: TAction;
    actAddProp: TAction;
    actDelProp: TAction;
    actEditProp: TAction;
    actRenamePropSet: TAction;
    miRenamePropSet: TMenuItem;
    actRenameProp: TAction;
    miRenameProp: TMenuItem;
    N2: TMenuItem;
    procedure FormCreate(Sender: TObject);
    procedure FormDestroy(Sender: TObject);
    procedure FormResize(Sender: TObject);
    procedure lvPropSetsChange(Sender: TObject; Item: TListItem;
      Change: TItemChange);
    procedure actOpenExecute(Sender: TObject);
    procedure actExitExecute(Sender: TObject);
    procedure actCloseUpdate(Sender: TObject);
    procedure actAddPropSetExecute(Sender: TObject);
    procedure actAddPropSetUpdate(Sender: TObject);
    procedure actDeletePropSetUpdate(Sender: TObject);
    procedure actDeletePropSetExecute(Sender: TObject);
    procedure actCloseExecute(Sender: TObject);
    procedure actRenamePropSetExecute(Sender: TObject);
    procedure actAddPropUpdate(Sender: TObject);
    procedure actDelPropUpdate(Sender: TObject);
    procedure actAddPropExecute(Sender: TObject);
    procedure actDelPropExecute(Sender: TObject);
    procedure actRenamePropExecute(Sender: TObject);
    procedure actEditPropExecute(Sender: TObject);
  private
    { Private declarations }
    FPropSetsStg: TStgPropertySet;
    FPropSetIndex: integer;
    procedure OpenPropertySetStorage(const AFileName: string);
    procedure RefreshPropertySets;
    procedure RefreshProperties(PropSetItem: TListItem);
    function GetVarTypeString(TypeID: Word): string;
  public
    { Public declarations }
  end;

var
  MainForm: TMainForm;

implementation

uses
  AddPropSetDlgUnit, Math, AddPropDlgUnit;

{$R *.dfm}

procedure TMainForm.FormResize(Sender: TObject);
begin
  StatusBar1.Panels[0].Width:= ClientHeight;
end;

procedure TMainForm.FormCreate(Sender: TObject);
begin
  Caption:= Application.Title;
  FPropSetIndex:= -1;
end;

procedure TMainForm.lvPropSetsChange(Sender: TObject; Item: TListItem;
  Change: TItemChange);
var
  FmtID: TGUID;
begin
  if ctState <> Change then Exit;

  if (nil <> Item) and Item.Selected then
  begin
    if lvPropSets.ItemIndex = FPropSetIndex then Exit;
    FPropSetIndex:= lvPropSets.ItemIndex;
    FmtID:= StringToGUID(Item.Caption);
  end else
  begin
    FPropSetIndex:= -1;
    FmtID:= GUID_NULL;
  end;

  if nil <> FPropSetsStg then FPropSetsStg.Select(FmtID);
  RefreshProperties(Item);
end;

procedure TMainForm.FormDestroy(Sender: TObject);
begin
  lvPropSets.OnChange:= nil;
  FPropSetsStg.Free;
end;

procedure TMainForm.actOpenExecute(Sender: TObject);
begin
  if not OpenDialog1.Execute then exit;
  OpenPropertySetStorage(OpenDialog1.FileName);
end;

procedure TMainForm.actExitExecute(Sender: TObject);
begin
  Close;
end;

procedure TMainForm.actCloseUpdate(Sender: TObject);
begin
  TAction(Sender).Enabled:= FPropSetsStg <> nil;
end;

procedure TMainForm.actAddPropSetExecute(Sender: TObject);
var
  ID: TGUID;
  PSName: WideString;
begin
  if not TfrmAddPropSet.Execute(ID, PSName) then Exit;
  FPropSetsStg.AddPropSet(ID, GUID_NULL, PSName);
  RefreshPropertySets;
end;

procedure TMainForm.actAddPropSetUpdate(Sender: TObject);
begin
  TAction(Sender).Enabled:= nil <> FPropSetsStg;
end;

procedure TMainForm.actDeletePropSetUpdate(Sender: TObject);
begin
  TAction(Sender).Enabled:= lvPropSets.ItemIndex > -1;
end;

procedure TMainForm.actDeletePropSetExecute(Sender: TObject);
var
  ID: TGUID;
begin
  ID:= StringToGUID(lvPropSets.Items[lvPropSets.ItemIndex].Caption);
  FPropSetsStg.DeletePropSet(ID);
  RefreshPropertySets;
end;

procedure TMainForm.OpenPropertySetStorage(const AFileName: string);
var
  PS: TStgPropertySet;
begin
  lvPropSets.Items.Clear;
  lvProps.Items.Clear;
  if AFileName = StatusBar1.Panels[0].Text then FreeAndNil(FPropSetsStg);
  if S_OK = StgIsStorageFile(PWideChar(WideString(AFileName))) then
    PS:= TDocFilePropertySet.Create(AFileName, prsReadWrite)
  else
    PS:=TNtfsPropertySet.Create(AFileName, prsReadWrite);
  FreeAndNil(FPropSetsStg);
  FPropSetsStg:= PS;
  StatusBar1.Panels[0].Text:= AFileName;
  Caption:= Application.Title + ' - ' + ExtractFileName(AFileName);
  RefreshPropertySets;
end;

procedure TMainForm.RefreshProperties(PropSetItem: TListItem);
var
  NewItem: TListItem;
  Info: TPropInfoList;
  Spec: TPropSpecList;
  Vals: TPropVariantList;
  n: integer;
  s: string;
  SetGuid: TGUID;
  SetID: TPredefinedPropSet;
begin
  lvProps.Clear;
  if nil = PropSetItem then Exit;
  if not PropSetItem.Selected then Exit;

  FPropSetsStg.GetPropSetGuid(SetGuid);
  SetID:= PropSetIdToPredefId(SetGuid);
  FPropSetsStg.GetPropsInfo(Info);
  try
    GetSpecificationFromInfo(Info, Spec);
    FPropSetsStg.ReadProps(Spec, Vals);
    try
      for n:=0 to Pred(Length(Info)) do
      begin
        NewItem:=lvProps.Items.Add;
        NewItem.Caption:=IntToStr(Info[n].propid);
        s:= GetKnownPropName(SetID, Info[n].propid);
        if s = '' then s:= Info[n].lpwstrName;
        NewItem.SubItems.Add(s);
        NewItem.SubItems.Add(GetVarTypeString(Info[n].vt));
        if not PropVariantToStr(Vals[n], s) then s:= '<Not converted>';
        NewItem.SubItems.Add(s);
      end;
    finally
      FPropSetsStg.FinalizePropVariants(Vals);
    end;
  finally
    FPropSetsStg.FinalizeInformationList(Info);
  end;
end;

procedure TMainForm.RefreshPropertySets;
var
  Arr: TPropSetsList;
  n: integer;
  Item: TListItem;
  s: string;
begin
  lvPropSets.Clear;
  FPropSetsStg.GetPropSets(Arr);
  for n:= 0 to Pred(Length(Arr)) do
  begin
    Item:= lvPropSets.Items.Add;
    Item.Caption:= GUIDToString(Arr[n].fmtid);

    case PropSetIdToPredefId(Arr[n].fmtid) of

      ppsNoPredef: begin
                     FPropSetsStg.Select(Arr[n].fmtid);
                     s:= FPropSetsStg.GetPropSetName;
                   end;

      ppsSumInfo:    s:= 'SummaryInformation';
      ppsDocSumInfo: s:= 'DocSummaryInformation';
      ppsUserDef:    s:= 'UserDefinedProperties';

    end;
    Item.SubItems.Add(s);
  end;
  if lvPropSets.Items.Count > 0 then lvPropSets.ItemIndex:= 0;
end;

procedure TMainForm.actCloseExecute(Sender: TObject);
begin
  lvPropSets.Clear;
  lvProps.Clear;
  FreeAndNil(FPropSetsStg);
  StatusBar1.Panels[0].Text:= '';
  Caption:= Application.Title;
end;

procedure TMainForm.actRenamePropSetExecute(Sender: TObject);
var
  ID: TGUID;
  NewName: string;
begin
  NewName:= lvPropSets.Items[lvPropSets.ItemIndex].SubItems[0];
  if not InputQuery('Rename property set', 'Input new name:', NewName)
  then Exit;
  ID:= StringToGUID(lvPropSets.Items[lvPropSets.ItemIndex].Caption);
  FPropSetsStg.SetPropSetName(NewName);
  RefreshPropertySets;
end;

procedure TMainForm.actAddPropUpdate(Sender: TObject);
begin
  TAction(Sender).Enabled:= lvPropSets.ItemIndex > -1;
end;

procedure TMainForm.actDelPropUpdate(Sender: TObject);
begin
  TAction(Sender).Enabled:= lvProps.ItemIndex > -1;
end;

procedure TMainForm.actAddPropExecute(Sender: TObject);
var
  ID: Cardinal;
  NewName: WideString;
  Spec: TPropSpec;
  Val: TPropVariant;
begin
  if not TfrmAddProperty.Execute(ID, NewName) then Exit;

  if '' <> NewName then
  begin
    Spec.ulKind:= PRSPEC_LPWSTR;
    Spec.lpwstr:= @NewName[1];
    ID:= 2;
  end else
  begin
    Spec.ulKind:= PRSPEC_PROPID;
    Spec.propid:= ID;
  end;
  
  Val.vt:= VT_LPSTR;
  Val.pszVal:= nil;
  FPropSetsStg.WriteProp(Spec, Val, ID);
  RefreshProperties(lvPropSets.Selected);
end;

procedure TMainForm.actDelPropExecute(Sender: TObject);
var
  ID: Cardinal;
begin
  ID:= Cardinal(StrToInt(lvProps.Items[lvProps.ItemIndex].Caption));
  FPropSetsStg.DeleteProperty(ID);
  OpenPropertySetStorage(StatusBar1.Panels[0].Text);
  RefreshProperties(lvPropSets.Selected);
end;

procedure TMainForm.actRenamePropExecute(Sender: TObject);
var
  ID: Cardinal;
  NewName: string;
begin
  NewName:= lvProps.Items[lvProps.ItemIndex].SubItems[0];
  if not InputQuery('Rename property', 'Input new name:', NewName)
  then Exit;
  ID:= Cardinal(StrToInt(lvProps.Items[lvProps.ItemIndex].Caption));
  FPropSetsStg.SetPropName(ID, NewName);
  RefreshProperties(lvPropSets.Selected);
end;

procedure TMainForm.actEditPropExecute(Sender: TObject);
var
  ID: Cardinal;
  NewValue: string;
  Val: TPropVariant;
begin
  NewValue:= lvProps.Items[lvProps.ItemIndex].SubItems[2];
  if not InputQuery('Edit property...', 'Input new value:', NewValue) then Exit;
  ID:= Cardinal(StrToInt(lvProps.Items[lvProps.ItemIndex].Caption));
  Val.vt:= VT_LPSTR;
  Val.pszVal:= PChar(NewValue);
  FPropSetsStg.WriteProp(ID, Val, ID);
  RefreshProperties(lvPropSets.Selected);
end;

function TMainForm.GetVarTypeString(TypeID: Word): string;
begin
  case TypeID and VT_TYPEMASK of
    VT_EMPTY            : Result := 'VT_EMPTY';
    VT_NULL             : Result := 'VT_NULL';
    VT_I2               : Result := 'VT_I2';
    VT_I4               : Result := 'VT_I4';
    VT_R4               : Result := 'VT_R4';
    VT_R8               : Result := 'VT_R8';
    VT_CY               : Result := 'VT_CY';
    VT_DATE             : Result := 'VT_DATE';
    VT_BSTR             : Result := 'VT_BSTR';
    VT_DISPATCH         : Result := 'VT_DISPATCH';
    VT_ERROR            : Result := 'VT_ERROR';
    VT_BOOL             : Result := 'VT_BOOL';
    VT_VARIANT          : Result := 'VT_VARIANT';
    VT_UNKNOWN          : Result := 'VT_UNKNOWN';
    VT_DECIMAL          : Result := 'VT_DECIMAL';
    VT_I1               : Result := 'VT_I1';
    VT_UI1              : Result := 'VT_UI1';
    VT_UI2              : Result := 'VT_UI2';
    VT_UI4              : Result := 'VT_UI4';
    VT_I8               : Result := 'VT_I8';
    VT_UI8              : Result := 'VT_UI8';
    VT_INT              : Result := 'VT_INT';
    VT_UINT             : Result := 'VT_UINT';
    VT_VOID             : Result := 'VT_VOID';
    VT_HRESULT          : Result := 'VT_HRESULT';
    VT_PTR              : Result := 'VT_PTR';
    VT_SAFEARRAY        : Result := 'VT_SAFEARRAY';
    VT_CARRAY           : Result := 'VT_CARRAY';
    VT_USERDEFINED      : Result := 'VT_USERDEFINED';
    VT_LPSTR            : Result := 'VT_LPSTR';
    VT_LPWSTR           : Result := 'VT_LPWSTR';
    VT_FILETIME         : Result := 'VT_FILETIME';
    VT_BLOB             : Result := 'VT_BLOB';
    VT_STREAM           : Result := 'VT_STREAM';
    VT_STORAGE          : Result := 'VT_STORAGE';
    VT_STREAMED_OBJECT  : Result := 'VT_STREAMED_OBJECT';
    VT_STORED_OBJECT    : Result := 'VT_STORED_OBJECT';
    VT_BLOB_OBJECT      : Result := 'VT_BLOB_OBJECT';
    VT_CF               : Result := 'VT_CF';
    VT_CLSID            : Result := 'VT_CLSID';
    else                  Result:= '<Not defined>';
  end;
  if 0 <> (TypeID and VT_VECTOR) then
    Result:= 'Array of ' + Result;
end;

end.
