dfminfotip.pas

这是一个DELPHI7应用案例开发篇有配套程序种子光盘

unit DFMInfoTip;

{$WARN SYMBOL_PLATFORM OFF}

interface

uses
  ComObj, ActiveX, InfoTip_TLB, StdVcl, shlobj, Classes, Windows, sysutils;

type
  TDFMInfoTip = class(TAutoObject, IDFMInfoTip,IQueryInfo,IPersistFile,IPersist)
  protected
    pMalloc : IMalloc;
    FFile : string;
      
    function Load(pszFileName: POleStr; dwMode: Longint): HResult;
      stdcall;
    function Save(pszFileName: POleStr; fRemember: BOOL): HResult;
      stdcall;
    function IsDirty: HResult; stdcall;
    function SaveCompleted(pszFileName: POleStr): HResult;
      stdcall;
      
    function GetInfoTip(dwFlags: DWORD; var ppwszTip: PWideChar): HResult; stdcall;
    function GetInfoFlags(out pdwFlags: DWORD): HResult; stdcall;

    function GetDFMInfo : string;

    function GetCurFile(out pszFileName: POleStr): HResult;
      stdcall;
    {IPersist} // need to implement, since IPersistFile is derived from IPersist
    function GetClassID(out classID: TCLSID): HResult; stdcall;
public
    procedure Initialize; override;
    destructor Destroy; override;            
  end;

implementation

uses ComServ;

{ TDFMInfoTip }

function TDFMInfoTip.GetDFMInfo: string;
var fStream : TFileStream;
    inStream : TMemoryStream;
    szFullText, szText : string;
    pFirst : Pchar;
    First : byte;
    slStrings : TStringList;
    iWidth, iHeight,
    iPos, iEnd : integer;
begin
  if FFile = '' then Exit;
  Result := '文件名: ' + ExtractFileName(FFile) + #13#10;
  //open the file
  fStream := TFileStream.Create(FFile,fmOpenRead or fmShareDenyNone);
  slStrings := TStringList.Create;
  try
    fStream.Position := 0;
    pFirst := @First;
    fStream.Read(pFirst^, 1);
    fStream.Position := 0;
    if First = $FF then // binary DFM
    begin
      Result := Result + '类型: Binary';
      inStream := TMemoryStream.Create;
      ObjectResourceToText( fStream, inStream );
      inStream.Position := 0;
      slStrings.LoadFromStream(inStream);
      inStream.Free;
    end
    else
    begin // Delphi 5's text DFM
       slStrings.LoadFromStream(fStream);
       Result := Result + '类型: Text';
    end;

    szFullText := slStrings.Text;
    szText := szFullText;
    if Copy(szText, 1, 9) = 'inherited' then
      Result := Result + #13#10 + '(inherited)' ;
    //get the caption
    iPos := Pos('  Caption = ''', szText);
    if iPos <> 0 then
    begin
      Inc(iPos, Length('  Caption = '''));
      iEnd := iPos;
      while true do
      begin
        if (szText[iEnd] = '''') then
          if (Copy(szText, iEnd+1, 4)='#39''') then
            Inc(iEnd, 4)
          else
            break;
        Inc(iEnd);
      end;
      szText := StringReplace(Copy(szText, iPos, iEnd-iPos), '''#39''', '''', [rfReplaceAll]);
      Result := Result + #13#10 + '标题：' + szText ;
    end;

    //get the width and height
    szText := szFullText;
    iPos := Pos('Width =', szText);
    if iPos <> 0 then
    begin
      Inc(iPos, Length('Width ='));
      iEnd := iPos;
      while not (szText[iEnd] in [#13, #0]) do
        Inc(iEnd);
      try
         iWidth := StrToInt(Copy(szText, iPos, iEnd-iPos));
      except
        Exit;
      end;
      iPos := Pos('Height =', szText);
      if iPos <> 0 then
      begin
        Inc(iPos, Length('Height ='));
        iEnd := iPos;
        while not (szText[iEnd] in [#13, #0]) do
           Inc(iEnd);
        try
          iHeight := StrToInt(Copy(szText, iPos, iEnd-iPos));
        except
          Exit;
        end;
        Result := Result + #13#10 + Format('窗口大小: %dx%d',[iWidth, iHeight]);
      end;
    end;
  finally
    fStream.Free;
    slStrings.Free;
  end;
end;

function TDFMInfoTip.GetInfoFlags(out pdwFlags: DWORD): HResult;
begin
  pdwFlags := 0;
  Result := E_NOTIMPL;
end;

function TDFMInfoTip.GetInfoTip(dwFlags: DWORD;
  var ppwszTip: PWideChar): HResult;
var szTip : string;
begin
  Result := S_OK;

  //当前查看的文件名位于FFile变量中
  szTip := GetDFMInfo;
  ppwszTip := pMalloc.Alloc( sizeof(WideChar)*(Length(szTip)+1));
  if (ppwszTip <> nil) then
    ppwszTip := StringToWideChar(szTip, ppwszTip, sizeof(WideChar)*Length(szTip) +1 );
end;

procedure TDFMInfoTip.Initialize;
begin
  inherited;
  if Failed(ShGetMalloc(pMalloc)) then
    pMalloc := nil;
end;

function TDFMInfoTip.IsDirty: HResult;
begin
  Result := E_NOTIMPL;
end;

function TDFMInfoTip.Load(pszFileName: POleStr; dwMode: Integer): HResult;
begin
  FFile := pszFileName;
  Result := S_OK;
end;

function TDFMInfoTip.Save(pszFileName: POleStr; fRemember: BOOL): HResult;
begin
  Result := E_NOTIMPL;
end;

function TDFMInfoTip.SaveCompleted(pszFileName: POleStr): HResult;
begin
  Result := E_NOTIMPL;
end;

function TDFMInfoTip.GetClassID(out classID: TCLSID): HResult;
begin
  Result := E_NOTIMPL;
end;

function TDFMInfoTip.GetCurFile(out pszFileName: POleStr): HResult;
begin
  Result := E_NOTIMPL;
end;

destructor TDFMInfoTip.Destroy;
begin
  pMalloc := nil;
  inherited;
end;

initialization
  TAutoObjectFactory.Create(ComServer, TDFMInfoTip, Class_DFMInfoTip,
    ciMultiInstance, tmApartment);
end.