olehelpers.pas

是一个delphi的流程制作软件

//===================== DRAG AND DROP UTILITIES ================================
//
// This unit contains utility types, constants, procedures, functions, classes
// and components to help with the development of OLE based drag/drop and
// clipboard operations using COM interfaces.
//
// Contents:
//     Stream utilities
//       TPersistMemStream
//       THandleMemStream
//     Get clipboard format names (including predefined)
//     Metafile utilities
//       Convert between enhanced and windows
//       Delete windows
//       TUIMetafile
//     Make global memory copies of...
//     Drag start detection
//
// Grahame Marsh
// Freeware for UNDU - you get it for free I make no promises
// [e-mail]
//==============================================================================

{$INCLUDE OLE.INC}

unit OleHelpers;

interface

uses
  Windows, SysUtils, Classes, Controls, Graphics, ActiveX, Messages, Forms, ShlObj,
{$IFDEF GIF}
  GifImage,
{$ENDIF}
{$IFDEF JPEG}
  JPEG,
{$ENDIF}
  OleDnD, OleConsts, OleStd, OleNames;

// This stream is very similar to a TMemoryStream except that the memory allocated
// by the stream is not disposed of when the stream is destroyed (hence "persist").
// The user must obtain the handle/pointer and correctly dispose of the memory
// after use.  This stream is handly when transferring an object from into global
// memory where the object has a SaveToStream capability.  If you don't want to
// keep the stuff in memory call Clear before Free.

type
  TPersistMemStream = class (TStream)
  private
    FMemory : Pointer;
    FSize,
    FPosition,
    FCapacity : Longint;
    function GetHandle : THandle;
    procedure SetCapacity(NewCapacity: Longint);
  protected
    function Realloc(var NewCapacity: Longint): Pointer; virtual;
    procedure SetPointer(Ptr: Pointer; Size: Longint);
    property Capacity: Longint read FCapacity write SetCapacity;
  public
    procedure Clear;
    procedure LoadFromFile (const FileName: string);
    procedure LoadFromStream (Stream: TStream);
    function  Read (var Buffer; Count: Longint): Longint; override;
    procedure SaveToFile (const FileName: string);
    procedure SaveToStream (Stream: TStream);
    function  Seek (Offset: Longint; Origin: Word): Longint; override;
    procedure SetSize (NewSize: Longint); override;
    function  Write (const Buffer; Count: Longint): Longint; override;
    property Handle : THandle read GetHandle;
    property Memory : pointer read FMemory;
  end;

// This class makes a global memory block appear as a stream.  It is valid for
// readonly operations but is handy when a global handle has been passed and
// you want to transfer the global data into an object that has a LoadFromStream
// capability;

  THandleMemStream = class (TStream)
  private
    FHandle : THandle;
    FMemory : pointer;
    FPosition,
    FSize : integer;
  protected
  public
    constructor Create (Handle : THandle);
    destructor Destroy; override;
    function  Read (var Buffer; Count: Longint): Longint; override;
    function  Seek (Offset: Longint; Origin: Word): Longint; override;
    function  Write (const Buffer; Count: Longint): Longint; override;
    property Handle : THandle read FHandle;
    property Memory : pointer read FMemory;
    property Size : integer read FSize;
  end;

//=== Clipboard formats and names helpers ======================================

function GetClipboardFormat (const AName : string) : TClipFormat;
function GetClipboardFormatName (ACode : TClipFormat) : string;
function GetPredefinedFormat (const AName : string) : TClipFormat;

//=== Metafile Helpers =========================================================
// Free a metafilepict structure
procedure FreeMetafilePict (var H : hMetafile);

// Convert an enhanced to windows metafile and back
function ConvertMetafile (MetafileHandle : hMetafile) : TMetaFile; overload;
function ConvertMetafile (EnhMetafile : TMetafile) : hMetafile; overload;

// This is a convient class to hold UI Metafiles - they consist of an icon and
// a caption label, have have three comment strings.  The first is always the
// text 'IconOnly' and occurs ahead of the caption label.  This allows the draw
// method to optionally only draw the icon and omit the caption.  The two other
// strings are the filename and icon offset from which the icon was extracted.
// Support methods allow this class to create a metafile based on a filename,
// based on a CLSID, or based on an Icon, Caption, Filename and icon offset.
type
  TUIMetafileImage = class
  private
    FRefCount,
    FWidth,
    FHeight : integer;
    FHandle : hMetafile;
    procedure Reference;
    procedure Release;
  end;

  TUIMetafile = class (TGraphic)
  private
    FImage : TUIMetafileImage;
    FIconOnly : boolean;
    function GetHandle : hMetafile;
    procedure NewImage;
    procedure SetHandle (Value : hMetafile);
    procedure UniqueImage;
    procedure SetIconOnly (Value : boolean);
    function GetCaption : string;
    function GetIcon : TIcon;
    function GetSource : string;
    function GetOffset : integer;
    procedure SetPict (Metafile : hMetafile);
    function GetPict : hMetafile;
    function GetHasIconOnly : boolean;
  protected
    function GetEmpty : boolean; override;
    function GetHeight : integer; override;
    function GetWidth : integer; override;
    procedure Draw (ACanvas : TCanvas; const Rect : TRect); override;
    procedure ReadData (Stream : TStream); override;
    procedure SetHeight (Value : integer); override;
    procedure SetWidth (Value : integer); override;
    procedure WriteData (Stream : TStream); override;
  public
    constructor Create; override;
    destructor Destroy; override;
    procedure LoadFromStream(Stream: TStream); override;
    procedure SaveToStream(Stream: TStream); override;
    procedure LoadFromClipboardFormat (AFormat: word; AData : THandle; APalette : hPalette); override;
    procedure SaveToClipboardFormat (var AFormat : word; var AData : THandle; var APalette : hPalette); override;
    procedure Assign(Source : TPersistent); override;
    property Handle : hMetafile read GetHandle write SetHandle;
    property IconOnly : boolean read FIconOnly write SetIconOnly;
    property HasIconOnly : boolean read GetHasIconOnly;

    procedure IconOfFile (const Filename : string; MakeLabel : boolean = true);
    procedure IconOfClass (CLSID : TCLSID; const Caption : string = ''; AsType : boolean = true);
    procedure SourceAndOffset (var Source : string; var Offset : integer);
    procedure IconFromAll (Icon : TIcon; const Caption, Source : string; Offset : integer);
    property Caption : string read GetCaption;
    property Icon : TIcon read GetIcon;
    property Source : string read GetSource;
    property Offset : integer read GetOffset;
    property MetaPict : hMetafile read GetPict write SetPict;
  end;

procedure LoadMetafile (const Name: string; var Metafile: hMetafile; var Width, Height: integer);

//=== MakeGlobals ==============================================================

type
  hDrop = THandle;
  PDropFiles = ^TDropFiles;
  TDropFiles = packed record
    Files    : DWORD;        // number of bytes in this structure
    MousePos : TPoint;       // mouse position
    NC,                      // true if mouse was in the client area
    Wide     : BOOL;         // true if file contains wide characters
//  Namelist :               // then zero terminated name list (ends #0#0 eg
  end;                       // name1#0name2#0name3#0#0 )

{$IFDEF GIF}
function MakeGlobal (Gif : TGifImage) : hGlobal; overload;
{$ENDIF}
function MakeMFWrapper (Graphic : TGraphic) : hMetafile;
function MakeGlobal (Graphic : TBitmap) : hBitmap; overload;
{$IFDEF JPEG}
function MakeGlobal (Graphic : TJPEGImage) : hBitmap; overload;
{$ENDIF}
function MakeGlobal (Graphic : TGraphic) : hGlobal; overload;
function MakeGlobal (Icon : TIcon): hGlobal; overload;
function MakeGlobal (Value : integer) : hGlobal; overload;
function MakeGlobal (List : TStringList) : hDrop; overload;
function MakeGlobal (const S: string): hGlobal; overload;
function MakeGlobal (var P; Size : integer) : hGlobal; overload;
function MakeGlobal (Desc : array of TFileDescriptor) : hGlobal; overload;
function GraphicSize (Graphic : TGraphic) : integer;

//== cf_hdrop helpers ==========================================================
// These are the utility functions used by MakeHDrop
function CreateDropFile (Pos : TPoint; NCArea : boolean) : hDrop;
function AddDropFile (Drop : hDrop; const PathName : string) : hDrop;
function AddDropFiles (Drop : hDrop; const List : TStringList) : hDrop;

//=== Drag Helper functions ====================================================

function DragDetect (Control : TControl; StartX, StartY : integer) : boolean; overload;
function DragDetect (Control : TControl; Start : TPoint) : boolean; overload;
function DragDetect (Control : TControl) : boolean; overload;

//=== helper for cfFileDescriptor format =======================================

procedure InitFileDescriptor (var D : TFileDescriptor);

implementation

//=== Persistant Memory Stream =================================================

procedure TPersistMemStream.Clear;
begin
  SetCapacity(0);
  FSize := 0;
  FPosition := 0
end;

function TPersistMemStream.GetHandle : THandle;
begin
  if FSize = 0 then
    Result := 0
  else
    Result := GlobalHandle (FMemory)
end;

procedure TPersistMemStream.LoadFromStream(Stream: TStream);
var
  Count: Longint;
begin
  Stream.Position := 0;
  Count := Stream.Size;
  SetSize(Count);
  if Count <> 0 then
    Stream.ReadBuffer(FMemory^, Count)
end;

procedure TPersistMemStream.LoadFromFile(const FileName: string);
var
  Stream: TStream;
begin
  Stream := TFileStream.Create(FileName, fmOpenRead or fmShareDenyWrite);
  try
    LoadFromStream(Stream)
  finally
    Stream.Free
  end
end;

function TPersistMemStream.Read(var Buffer; Count: Longint): Longint;
begin
  if (FPosition >= 0) and (Count >= 0) then
  begin
    Result := FSize - FPosition;
    if Result > 0 then
    begin
      if Result > Count then
        Result := Count;
      Move(Pointer(Longint(FMemory) + FPosition)^, Buffer, Result);
      Inc(FPosition, Result);
      Exit
    end
  end;
  Result := 0
end;

function TPersistMemStream.Realloc(var NewCapacity: Longint): Pointer;
const
  MemoryDelta = $2000;
begin
  if NewCapacity > 0 then
    NewCapacity := (NewCapacity + (MemoryDelta - 1)) and not (MemoryDelta - 1);
  Result := Memory;
  if NewCapacity <> FCapacity then
  begin
    if NewCapacity = 0 then
    begin
      GlobalFreePtr(Memory);
      Result := nil
    end else begin
      if Capacity = 0 then
        Result := GlobalAllocPtr(HeapAllocFlags, NewCapacity)
      else
        Result := GlobalReallocPtr(Memory, NewCapacity, HeapAllocFlags);
      if not Assigned (Result) then
        OutOfMemoryError
    end
  end
end;

procedure TPersistMemStream.SaveToFile(const FileName: string);
var
  Stream: TStream;
begin
  Stream := TFileStream.Create(FileName, fmCreate);
  try
    SaveToStream(Stream)
  finally
    Stream.Free
  end
end;

procedure TPersistMemStream.SaveToStream(Stream: TStream);
begin
  if FSize <> 0 then
    Stream.WriteBuffer(FMemory^, FSize)
end;

function TPersistMemStream.Seek(Offset: Longint; Origin: Word): Longint;
begin
  case Origin of
    soFromBeginning : FPosition := Offset;
    soFromCurrent   : Inc(FPosition, Offset);
    soFromEnd       : FPosition := FSize + Offset
  end;
  Result := FPosition
end;

procedure TPersistMemStream.SetCapacity(NewCapacity: Longint);
begin
  SetPointer (Realloc(NewCapacity), FSize);
  FCapacity := NewCapacity
end;

procedure TPersistMemStream.SetPointer(Ptr: Pointer; Size: Longint);
begin
  FMemory := Ptr;
  FSize := Size
end;

procedure TPersistMemStream.SetSize(NewSize: Longint);
var
  OldPosition: Longint;
begin
  OldPosition := FPosition;
  SetCapacity(NewSize);
  FSize := NewSize;
  if OldPosition > NewSize then
    Seek(0, soFromEnd)
end;

function TPersistMemStream.Write(const Buffer; Count: Longint): Longint;
var
  Pos: Longint;
begin
  if (FPosition >= 0) and (Count >= 0) then
  begin
    Pos := FPosition + Count;
    if Pos > 0 then
    begin
      if Pos > FSize then
      begin
        if Pos > FCapacity then
          SetCapacity(Pos);
        FSize := Pos;
      end;
      System.Move(Buffer, Pointer(Longint(FMemory) + FPosition)^, Count);
      FPosition := Pos;
      Result := Count;
      Exit;
    end;
  end;
  Result := 0;
end;

//=== Handle Memory Stream =====================================================

constructor THandleMemStream.Create (Handle : THandle);
begin
  inherited Create;
  FHandle := Handle;
  FSize := GlobalSize (FHandle);
  FMemory := GlobalLock (FHandle)
end;

destructor THandleMemStream.Destroy;
begin
  GlobalUnlock (FHandle);
  inherited Destroy
end;

function THandleMemStream.Read (var Buffer; Count: Longint): Longint;
begin
  if (FPosition >= 0) and (Count >= 0) then
  begin
    Result := FSize - FPosition;
    if Result > 0 then
    begin
      if Result > Count then
        Result := Count;
      Move(Pointer(Longint(FMemory) + FPosition)^, Buffer, Result);
      Inc(FPosition, Result);
      Exit
    end
  end;
  Result := 0
end;

function THandleMemStream.Seek (Offset: Longint; Origin: Word): Longint;
begin
  case Origin of
    soFromBeginning : FPosition := Offset;
    soFromCurrent   : Inc(FPosition, Offset);
    soFromEnd       : FPosition := FSize + Offset
  end;
  Result := FPosition
end;

function THandleMemStream.Write (const Buffer; Count: Longint): Longint;
begin
  Result := 0  // stub - no action on write, could raise exception?
end;

//=== CLIP FORMAT HELPERS ======================================================

function GetPredefinedFormat (const AName : string) : TClipFormat;
var
  Loop : integer;
begin
  for Loop := Low (FixedClipNames) to High (FixedClipNames) do
    with FixedClipNames [Loop] do
      if CompareText (Name, AName) = 0 then
      begin
        Result := Code;
        exit
      end;
  Result := 0
end;