olehelpers.pas

是一个delphi的流程制作软件

  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
// Now look for the source string
      if not Data^.FoundSource then
        if (MetaRecord^.rdFunction = META_ESCAPE) and (MetaRecord^.rdParm [0] = MFCOMMENT) then
        begin
          Data^.Source := PChar(@MetaRecord^.rdParm [2]);
          Data^.FoundSource := true
        end else
      else
// Now look for the offset string and convert it to an integer
        if not Data^.FoundOffset then
          if (MetaRecord^.rdFunction = META_ESCAPE) and (MetaRecord^.rdParm [0] = MFCOMMENT) then
          begin
            try
              Data^.Offset := StrToInt(PChar(@MetaRecord^.rdParm [2]))
            except
              Data^.Offset := 0
            end;
            Data^.FoundOffset := true;
            Result := 0
          end
  end;

procedure TUIMetafile.SourceAndOffset (var Source : string; var Offset : integer);
var
  S : TGetSource;
  DC : hDC;
begin
  ZeroMemory (@S, sizeof (TGetSource));
  if Assigned (FImage) then
  begin
    DC := GetDC (0);
    try
      EnumMetafile (DC, Handle, @Enum4Source, integer (@S))
    finally
      ReleaseDC (0, DC)
    end
  end;
  Source := S.Source;
  Offset := S.Offset
end;

function TUIMetafile.GetSource : string;
var
  I : integer;
begin
  SourceAndOffset (Result, I)
end;

function TUIMetafile.GetOffset : integer;
var
  S : string;
begin
  SourceAndOffset (S, Result)
end;

function TUIMetafile.GetPict : hMetafile;
var
  Meta : PMetafilePict;
begin
  if Assigned (FImage) then
  begin
    Result := GlobalAlloc (GHND, sizeof (TMetafilePict));
    Meta := GlobalLock (Result);
    try
      with Meta^, FImage do
      begin
        mm   := MM_ANISOTROPIC;
        xExt := FWidth;
        yExt := FHeight;
        hMF  := CopyMetafile (FHandle, nil)
      end
    finally
      GlobalUnlock (Result)
    end
  end else
    Result := 0
end;

//=== MAKE GLOBALS =============================================================

{$IFDEF GIF}
function MakeGlobal (Gif : TGifImage): hGlobal;
var
  Stream : TPersistMemStream;
begin
  Stream := TPersistMemStream.Create;
  try
    try
// Save the GIF to a persistent memory stream
      Gif.SaveToStream (Stream);
// Return the stream handle
      Result := Stream.Handle
    except
      Stream.Clear;
      Result := 0;
      raise
    end
  finally
    Stream.Free
  end
end;
{$ENDIF}

function MakeGlobal (Icon : TIcon): hGlobal;
var
  Stream : TPersistMemStream;
begin
  Stream := TPersistMemStream.Create;
  try
    try
// Save the icon to a persistent memory stream
     Icon.SaveToStream (Stream);
// Return the stream handle
      Result := Stream.Handle
    except
      Stream.Clear;
      Result := 0;
      raise
    end
  finally
    Stream.Free
  end
end;

function MakeGlobal (Graphic : TGraphic): hGlobal;
var
  Stream : TPersistMemStream;
begin
  Stream := TPersistMemStream.Create;
  try
    try
      Graphic.SaveToStream (Stream);
      Result := Stream.Handle
    except
      Stream.Clear;
      Result := 0;
      raise
    end
  finally
    Stream.Free
  end
end;

function MakeMFWrapper (Graphic : TGraphic) : hMetafile;
var
  Metafile : TMetafile;
begin
  if Graphic.Empty then
    Result := 0
  else begin
    Metafile := TMetafile.Create;
    try
      Metafile.Width := Graphic.Width + 2;
      Metafile.Height := Graphic.Height + 2;
      with TMetafileCanvas.Create (Metafile, 0) do
      try
        Draw (0, 0, Graphic)
      finally
        Free
      end;
      Result := ConvertMetafile (Metafile)
    finally
      Metafile.Free
    end
  end
end;

function MakeGlobal (Graphic : TBitmap) : hBitmap;
var
  Fmt : TClipFormat;
  Pal : hPalette;
begin
  if (not Assigned (Graphic)) or Graphic.Empty then
    Result := 0
  else begin
    Graphic.SaveToClipboardFormat (Fmt, THandle (Result), Pal);
    if Fmt <> cfBitmap then
    begin
      DeleteObject (Result);
      Result := 0
    end;
    if Pal <> 0 then
      DeleteObject (Pal)
  end
end;

{$IFDEF JPEG}
function MakeGlobal (Graphic : TJPEGImage) : hBitmap;
var
  Fmt : TClipFormat;
  Pal : hPalette;
begin
  if (not Assigned (Graphic)) or Graphic.Empty then
    Result := 0
  else begin
    Graphic.SaveToClipboardFormat (Fmt, THandle (Result), Pal);
    if Fmt <> cfBitmap then
    begin
      DeleteObject (Result);
      Result := 0
    end;
    if Pal <> 0 then
      DeleteObject (Pal)
  end
end;
{$ENDIF}

function MakeGlobal (const S: string): hGlobal;
var
  P : PChar;
begin
  Result := GlobalAlloc (GHND, length (S)+1);
  if Result = 0 then
    OutOfMemoryError;
  P := GlobalLock (Result);
  try
    StrPCopy (P, S)
  finally
    GlobalUnlock (Result)
  end
end;

function MakeGlobal (Value : integer) : hGlobal;
begin
  Result := MakeGlobal (Value, sizeof (integer))
end;

function MakeGlobal (List : TStringList) : hDrop;
var
  InNCArea : boolean;
  Handle : THandle;
  MousePos : TPoint;
begin
  MousePos := Mouse.CursorPos;
  Handle := WindowFromPoint (MousePos);
  InNCArea := SendMessage (Handle, WM_NCHITTEST, 0, MakeLParam (MousePos.X, MousePos.Y)) <> HTCLIENT;
  Windows.ScreenToClient (Handle, MousePos);
  Result := AddDropFiles (CreateDropFile (MousePos, InNCArea), List)
end;

function MakeGlobal (var P; Size : integer) : hGlobal;
var
  D : pointer;
begin
  Result := GlobalAlloc (GHND, Size);
  if Result = 0 then
    OutOfMemoryError;
  D := GlobalLock (Result);
  try
    Move (P, D^, Size)
  finally
    GlobalUnlock (Result)
  end
end;

// Takes an array of Delphi File descriptors and returns a global handle
// to an array of ShlObj File descriptors
function MakeGlobal (Desc : array of TFileDescriptor) : hGlobal; overload;
var
  G : PFileGroupDescriptor;
  L : integer;
begin
  Result := GlobalAlloc (GHND, SizeOf (TFileGroupDescriptor) +
    High (Desc) * SizeOf (ShlObj.TFileDescriptor));
  if Result = 0 then
    OutOfMemoryError;
  G := GlobalLock (Result);
  try
    G.cItems := High (Desc) + 1;
{$R-}
    for L := 0 to High (Desc) do
      G.fgd [L] := XlatFileDescriptor (Desc [L])
{$R+}
  finally
    GlobalUnlock (Result)
  end
end;

// Returns the size in bytes of the graphic
// clumsy as it requires the memory to duplicate the storage first
function GraphicSize (Graphic : TGraphic) : integer;
var
  Mem : TMemoryStream;
begin
  Mem := TMemoryStream.Create;
  try
    Graphic.SaveToStream (Mem);
    Result := Mem.Size
  finally
    Mem.Free
  end
end;


//=== DRAG DETECTION ===========================================================

function DragDetect (Control : TControl) : boolean;
var
  M : TPoint;
begin
  GetCursorPos (M);
  Result := DragDetect (Control, M.X, M.Y)
end;

function DragDetect (Control : TControl; Start : TPoint) : boolean;
begin
  Result := DragDetect (Control, Start.X, Start.Y)
end;

function DragDetect (Control : TControl; StartX, StartY : integer) : boolean;
var
  Handle : THandle;
begin
  if Control is TWinControl then
    Handle := TWinControl (Control).Handle
  else
    Handle := Control.Parent.Handle;

  Result := Windows.DragDetect (Handle, Point (StartX, StartY))
end;


//=== CF_HDROP UTILITIES =======================================================

// Utility to create a dropfiles record and return a handle to it
// returns the handle or 0 on failure.  Put in place the Files, NC, Wide and mouse
// values.  The file data area is initialised to #0 (no files).
function CreateDropFile (Pos : TPoint; NCArea : boolean) : hDrop;
var
  DropFiles : PDropFiles;
begin
  Result := GlobalAlloc (GMEM_SHARE or GMEM_MOVEABLE or GMEM_ZEROINIT, SizeOf (TDropFiles) + 1);
  if Result <> 0 then
  begin
    DropFiles := GlobalLock (Result);
    try
      with DropFiles^ do
      begin
        Files := SizeOf (TDropFiles);
        MousePos := Pos;
        NC := NCArea;
        Wide := false
      end
    finally
      GlobalUnlock (Result)
    end
  end
end;

// Utility to add a pathname to the dropfile handle.  Returns 0 on out
// of memory.
function AddDropFile (Drop : hDrop; const PathName : string) : hDrop;
var
  DropFiles : PDropFiles;
  Names : PChar;
  CurrentSize : integer;
begin
  Result := 0;
  if Drop <> 0 then
  begin
    DropFiles := GlobalLock (Drop);
    try
      Names := pointer (DropFiles);
      inc (Names, DropFiles^.Files);
      while Names^ <> #0 do
      begin
        while Names^ <> #0 do
          inc (Names);
        inc (Names)
      end;
      CurrentSize := integer(Names) - integer (DropFiles) + 1
    finally
      GlobalUnlock (Drop)
    end;
    Result := GlobalReAlloc (Drop, CurrentSize + length (PathName) + 1, GMEM_SHARE or GMEM_MOVEABLE or GMEM_ZEROINIT);
    if Result <> 0 then
    try
      DropFiles := GlobalLock (Drop);
      Names := pointer (DropFiles);
      inc (Names, CurrentSize - 1);
      StrCopy (Names, PChar (PathName))
    finally
      GlobalUnlock (Result)
    end
  end
end;

// Add from a string list and include out of memory exception
function AddDropFiles (Drop : hDrop; const List : TStringList) : hDrop;
var
  Loop : integer;
begin
  Result := 0;
  if Drop <> 0 then
    with List do
      for Loop := 0 to Count - 1 do
      begin
        Result := AddDropFile (Drop, List [Loop]);
        if Result = 0 then
        begin
          GlobalFree (Drop);
          OutOfMemoryError
        end;
        Drop := Result
      end
end;

//=== Initialises some fields of a TFileDescriptor =============================

procedure InitFileDescriptor (var D : TFileDescriptor);
begin
  ZeroMemory (@D, SizeOf (TFileDescriptor));
  with D do
  begin
    Flags := fdLinkUI or fdCreateTime or fdWritesTime or fdFileSize;
    LastWriteTime := Now;
    CreationTime := LastWriteTime
  end
end;

//==============================================================================
// initialise graphics.pas to accept a TUIMetafile and use the extension umf,
// I tried overloading wmf here, but found it blocked access to the wmf functions
// in a Delphi 4 TMetafile

initialization
  TPicture.RegisterFileFormat ('umf', 'UI Metafile', TUIMetafile);
// don't think this is necessary:
//  TPicture.RegisterClipboardFormat (CF_METAFILEPICT, TUIMetafile)
finalization
  TPicture.UnregisterGraphicClass (TUIMetafile)
end.