Код: Выделить всё
{$apptype console}
{$mode delphi}
uses
SysUtils, Windows, ActiveX;
type
EOleError = class(Exception);
EOleSysError = class(EOleError)
private
FErrorCode: HRESULT;
public
constructor Create(const Message: String; ErrorCode: HRESULT; HelpContext: Integer);
property ErrorCode: HRESULT read FErrorCode write FErrorCode;
end;
constructor EOleSysError.Create(const Message: String; ErrorCode: HRESULT; HelpContext: Integer);
var
S: String;
begin
S:=Message;
if S='' then
begin
S:=SysErrorMessage(ErrorCode);
if S='' then FmtStr(S,'OLE error %.8x',[ErrorCode]);
end;
inherited CreateHelp(S,HelpContext);
FErrorCode:=ErrorCode;
end;
procedure OleCheck(Result: HResult);
begin
if Failed(Result) then raise EOleSysError.Create('',Result,0);
end;
{function LCIDToCodePage(ALcid: LongWord): Integer;
const
CP_ACP = 0;
LOCALE_IDEFAULTANSICODEPAGE = $00001004;
var
ResultCode: Integer;
Buffer: array [0..6] of Char;
begin
GetLocaleInfo(ALcid, LOCALE_IDEFAULTANSICODEPAGE, Buffer, SizeOf(Buffer));
Val(Buffer, Result, ResultCode);
if ResultCode<>0 then Result:=CP_ACP;
end;}
function WCharFromChar(WCharDest: PWideChar; DestChars: Integer; const CharSource: PChar; SrcBytes: Integer): Integer;
begin
{if GetVersion() and $80000000<>$80000000 then
begin
if Lo(GetVersion())>4 then
DefaultUserCodePage:=3 else
DefaultUserCodePage:=LCIDToCodePage(GetThreadLocale);
end
else
DefaultUserCodePage := LCIDToCodePage(GetThreadLocale);
Result:=MultiByteToWideChar(DefaultUserCodePage, 0, CharSource, SrcBytes, WCharDest, DestChars);}
Result:=MultiByteToWideChar(3,0,CharSource,SrcBytes,WCharDest,DestChars);
end;
function StringToWideChar(const Source: String; Dest: PWideChar; DestSize: Integer): PWideChar;
begin
Dest[WCharFromChar(Dest,DestSize-1,PChar(Source),Length(Source))]:=#0;
Result:=Dest;
end;
function StringToOleStr(const Source: String): POleStr;
var
SourceLen: Integer;
Buffer: PWideChar;
begin
SourceLen:=Length(Source);
Buffer:=CoTaskMemAlloc((SourceLen+1)*SizeOf(WideChar));
StringToWideChar(Source,Buffer,SourceLen+1);
Result:=POleStr(Buffer);
end;
{procedure WriteStorage(Storage: IStorage);
var
Enum: IEnumSTATSTG;
Elem: TSTATSTG;
n: Integer;
s: String;
begin
OleCheck(Storage.EnumElements(0,nil,0,Enum));
repeat
Enum.Next(1,Elem,@n);
if n>0 then
begin
case Elem.dwType of
STGTY_STORAGE : s:='Storage';
STGTY_STREAM : s:='Stream';
STGTY_LOCKBYTES: s:='LockBytes';
STGTY_PROPERTY : s:='Property';
else s:='';
end;
if s<>'' then s:=#09'- '+s;
WriteLn(WideCharToString(Elem.pwcsName)+s);
end;
until n=0;
end;
procedure WriteOffice(FileName: PWideChar);
var
Storage: IStorage;
Stream : IStream;
Mode: DWORD;
begin
Mode:=STGM_READ or STGM_SHARE_EXCLUSIVE;
OleCheck(StgOpenStorage(FileName,nil,Mode,nil,0,Storage));
WriteStorage(Storage);
OleCheck(Storage.OpenStream(#05'SummaryInformation',nil,Mode,0,Stream));
end;}
function GetTypeDocument(FileName: String): String;
var
Storage: IStorage;
OleStr: POleStr;
Mode: DWORD;
hr: HRESULT;
function ExistName(Name: PWideChar): Boolean;
var
Stream: IStream;
begin
hr:=Storage.OpenStream(Name,nil,Mode,0,Stream);
Result:=Succeeded(hr);
if not Result and (hr<>HRESULT($80030002)) then OleCheck(hr);
end;
begin
Result:='unk';
Mode:=STGM_READ or STGM_SHARE_EXCLUSIVE;
OleStr:=StringToOleStr(FileName);
try
hr:=StgOpenStorage(OleStr,nil,Mode,nil,0,Storage);
if Succeeded(hr) then
begin
if ExistName('Workbook') then Result:='xls' else
if ExistName('WordDocument') then Result:='doc';
end else
if hr<>HRESULT($80030050) then OleCheck(hr);
finally
CoTaskMemFree(OleStr);
end;
end;
var
Handle: THandle;
Search: TSearchRec;
begin
Handle:=FindFirst('*',faAnyFile and not (faDirectory or faVolumeId or faHidden),Search);
while Handle=S_OK do
begin
WriteLn(Format('%s'#09' - %s',[Search.Name,GetTypeDocument(Search.Name)]));
Handle:=FindNext(Search);
end;
FindClose(Handle);
end.
