olehelpers.pas

是一个delphi的流程制作软件

      WriteMetafile (Stream, FHandle, True, FWidth, FHeight)
end;


// This enum is used to play the metafile upto the comment "IconOnly" at which
// enumeration stops.
  function Enum2Play (DC : hDC; HandleTable : PHandleTable; MetaRecord : PMetaRecord;
    Count : integer; Data : pointer) : integer;  stdcall;
  begin
    if (MetaRecord^.rdFunction = META_ESCAPE) and (MetaRecord^.rdParm [0] = MFCOMMENT) and
      (CompareText (IconOnly, PChar(@MetaRecord^.rdParm [2])) = 0) then
      Result := 0 // stop
    else begin
      Result := 1; // continue
      PlayMetafileRecord (DC, HandleTable^, Windows.PMetaRecord(MetaRecord)^, Count)
    end
  end;

// Draw the metafile adjusting the coordinate space of the Canvas to scale the drawing properly
procedure TUIMetafile.Draw (ACanvas: TCanvas; const Rect: TRect);
var
  SavedDC: integer;
  DC: HDC;
  ViewOrg: TPoint;
begin
  if Assigned (FImage) then
  begin
    DC := ACanvas.Handle;
    SavedDC := SaveDC (DC);
// Set mapping mode to MM_ANISOTROPIC since we want the coordinate space the
// allow a non-1 by 1 mapping. Note the order of these calls is essential.
// The mapping mode must be set to MM_ANISOTROPIC or Windows will ignore
// the WindowExt change which must preceed a ViewportExt change.
    SetMapMode (DC, MM_ANISOTROPIC);
// Set the logical size of the DC to be the maximum X and maximum Y used in
// the metafile's drawing
    with FImage do
      SetWindowExtEx (DC, FWidth, FHeight, nil);
// Set the DC 'window' (logical coordinate extent) to map on to the entire
// rectangle provided.
    SetViewportExtEx (DC, Rect.Right - Rect.Left, Rect.Bottom - Rect.Top, nil);
// Get the original viewport origin since we are relative to that
//    GetViewPortOrgEx (DC, ViewOrg);
   GetWindowOrgEx (DC, ViewOrg);
// Move the viewport origin to match the top left of the rectangle
    with Rect.TopLeft do
      SetViewportOrgEx (DC, -ViewOrg.X + X, -ViewOrg.Y + Y, nil);
// Now that the metafile's coordinate space has been setup, play the metafile
   if FIconOnly then
     EnumMetafile (DC, FImage.FHandle, @Enum2Play, 0)
   else
     PlayMetafile (DC, FImage.FHandle);
// Reset everything back the way it came.
    RestoreDC (DC, SavedDC)
  end
end;

procedure TUIMetafile.LoadFromStream(Stream: TStream);
begin
  NewImage;
  with FImage do
    ReadMetafile(Stream, FHandle, Stream.Size - Stream.Position, FWidth, FHeight);
  Changed(Self)
end;

procedure TUIMetafile.SaveToStream(Stream: TStream);
begin
  if Assigned (FImage) then
    with FImage do
      WriteMetafile (Stream, FHandle, False, FWidth, FHeight)
end;

procedure TUIMetafile.LoadFromClipboardFormat(AFormat: word; AData: THandle; APalette: hPalette);
var
  MetafilePict: PMetaFilePict;
begin
  if (AFormat <> CF_METAFILEPICT) or (AData = 0) then
    UnknownFormat;

  MetafilePict := GlobalLock(AData);
  try
    NewImage;
    with MetafilePict^, FImage do
    begin
      if (xExt < 1) or (yExt < 1) then
// Metafiles that don't have a recommended size are not supported
        UnknownFormat;
      if mm <> MM_ANISOTROPIC then
        WrongScale;
      FWidth := xExt;
      FHeight := yExt;
      FHandle := CopyMetafile (hMF, nil)
    end
  finally
    GlobalUnlock(AData)
  end;

  Changed(Self)
end;

procedure TUIMetafile.SaveToClipboardFormat(var AFormat: word; var AData: THandle; var APalette: hPalette);
var
  MetafilePict : PMetaFilePict;
begin
  if Assigned (FImage) then
  begin
    AFormat := CF_METAFILEPICT;
    AData := GlobalAlloc (GMEM_MOVEABLE, SizeOf(TMetafilePict));
    APalette := 0;
    try
      MetafilePict := GlobalLock(AData);
      try
        with MetafilePict^, FImage do
        begin
// TUIMetafilePict doesn't let us be exact so find something close
          mm := MM_ANISOTROPIC;
          xExt := FWidth;
          yExt := FHeight;
          hMF := CopyMetafile (FHandle, nil)
        end
      finally
        GlobalUnlock(AData)
      end
    except
      GlobalFree(AData);
      raise
    end
  end
end;

//=== OLE UI Specific additions ================================================

// Utility called by the IconFromXXXX methods.  Takes a given hmetafile, copies
// into the TUIMetafile the size and data and then optionally chucks the hmetafile.

procedure TUIMetafile.SetPict (Metafile : hMetafile);
var
  MetaData : PMetafilePict;
begin
  NewImage;
  if Metafile <> 0 then
  begin
    MetaData := GlobalLock (Metafile);
    try
      with FImage do
      begin
        FHandle := CopyMetafile (Metadata^.hMF, nil);
        FWidth := MetaData^.xExt;
        FHeight := MetaData^.yExt
      end;
    finally
      GlobalUnlock (Metafile)
    end
  end;

  Changed (Self)
end;

//-- Creates a metafile containing an Icon and Caption based on the given filename,
// optionally choose to add a label.
procedure TUIMetafile.IconOfFile (const Filename : string; MakeLabel : boolean = true);
var
  Metafile : hMetafile;
  Buffer : POleStr;
begin
  NewImage;
  Buffer := OleStdCopyPasString (Filename);
  try
    Metafile := OleGetIconOfFile (Buffer, MakeLabel);
    SetPict (Metafile);
    FreeMetafilePict (Metafile)
  finally
    if Assigned (Buffer) then
      OleStdFreeString (Buffer)
  end
end;

//--- Create a TUIMetafile containing a Icon based on a CLSID and a caption string
// optionally choose to create the caption using the type string from the registration
// database, in which case the caption string is ignored.
procedure TUIMetafile.IconOfClass (CLSID : TCLSID; const Caption : string = ''; AsType : boolean = true);
var
  Metafile : hMetafile;
  Buffer : POleStr;
begin
  Buffer := OleStdCopyPasString (Caption);
  try
    Metafile := OleGetIconOfClass (CLSID, Buffer, AsType);
    SetPict (Metafile);
    FreeMetafilePict (Metafile)
  finally
    if Assigned (Buffer) then
      OleStdFreeString (Buffer)
  end
end;

//--- Make Icon metafile from Icon and Caption, embed source and Offset
// This creates a UI container metafile in which the given icon and caption
// (label) are drawn.  A comment record ('IconOnly') is inserted between the icon
// and the caption so the draw function can stop playing before the caption.  A
// filename and offset are added as further comments to the metafile.  The caption
// is limited to the first 40 characters only.

procedure TUIMetafile.IconFromAll (Icon : TIcon; const Caption, Source : string; Offset : integer);
var
  Metafile : hMetafile;
  WCaption,
  WSource : POleStr;
begin
  WCaption := OleStdCopyPasString (Caption);
  WSource := OleStdCopyPasString (Source);
  try
    Metafile := OleMetafilePictFromIconAndLabel (Icon.Handle, WCaption, WSource, Offset);
    SetPict (Metafile);
    FreeMetafilePict (Metafile)
  finally
    if Assigned (WCaption) then
      OleStdFreeString (WCaption);
    if Assigned (WSource) then
      OleStdFreeString (WSource)
  end
end;

//--- Retrieve a caption (label) in a UI Icon Metatfile
  type
    PGetCaption = ^TGetCaption;
    TGetCaption = packed record
      FoundIconOnly : boolean;
      Caption : string
    end;

  function Enum4Caption (DC : hDC; HandleTable : PHandleTable; MetaRecord : PMetaRecord;
    Count : integer; Data : PGetCaption) : integer;  stdcall;
  begin
    Result := 1;
  // Don't do anything until we see "IconOnly" in an MFCOMMENT and then allow
  // the search for the caption label.
    if not Data^.FoundIconOnly then
      if (MetaRecord^.rdFunction = META_ESCAPE) and (MetaRecord^.rdParm [0] = MFCOMMENT) then
         Data^.FoundIconOnly := CompareText (IconOnly, PChar(@MetaRecord^.rdParm [2])) = 0
      else
    else
  // enumerate the records looking for META_EXTTEXTOUT - there can be more than one.
      if MetaRecord^.rdFunction = META_EXTTEXTOUT then
        Data^.Caption := Data^.Caption + PChar (@MetaRecord^.rdParm [8])
  end;

function TUIMetafile.GetCaption : string;
var
  S : TGetCaption;
  DC : hDC;
begin
  ZeroMemory (@S, sizeof (TGetCaption));
  if Assigned (FImage) then
  begin
    DC := GetDC (0);
    try
      EnumMetafile (DC, Handle, @Enum4Caption, integer (@S))
    finally
      ReleaseDC (0, DC)
    end
  end;
  Result := S.Caption
end;

//--- Enum to look for the IconOnly string (to validate the UI metafile)

  function Enum4IconOnly (DC : hDC; HandleTable : PHandleTable; MetaRecord : PMetaRecord;
    Count : integer; Data : PGetCaption) : integer;  stdcall;
  begin
    if (MetaRecord^.rdFunction = META_ESCAPE) and (MetaRecord^.rdParm [0] = MFCOMMENT) and
       (CompareText (IconOnly, PChar(@MetaRecord^.rdParm [2])) = 0) then
    begin
      Data^.FoundIconOnly := true;
      Result := 0
    end else
      Result := 1
  end;

function TUIMetafile.GetHasIconOnly : boolean;
var
  S : TGetCaption;
  DC : hDC;
begin
  ZeroMemory (@S, sizeof (TGetCaption));
  if Assigned (FImage) then
  begin
    DC := GetDC (0);
    try
      EnumMetafile (DC, Handle, @Enum4IconOnly, integer (@S))
    finally
      ReleaseDC (0, DC)
    end
  end;
  Result := S.FoundIconOnly
end;

//--- Retrieve the metafile icon

// This data structure is passed into the enumeration function
  type
    PGetIcon = ^TGetIcon;
    TGetIcon = packed record
      DoAnd : boolean;   // true = AND mask data; false = XOR colour data
      AndMem : hGlobal;  // global memory handle to AND mask data bits
      Icon : hIcon;      // handle to icon when finished
    end;

  function Enum4Icon (DC : hDC; HandleTable : PHandleTable; MetaRecord : PMetaRecord;
    Count : integer; Data : PGetIcon) : integer;  stdcall;
  var
    Size,
    Height,
    Width : integer;
    BitmapInfo : PBitmapInfo;
    BitmapInfoHeader : PBitmapInfoHeader;
    DstBits,
    SrcBits : PByte;
    Bmp : hBitmap;
    Bitmap : Windows.TBitmap;
    Mem : hGlobal;
  begin
    Result := 1;
// Look at records for elements wanted
// Then get dimension and TBitmapInfo
    if MetaRecord.rdFunction = META_DIBBITBLT then   // win 3.0 wow!
    begin
      Height := MetaRecord.rdParm [1];
      Width := MetaRecord.rdParm [2];
      BitmapInfo := @MetaRecord.rdParm [8]
    end else
      if MetaRecord.rdFunction = META_DIBSTRETCHBLT then // win 3.1
      begin
        Height := MetaRecord.rdParm [2];
        Width := MetaRecord.rdParm [3];
        BitmapInfo := @MetaRecord.rdParm [10]
      end else
        exit; // not found so continue enumeration

// Calculate the starting position of the data bytes
    BitmapInfoHeader := @BitmapInfo^.bmiHeader;
    SrcBits := pointer (integer(BitmapInfo) + integer(BitmapInfoHeader^.biSize));
    if BitmapInfoHeader^.biClrUsed <> 0 then
      inc (SrcBits, BitmapInfoHeader^.biClrUsed * sizeof (TRGBQuad))
    else
      if BitmapInfoHeader^.biBitCount <= 8 then
        inc (SrcBits, (1 shl BitmapInfoHeader^.biBitCount) * sizeof (TRGBQuad));

// The bits in SrcBits are device-independant, so convert them to device-dependant
// using SetDIBits.
    if Data^.DoAnd or (BitmapInfoHeader^.biBitCount = 1) then
      Bmp := CreateBitmap (BitmapInfoHeader^.biWidth, BitmapInfoHeader^.biHeight, 1, 1, nil)
    else
      Bmp := CreateCompatibleBitmap (DC, BitmapInfoHeader^.biWidth, BitmapInfoHeader^.biHeight);

    if (Bmp = 0) or (SetDIBits (DC, Bmp, 0, BitmapInfoHeader^.biHeight, SrcBits,
      BitmapInfo^, DIB_RGB_COLORS) = 0) then
    begin
      if not Data^.DoAnd then
        GlobalFree (Data^.AndMem);
      DeleteObject (Bmp);
      Result := 0;
      exit
    end;

// Now use a Bitmap to assemble the data how its wanted
    GetObject (Bmp, sizeof (Windows.TBitmap), @Bitmap);
    Size := Bitmap.bmHeight * Bitmap.bmWidthBytes * Bitmap.bmPlanes;
    Mem := GlobalAlloc (GHND, Size);
    if Mem = 0 then
    begin
      if not Data^.DoAnd then
        GlobalFree (Data^.AndMem);
      DeleteObject (Bmp);
      Result := 0;
      exit
    end;

    DstBits := GlobalLock (Mem);
    try
      GetBitmapBits (Bmp, Size, DstBits)
    finally
      GlobalUnlock (Mem)
    end;
    DeleteObject (Bmp);

// If this is the first pass (DoAnd is true) then save the memory of the AND bits
// for the next pass
    if Data^.DoAnd then
    begin
      Data^.AndMem := Mem;
      Data^.DoAnd := false;
      exit
    end;

// Two passes complete, so make the icon, chuck the memory buffers
    SrcBits := GlobalLock (Data^.AndMem);
    try
      Data^.Icon := CreateIcon (hInstance, Width, Height, Bitmap.bmPlanes,
        Bitmap.bmBitsPixel, SrcBits, DstBits)
    finally
      GlobalUnlock (Data^.AndMem)
    end;
    GlobalFree (Data^.AndMem);
    GlobalFree (Mem);
    Result := 0  // no need to continue
  end;

// Returns a TIcon containing the icon component of the metafile
function TUIMetafile.GetIcon : TIcon;
var
  S : TGetIcon;
  DC : hDC;
begin
  ZeroMemory (@S, sizeof (TGetIcon));
  if Assigned (FImage) then
  begin
    DC := GetDC (0);
    S.DoAnd := true;
    try
      EnumMetafile (DC, Handle, @Enum4Icon, integer (@S))
    finally
      ReleaseDC (0, DC)
    end
  end;
  Result := TIcon.Create;
  Result.Handle := S.Icon
end;

//--- Get Icon source filename and offset index

  type
    PGetSource = ^TGetSource;
    TGetSource = packed record
      FoundIconOnly,
      FoundSource,
      FoundOffset : boolean;
      Source : string;
      Offset : integer;
    end;

// This callback proc enumerates the metafile skipping the first comment record,
// extracting the source filename from the second and the file offset (index) from
// the third.
  function Enum4Source (DC : hDC; HandleTable : PHandleTable; MetaRecord : PMetaRecord;
    Count : integer; Data : PGetSource) : integer;  stdcall;