olehelpers.pas

是一个delphi的流程制作软件

function GetClipboardFormat (const AName : string) : TClipFormat;
begin
  Result := GetPredefinedFormat (AName);
  if Result = 0 then
    Result := RegisterClipboardFormat (PChar(AName))
end;

// replacement for windows function as it fills in the standard names also -----
function GetClipboardFormatName (ACode : TClipFormat) : string;
begin
  if ACode >= $C000 then
  begin
    SetLength (Result, 255);
    Windows.GetClipboardFormatName (ACode, PChar(Result), 255);
    SetLength (Result, StrLen (PChar (Result)))
  end else
    Result := GetPredefinedName (ACode)
end;

//=== METAFILE UTILITIES =======================================================

// Convert a Delphi enhanced metafile into a TMetafilePict in global memory (WMF)
function ConvertMetafile (EnhMetafile : TMetafile) : hMetafile;
var
  Metafile : PMetafilePict;
  Size : integer;
  DC : hDC;
  BitsHandle : hGlobal;
  Bits : pointer;
begin
  BitsHandle := 0;
  Result := GlobalAlloc (GHND, sizeof (TMetafilePict));
  if Result = 0 then
    OutOfMemoryError;

  Metafile := GlobalLock (Result);
  try
    try
      DC := GetDC (0);
      try
        Size := GetWinMetafileBits (EnhMetafile.Handle, 0, nil, MM_ANISOTROPIC, DC);
        BitsHandle := GlobalAlloc (GHND, Size);
        if BitsHandle = 0 then
          OutOfMemoryError;
        Bits := GlobalLock (BitsHandle);
        try
          GetWinMetafileBits (EnhMetafile.Handle, Size, Bits, MM_ANISOTROPIC, DC);
          with Metafile^ do
          begin
            hMF := SetMetafileBitsEx (Size, Bits);
            mm := MM_ANISOTROPIC;
            xExt := EnhMetafile.MMWidth;
            yExt := EnhMetafile.MMHeight
          end
        finally
          GlobalUnlock (BitsHandle)
        end
      finally
        ReleaseDC (0, DC)
      end
    finally
      GlobalUnlock (Result)
    end;

    if Size = 0 then
    begin
      if Result <> 0 then
       GlobalFree (Result);
      Result := 0
    end
  except
    if Result <> 0 then
      GlobalFree (Result);
    if BitsHandle <> 0 then
      GlobalFree (BitsHandle);
    raise
  end
end;

// Convert an Win 3.1 TMetafilePict (WMF) into a Delphi enhanced TMetafile
function ConvertMetafile (MetafileHandle : hGlobal) : TMetaFile;
var
  BlockData : PMetafilePict;
  MetafileSize : integer;
  TempBits : PChar;
  EnhHandle : hEnhMetafile;
  DC : hDC;
begin
  Result := TMetafile.Create;
  if MetafileHandle = 0 then
    exit;
// get a pointer to the TMetafilePict data passed by the DataObject
  BlockData := GlobalLock (MetafileHandle);
  try
// find out how much storage is needed; allocate memory for it
    MetafileSize := GetMetafileBitsEx (BlockData^.hMF, 0, nil);
    GetMem (TempBits, MetafileSize);
    try
// retrieve the metafile data
      GetMetafileBitsEx (BlockData^.hMF, MetafileSize, TempBits);
// convert the data to an enhanced metafile and obtain a handle to it
      DC := GetDC (0);
      try
        EnhHandle := SetWinMetafileBits (MetafileSize, TempBits, DC, BlockData^)
      finally
        ReleaseDC (0, DC)
      end
    finally
      FreeMem (TempBits, MetafileSize)
    end;
// pass the enhanced handle to the TMetafile
    if EnhHandle <> 0 then
      Result.Handle := EnhHandle
  finally
    GlobalUnlock (MetafileHandle)
  end
end;

procedure FreeMetafilePict (var H : hGlobal);
var
  M : PMetafilePict;
begin
  if H <> 0 then
  begin
    M := GlobalLock (H);
    DeleteMetafile (M^.hMF);
    GlobalUnlock (H);
    GlobalFree (H);
    H := 0
  end
end;

//--- TUIMetaFile --------------------------------------------------------------
// A lot of this stuff was borrowed from Delphi 1.0 TMetafile !!!!!

const
  WMFKey = integer ($9AC6CDD7);
  InchScale = 2540; // forMM_ANISOTROPIC

type
  PUIMetafileHeader = ^TUIMetafileHeader;
  TUIMetafileHeader = packed record
    Key : Longint;
    Handle : SmallInt;
    Box : TSmallRect;
    Inch : word;
    Reserved : Longint;
    CheckSum : word;
  end;

// Useful type when enumerating metafiles - has the rdParm part of the record
// defined to cover a useable number of array elements, the original is [0..0]
type
  PMetaRecord = ^TMetaRecord;
  TMetaRecord = packed record
    rdSize : DWORD;
    rdFunction : word;
    rdParm : array[0..20] of word
  end;

const
  IconOnly = 'IconOnly';

procedure InvalidGraphic(Str: string);
begin
  raise EInvalidGraphic.Create('TUIMetafile: ' + Str);
end;

procedure InvalidMetafile;
begin
  InvalidGraphic ('Invalid metafile')
end;

procedure UnknownFormat;
begin
  InvalidGraphic ('Unknown clipboard format')
end;

procedure WrongScale;
begin
  InvalidGraphic ('Metafile format not ANISOTROPIC')
end;

function ComputeAldusChecksum (var Header : TUIMetafileHeader): word;
var
  W : PWord;
begin
  Result := 0;
  W := @Header;
  while W <> @Header.CheckSum do
  begin
    Result := Result xor W^;
    inc (W)
  end
end;

procedure ReadMetafile (Stream : TStream; var Metafile : hMetafile; Length : Longint;
  var Width, Height : integer);
var
  Header : TUIMetafileHeader;
  Bits  : hGlobal;
  BitMem : Pointer;
begin
  Stream.Read(Header, sizeof (TUIMetafileHeader));
  if (Header.Key <> WMFKEY) or (ComputeAldusChecksum (Header) <> Header.CheckSum) then
    InvalidMetafile;
  dec (Length, sizeof (TUIMetafileHeader));
  Bits := GlobalAlloc (GMEM_MOVEABLE, Length);
  try
    BitMem := GlobalLock (Bits);
    try
      Stream.Read (BitMem^, Length);
      Metafile := SetMetafileBitsEx (Length, BitMem);
      if Metafile = 0 then
        InvalidMetafile;
      Width := Header.Box.right - Header.Box.left;
      Height := Header.Box.bottom - Header.Box.top;
      if Header.Inch <> InchScale then
        WrongScale
    finally
      GlobalUnlock(Bits)
    end;
  finally
    GlobalFree(Bits)
  end
end;

procedure LoadMetafile (const Name: string; var Metafile: hMetafile; var Width, Height: integer);
var
  Stream: TStream;
begin
  Stream := TFileStream.Create(Name, fmOpenRead);
  try
    ReadMetafile (Stream, Metafile, Stream.Size, Width, Height)
  finally
    Stream.Free
  end
end;

procedure WriteMetafile(Stream: TStream; Metafile: hMetafile; WriteLength: Boolean; AWidth, AHeight: integer);
var
  Header : TUIMetafileHeader;
  MetaMemHandle : hMetafile;
  MetaMem : pointer;
  Size,
  Length : integer;
begin
  ZeroMemory (@Header, sizeof(Header));
  with Header do
  begin
    Key := WMFKEY;
    with Box do
    begin
      Left  := 0;      Top    := 0;
      Right := AWidth; Bottom := AHeight
    end;
    Inch := InchScale;
    CheckSum := ComputeAldusChecksum (Header)
  end;

  Size := GetMetafileBitsEx (Metafile, 0, nil);
  MetaMemHandle := GlobalAlloc (GMEM_MOVEABLE, Size);
  try
    MetaMem := GlobalLock (MetaMemHandle);
    try
      GetMetafileBitsEx (Metafile, Size, MetaMem);
      Length := Size + SizeOf (TUIMetafileHeader);
      if WriteLength then
        Stream.Write (Length, sizeof (integer));
      Stream.Write (Header, sizeof (TUIMetafileHeader));
      Stream.Write (MetaMem^, Size)
    finally
      GlobalUnlock (MetaMemHandle)
    end
  finally
    GlobalFree (MetaMemHandle)
  end
end;

//--- TUIMetafileImage

procedure TUIMetafileImage.Reference;
begin
  inc (FRefCount)
end;

procedure TUIMetafileImage.Release;
begin
  if Assigned (Self) then
  begin
    Dec (FRefCount);
    if FRefCount = 0 then
    begin
      if FHandle <> 0 then
        DeleteMetafile (FHandle);
      Free
    end
  end
end;

// TUIMetafile

constructor TUIMetafile.Create;
begin
  inherited Create;
  Assign (nil)
end;

destructor TUIMetafile.Destroy;
begin
  FImage.Release;
  inherited Destroy
end;

procedure TUIMetafile.Assign(Source: TPersistent);
begin
  if (not Assigned (Source)) or (Source is TUIMetafile) then
  begin
    FImage.Release;
    if Source <> nil then
      FImage := TUIMetafile(Source).FImage
    else
      FImage := TUIMetafileImage.Create;
    FImage.Reference;
    Changed(Self)
  end else
    inherited Assign (Source)
end;

procedure TUIMetafile.UniqueImage;
var
  NewImage: TUIMetafileImage;
begin
  if FImage.FRefCount > 1 then
  begin
    NewImage := TUIMetafileImage.Create;
    NewImage.FHandle := CopyMetafile (FImage.FHandle, nil);
    NewImage.FHeight := FImage.FHeight;
    NewImage.FWidth := FImage.FWidth;
    FImage.Release;
    FImage := NewImage;
    FImage.Reference
  end
end;

procedure TUIMetafile.NewImage;
begin
  FImage.Release;
  FImage := TUIMetafileImage.Create;
  FImage.Reference
end;

function TUIMetafile.GetEmpty;
begin
  if Assigned (FImage) then
    Result := FImage.FHandle = 0
  else
    Result := true
end;

function TUIMetafile.GetHandle: hMetafile;
begin
  Result := FImage.FHandle
end;

function TUIMetafile.GetHeight: integer;
begin
  if Assigned (FImage) then
    Result := MulDiv (FImage.FHeight, Screen.PixelsPerInch, InchScale)
  else
    Result := 0
end;

function TUIMetafile.GetWidth: integer;
begin
  if Assigned (FImage) then
// FWidth stored in FInch units per inch, convert to pixels
    Result := MulDiv (FImage.FWidth, Screen.PixelsPerInch, InchScale)
  else
    Result := 0
end;

procedure TUIMetafile.SetHandle (Value: hMetafile);
begin
  NewImage;
  FImage.FHandle := Value;
  Changed (Self)
end;

procedure TUIMetafile.SetHeight(Value: integer);
begin
  if not Assigned (FImage) then
    NewImage;

// FHeight stored in FInch units per inch, conver Value to FInch units
  Value := MulDiv (Value, InchScale, Screen.PixelsPerInch);

  if FImage.FHeight <> Value then
  begin
    UniqueImage;
    FImage.FHeight := Value;
    Changed(Self)
  end
end;

procedure TUIMetafile.SetIconOnly (Value : boolean);
begin
  if FIconOnly <> Value then
  begin
    UniqueImage;
    FIconOnly := Value;
    Changed (Self)
  end
end;

procedure TUIMetafile.SetWidth(Value: integer);
begin
  if not Assigned (FImage) then
    NewImage;

// FWidth stored in FInch units per inch, Value to FInch units
  Value := MulDiv (Value, InchScale, 96);

  if FImage.FWidth <> Value then
  begin
    UniqueImage;
    FImage.FWidth := Value;
    Changed (Self)
  end
end;

procedure TUIMetafile.ReadData(Stream: TStream);
var
  Length : Longint;
begin
  NewImage;
  Stream.Read (Length, sizeof(Longint));
  with FImage do
    ReadMetafile (Stream, FHandle, Length, FWidth, FHeight);
  Changed(Self)
end;

procedure TUIMetafile.WriteData (Stream: TStream);
begin
  if Assigned (FImage) then
    with FImage do