高分！如何取得文件的提示信息？

[Apollo47]

当把鼠标在 Word 文档（*.doc）上停留片刻，就会出现文档的作者、完成时间等提示信息（Hint），还有鼠标停留在Internet快捷方式（InternetShortCut）上，会有这个快捷方式链接地址的提示信息。请问，如何在程序中获取某个文件的提示信息？

[BobLeeCn]

请找一些关于结构化存储文件方面的书看看。Word文档是以结构化存储文件形式存储的。

[Apollo47]

我主要是想得到Internet快捷方式的链接地址，没人知道吗？

[Apollo47]

？？？

[BigBen]

这个问题很好。文件信息的提取是个很大的题目，windows编程里专门有章节来论述，感觉上是为了很小的事，却非得费老大的力。
internet快捷方式？（超链？）

一个读快捷方式的例子，不见得有用。
use shlobj;

function ReadLink(AFileName: String):String;
var
psl: IShellLink;
ppf: IPersistFile;
WCLinkName: array[0..Max_Path] of WideChar;
Buf: array[0..255] of Char;
Data: TWin32FindData;
begin
psl:=CreateComObject(CLSID_ShellLink) as IShellLink;
ppf:=psl as IPersistFile;

StringToWideChar(AFileName, WCLinkName, MAX_PATH);
ppf.Load(WCLinkName, STGM_READ);

psl.GetPath(@Buf, Max_Path, Data, SLGP_UNCPRIORITY);
Result := StrPas(Buf);
end;

[enlightenment]

先看：

http://www.csdn.net/expert/topic/139/139416.shtm

属性集的操作组件源代码：

unit PropertySet;

interface

uses
Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
{$IFDEF VER100}
PropSets, // For Delphi 3
{$ENDIF}
ComObj, ActiveX;

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}';

type
TEnumPropertiesEvent = procedure(Sender: TObject; PropertyName: WideString;
PropertyID: Integer; PropertyVariant: TPropVariant) of object;

TPropertySet = class(TComponent)
private
FFileName: WideString;
FActive: Boolean;
FStorage: IStorage;
FPropertySetStorage: IPropertySetStorage;
FPropertyStorage: IPropertyStorage;
FStreamGUID: TGUID;
FOnEnumProperties: TEnumPropertiesEvent;
procedure SetFileName(const Value: WideString);
procedure SetActive(const Value: Boolean);
procedure SetStreamGUID(const Value: TGUID);
{ Private declarations }
protected
{ Protected declarations }
procedure InternalOpen; dynamic;
procedure InternalClose; dynamic;
procedure DoEnumProperty(PropertyName: WideString; PropertyID: Integer;
PropertyVariant: TPropVariant); dynamic;
public
{ Public declarations }
destructor Destroy; override;
procedure Open;
procedure Close;
procedure Enumerate;
function GetPropertyByName(APropertyName: WideString): TPropVariant;
function GetPropertyByID(APropertyID: Integer): TPropVariant;
procedure SetProperty(APropertyName: WideString; AValue: WideString);
procedure DeleteProperty(APropertyName: WideString);
published
{ Published declarations }
property Active: Boolean read FActive write SetActive;
property FileName: WideString read FFileName write SetFileName;
property OnEnumProperties: TEnumPropertiesEvent read FOnEnumProperties write FOnEnumProperties;
property StreamGUID: TGUID read FStreamGUID write SetStreamGUID;
end;

procedure Register;

implementation

type
TPropSpecArray = array[0 .. 1000] of TPropSpec;
PPropSpecArray = ^TPropSpecArray;
TPropVariantArray = array[0 .. 1000] of TPropVariant;
PPropVariantArray = ^TPropVariantArray;
TStatPropStgArray = array[0 .. 1000] of TStatPropStg;
PStatPropStgArray = ^TStatPropStgArray;

procedure Register;
begin
RegisterComponents('DCP', [TPropertySet]);
end;

{ TPropertySet }

procedure TPropertySet.Close;
begin
Active := False;
end;

procedure TPropertySet.DeleteProperty(APropertyName: WideString);
var
ps: PPropSpecArray;
begin
GetMem(ps, sizeof(TPropSpec));
try
ps[0].ulKind := PRSPEC_LPWSTR;
ps[0].lpwstr := PWideChar(APropertyName);

OleCheck(FPropertyStorage.DeleteMultiple(1, @ps[0]));
finally
FreeMem(ps);
end;
end;

destructor TPropertySet.Destroy;
begin
Close;
end;

procedure TPropertySet.DoEnumProperty(PropertyName: WideString;
PropertyID: Integer; PropertyVariant: TPropVariant);
begin
if Assigned(FOnEnumProperties) then
FOnEnumProperties(self, PropertyName, PropertyID, PropertyVariant);
end;

procedure TPropertySet.Enumerate;
var
ps: PPropSpecArray;
pv: PPropVariantArray;
sps: PStatPropStgArray;
Enum: IEnumStatPropStg;
Fetched: LongInt;
Prop: TPropVariant;
begin
ps := nil;
pv := nil;
sps := nil;
try
GetMem(ps, sizeof(TPropSpec));
GetMem(pv, sizeof(TPropVariant));
GetMem(sps, sizeof(TStatPropStg));

OleCheck(FPropertyStorage.Enum(Enum));

while Enum.Next(1, sps[0], @Fetched) = S_OK do begin
Prop := GetPropertyByID(sps[0].propid);
DoEnumProperty(sps[0].lpwstrName, sps[0].propid, Prop);
end;
finally
if ps <> nil then
FreeMem(ps);
if pv <> nil then
FreeMem(pv);
if sps <> nil then
FreeMem(sps);
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;

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;

procedure TPropertySet.InternalClose;
begin
FPropertyStorage := nil;
FPropertySetStorage := nil;
FStorage := nil;
end;

procedure TPropertySet.InternalOpen;
begin
FStorage := nil;
if FFileName = '' then
raise Exception.Create('File name must be set.');

if StgIsStorageFile(PWideChar(FFileName)) <> S_OK then
raise Exception.Create('File ' + FFileName + ' is not a structured storage file.');

OleCheck(StgOpenStorage(PWChar(FFileName), nil,
STGM_READWRITE or STGM_SHARE_EXCLUSIVE, nil, 0, FStorage));

FPropertySetStorage := FStorage as IPropertySetStorage;

OleCheck(FPropertySetStorage.Open(FStreamGUID, STGM_READWRITE or STGM_SHARE_EXCLUSIVE,
FPropertyStorage));
end;

procedure TPropertySet.Open;
begin
Active := True;
end;

procedure TPropertySet.SetActive(const Value: Boolean);
begin
if FActive <> Value then
if Value then
InternalOpen
else
InternalClose;
end;

procedure TPropertySet.SetFileName(const Value: WideString);
begin
FFileName := Value;
end;

procedure TPropertySet.SetProperty(APropertyName: WideString; AValue: WideString);
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);

pv[0].vt := VT_LPSTR;
pv[0].pszval := PChar(AValue);

OleCheck(FPropertyStorage.WriteMultiple(1, @ps[0], @pv[0], 2));
finally
if ps <> nil then
FreeMem(ps);
if pv <> nil then
FreeMem(pv);
end;
end;

procedure TPropertySet.SetStreamGUID(const Value: TGUID);
begin
FStreamGUID := Value;
end;

end.






演示程序代码：


unit MainForm;

interface

uses
Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
StdCtrls, ExtCtrls,
{$IFDEF VER100}
PropSets, // For Delphi 3
{$ENDIF}
PropertySet, ActiveX;

type
TfrmMain = class(TForm)
pnlBottom: TPanel;
pnlClient: TPanel;
Label1: TLabel;
cbStream: TComboBox;
Label2: TLabel;
cbPropertyName: TComboBox;
Label3: TLabel;
ecValue: TEdit;
btnFind: TButton;
btnClose: TButton;
Label4: TLabel;
lbFiles: TListBox;
PropertySet1: TPropertySet;
Label5: TLabel;
ecFilePath: TEdit;
procedure btnFindClick(Sender: TObject);
procedure FormCreate(Sender: TObject);
procedure btnCloseClick(Sender: TObject);
procedure cbStreamClick(Sender: TObject);
private
function Matches(P: TPropVariant): Boolean;
{ Private declarations }
public
{ Public declarations }
end;

var
frmMain: TfrmMain;

implementation

{$R *.DFM}

const
StreamGUIDs: array[0 .. 2] of TGUID = (
'{F29F85E0-4FF9-1068-AB91-08002B27B3D9}', // SummaryInformation
'{D5CDD502-2E9C-101B-9397-08002B2CF9AE}', // DocumentSummaryInformation
'{D5CDD505-2E9C-101B-9397-08002B2CF9AE}' // UserDefinedProperties
);

procedure TfrmMain.FormCreate(Sender: TObject);
begin
cbStream.ItemIndex := 0;
cbStreamClick(Sender);
end;

procedure TfrmMain.cbStreamClick(Sender: TObject);
begin
cbPropertyName.Items.Clear;

case cbStream.ItemIndex of
0: begin
cbPropertyName.Style := csDropDownList;
cbPropertyName.Items.AddObject('Title', TObject(PIDSI_TITLE));
cbPropertyName.Items.AddObject('Subject', TObject(PIDSI_SUBJECT));
cbPropertyName.Items.AddObject('Author', TObject(PIDSI_AUTHOR));
cbPropertyName.Items.AddObject('Keywords', TObject(PIDSI_KEYWORDS));
cbPropertyName.Items.AddObject('Comments', TObject(PIDSI_COMMENTS));
cbPropertyName.Items.AddObject('Template', TObject(PIDSI_TEMPLATE));
cbPropertyName.Items.AddObject('Last Author', TObject(PIDSI_LASTAUTHOR));
cbPropertyName.Items.AddObject('Revision Number', TObject(PIDSI_REVNUMBER));
cbPropertyName.Items.AddObject('Page Count', TObject(PIDSI_PAGECOUNT));
cbPropertyName.Items.AddObject('Word Count', TObject(PIDSI_WORDCOUNT));
cbPropertyName.Items.AddObject('Character Count', TObject(PIDSI_CHARCOUNT));
cbPropertyName.Items.AddObject('Application Name', TObject(PIDSI_APPNAME));
cbPropertyName.Items.AddObject('Document Security', TObject(PIDSI_DOC_SECURITY));
cbPropertyName.ItemIndex := 0;
end;

1: begin
cbPropertyName.Style := csDropDownList;
end;

2: begin
cbPropertyName.Style := csDropDown;
end;
end;
end;

function TfrmMain.Matches(P: TPropVariant): Boolean;
begin
case P.vt of
VT_LPSTR:
Result := UpperCase(P.pszVal) = UpperCase(ecValue.Text);

VT_I4:
Result := P.lVal = StrToInt(ecValue.Text);

// Handle other property types here...

else
Result := False;
end;
end;

procedure TfrmMain.btnFindClick(Sender: TObject);
var
SR: TSearchRec;
Res: Integer;
P: TPropVariant;
ID: Integer;
FileName: WideString;
begin
lbFiles.Items.Clear;

Res := FindFirst(ecFilePath.Text, faReadOnly or faArchive, SR);
if Res = 0 then
try
while Res = 0 do begin
FileName := ExtractFilePath(ecFilePath.Text) + SR.Name;
if StgIsStorageFile(PWideChar(FileName)) = S_OK then begin
PropertySet1.FileName := FileName;
PropertySet1.StreamGUID := StreamGuids[cbStream.ItemIndex];
PropertySet1.Open;

try
if cbStream.ItemIndex = 2 then begin
P := PropertySet1.GetPropertyByName(cbPropertyName.Text);
end else begin
ID := Integer(cbPropertyName.Items.Objects[cbPropertyName.ItemIndex]);
P := PropertySet1.GetPropertyByID(ID);
end;

if Matches(P) then
lbFiles.Items.Add(FileName);
finally
PropertySet1.Close;
end;
end;

Res := FindNext(SR);
end;
finally
FindClose(SR);
end;

if lbFiles.Items.Count = 0 then
ShowMessage('No matching files found.');
end;

procedure TfrmMain.btnCloseClick(Sender: TObject);
begin
Close;
end;

end.

[Apollo47]

来者又分，请积极发言！！