TrueType 或是 OpenType 字体

 

(* 
  This can be used for Streams OR files. Set AStream parameter to nil 
  if passing a FileName. 


  Usage: 
    Scan a Stream: 
      ScanIt('texttofind', False, MyMemoryStream); 


    Scan a File: 
    ScanIt('texttofind', False, nil, 'c:\mytextfile.txt'); 


*) 


function ScanIt(const forString: String; 
                caseSensitive: Boolean; 
                AStream: TStream; 
                AFilename: TFileName = ''): LongInt; 
{ 
  returns position of string in stream or file, 
  returns -1 if not found 


} 


const 
  BufferSize= $8001; { 32K+1 bytes } 
var 
  pBuf, pend, pScan, pPos : Pchar; 
  bytesRemaining: Integer; 
  bytesToRead: Integer; 
  SearchFor: Pchar; 
  filesize: LongInt; 
  fsTemp: TFileStream; 
begin 
  Result := -1; { assume failure } 
  if (Length(forString) = 0) or 
     ((AStream <> nil) and (AStream.Size = 0)) and 
     ((AStream = nil) and (Length(AFilename) = 0)) then 
    Exit; 
  SearchFor := nil; 
  pBuf := nil; 
  { open file as binary, 1 byte recordsize } 
  if not Assigned(AStream) then 
  begin 
    fsTemp := TFileStream.Create(AFilename, fmOpenRead or fmShareDenyWrite); 
    try 
      Result := ScanIt(forString, caseSensitive, fsTemp); 
    finally 
      fsTemp.free; 
    end; 
  end 
  else 
  begin 
    try { allocate memory for buffer and pchar search string } 
      SearchFor := StrAlloc(Length(forString)+1); 
      StrPCopy(SearchFor, forString); 
      if not caseSensitive then { convert to upper case } 
        AnsiUpper(SearchFor); 
      GetMem(pBuf, BufferSize); 
      filesize := AStream.Size; 
      bytesRemaining := filesize; 
      pPos := nil; 
      while bytesRemaining > 0 do 
      begin 
        { calc how many bytes to read this round } 
        if bytesRemaining >= BufferSize then 
          bytesToRead := Pred(BufferSize) 
        else 
          bytesToRead := bytesRemaining; 

        AStream.ReadBuffer(pBuf^, bytesToRead); 
        { read a buffer full and zero-terminate the buffer } 
        pend := @pBuf[ bytesToRead ]; 
        pend^:= #0; 
        { scan the buffer. Problem: buffer may contain #0 chars! So we 
          treat it as a concatenation of zero-terminated strings. } 
        pScan := pBuf; 
        while pScan < pend do 
        begin 
          if not caseSensitive then { convert to upper case } 
            AnsiUpper(pScan); 
          pPos := StrPos(pScan, SearchFor); { search for substring } 
          if pPos <> nil then { Found it! } 
          begin 
            Result := fileSize - bytesRemaining + 
                      LongInt(pPos) - LongInt(pBuf); 
            break; 
          end; 
          pScan := Strend(pScan); 
          Inc(pScan); 
        end; 
        if pPos <> nil then 
          break; 
        bytesRemaining := bytesRemaining - bytesToRead; 
        if bytesRemaining > 0 then 
        begin 
          { no luck in this buffers load. We need to handle the case of 
          the search string spanning two chunks of file now. We simply 
          go back a bit in the file and read from there, thus inspecting 
          some characters twice 
          } 
          AStream.Seek(-Length(forString), soFromCurrent); 
          bytesRemaining := bytesRemaining + Length(forString); 
        end; 
      end; { while } 
    finally 
      if SearchFor <> nil then StrDispose(SearchFor); 
      if pBuf <> nil then FreeMem(pBuf, BufferSize); 
    end; 
  end; 
end; { ScanIt } 


type 
  TFontType = (tftOpenType, tftTrueType, tftRaster); 


function GetFontType(AFontFileName: String): TFontType; 
var 
  fs: TFileStream; 
begin 
  Result := tftRaster; 
  fs := TFileStream.Create(AFontFileName, fmOpenRead); 
  try 
    fs.Position := 0; 
    // OpenType fonts have this signature in them 
    if ScanIt('DSIG', False, fs) > 0 then 
    begin 
      Result := tftOpenType; 
    end 
    else 
    begin 
      Result := tftTrueType; 
    end; 
  finally 
    fs.Free; 
  end; 
end; 


procedure TForm1.Button1Click(Sender: TObject); 
begin 
  case GetFontType('c:\Windows\Fonts\Amerigo Bold BT.TTF') of 
  tftOpenType: 
    begin 
      ShowMessage('OpenType'); 
    end; 
  tftTrueType: 
    begin 
      ShowMessage('TrueType'); 
    end; 
  end; 
end;