cpwmeta.pas

生物信息学中的遗传数据分析的delphi源码。

{*******************************************************************
*                                                                  *
*  COMPONENT for MS DOS and Windows source code.                   *
*                                                                  *
*  (c) 1992, 1993 Roderic D. M. Page                               *
*                                                                  *
*  Language: Turbo Pascal (Pascal with object-oriented extensions) *
*  Compiler: Turbo Pascal 6.0 (MS DOS)                             *
*            Turbo Pascal for Windows 1.0 (WINDOWS)                *
*                                                                  *
*  Notes:    Program interface is currently Windows specific.      *
*                                                                  *
*******************************************************************}

unit cpwmeta;

{ Support for disk based metafiles in the Aldus placeable format.
  Works with:

  Microsoft Draw OLE server with Word 2.0


  History

   4 Jan 1993 Written.
}

interface

uses
   WinTypes,
   WinProcs,
   Strings;

procedure WriteMetafile (MetaFileName, FileName : PChar;
    XRect, YRect, UnitsPerInch:integer);
   { Takes a metafile called <\b Filename> created by
     the Windows API function DeleteMetafile (CloseMetafile (...))
     and creates a placeable metafile called <\b Metafilename> with
     bounding rectangle of (0, 0, <\b XRect>, <\b YRect> and scale factor
     <\b UnitsPerInch>. }

implementation

const
	AldusPlaceableMetafile:longint = $9AC6CDD7;
      { Unique identifier for placeable metafiles.
        The bytes <\b D7 CD C6 9A> correspond to <\b W M F ^Z> with
        the highest order byte set to 1, hence the header
        indentifies the files as a <\b W>indows <\b M>eta<\b >File. }
type
	MetaFileHeader = record
      { Header for placeable metafile }
   	Version  : longint;    { format identifier }
	   AHandle  : THandle;    { always 0 }
	   BBRect   : TRect;      { bounding rectangle }
	   Inches   : word;       { units per inch }
	   Reserved : longint;    { always 0 }
	   Checksum : word;       { XOR of previous 10 words }
	   end;

procedure WriteMetafile (MetaFileName, FileName : PChar;
    XRect, YRect, UnitsPerInch:integer);
   { Takes a metafile called Filename created by
     DeleteMetafile (CloseMetafile (...)) and creates a
     placeable metafile (Metafilename). }
var
   hmfh   : MetaFileHeader;
   f1, f2 : file;
   Buf    : array[0..2048] of char;
   BytesRead,
   BytesWritten : word;
begin
   { File MetaFileHeader data }
	with hmfh do begin
		version  :=AldusPlaceableMetafile;
		ahandle  := 0;
		SetRect (bbrect, 0, 0, XRect, YRect);
		inches   := UnitsPerInch;
		reserved := 0;
		checksum := 0;
		end;

   { Compute checksum }
	with hmfh do begin
      checksum := $0000;
		checksum := checksum xor LoWord (Version);
      checksum := checksum xor HiWord (Version);
      checksum := checksum xor aHandle;
		with bbrect do begin
			checksum := checksum XOR bottom;
			checksum := checksum XOR right;
			checksum := checksum XOR top;
			checksum := checksum XOR left;
			end;
		checksum := checksum XOR inches;
		checksum := checksum XOR Loword (Reserved);
		checksum := checksum XOR HiWord (Reserved);
		end;


   { Write header to disk file}
   assign (f1, Metafilename);
   rewrite (f1, 1);
   BlockWrite (f1, hmfh, SizeOf (hmfh));


   { Open metafile created by DeleteMetafile and copy to
     our metafile } 
   Assign (f2, Filename);
   Reset (f2, 1);
   repeat
      BlockRead (f2, Buf, SizeOf(Buf), BytesRead);
      BlockWrite (f1, Buf, BytesRead, BytesWritten);
   until (BytesRead = 0) or (BytesWritten <> BytesRead);
   close (f2);

   { Erase old metafile }
   Erase (f2);

   close (f1);
end;

end.