cpwmeta2.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 cpwmeta2;

{ 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.
  16 Mar 1993 Revised for more elegant handling of disk meta files.
}

interface

uses
   WinTypes,
   WinProcs,
   Strings;

function WriteMetafile (FileName : PChar; MetaHandle: THandle;
    XRect, YRect, UnitsPerInch:integer):Boolean;
   { Writes metafile <\b MetaHandle> as a placeable metafile called
     <\b Metafilename> with bounding rectangle of (0, 0, <\b XRect>,
     <\b YRect> and scale factor <\b UnitsPerInch>. Returns <\i True>
     if successful.}

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;

function WriteMetafile (FileName : PChar; MetaHandle: THandle;
    XRect, YRect, UnitsPerInch:integer):Boolean;
var
   hmfh   : MetaFileHeader;
   f1, f2 : file;
   Buf    : array[0..2048] of char;
   BytesRead,
   BytesWritten : word;
   MetaFileHandle : THandle;
   PtrMetaFile    : Pointer;
begin
   WriteMetaFile := False;  
   { 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;

   MetaFileHandle := GetMetaFileBits (MetaHandle); {Handle to memory object}
   if (MetaFileHandle <> 0) then begin
      { Write header to disk file}
      assign (f1, Filename);
      rewrite (f1, 1);
      BlockWrite (f1, hmfh, SizeOf (hmfh), BytesWritten);

      if (BytesWritten = SizeOf (hmfh)) then begin
         {Write metafile itself}
         PtrMetaFile := GlobalLock (MetaFileHandle);
         BlockWrite (f1, PtrMetaFile^, GlobalSize (MetaFileHandle),
                    BytesWritten);
         WriteMetaFile := (BytesWritten = GlobalSize (MetaFileHandle));
         GlobalUnLock (MetaFileHandle);
         GlobalFree (MetaFileHandle);
         end;
      Close (f1);
      end;
end;

end.