clipview.pas

rxlib2.75控件包

{*******************************************************}
{                                                       }
{         Delphi VCL Extensions (RX)                    }
{                                                       }
{         Copyright (c) 1995 AO ROSNO                   }
{         Copyright (c) 1997 Master-Bank                }
{                                                       }
{*******************************************************}

unit ClipView;

interface

{$I RX.INC}

uses SysUtils, {$IFDEF WIN32} Windows, {$ELSE} WinTypes, WinProcs, {$ENDIF}
  Messages, Classes, Graphics, Controls, Clipbrd, Forms, StdCtrls,
  ExtCtrls, Menus;

type

{ TCustomClipboardViewer }

  TClipboardViewFormat = (cvDefault, cvEmpty, cvUnknown, cvText, cvBitmap,
    cvMetafile, cvPalette, cvOemText, cvPicture, cvComponent, cvIcon);

  TCustomClipboardViewer = class(TScrollBox)
  private
    { Private declarations }
    FWndNext: HWnd;
    FChained: Boolean;
    FPaintControl: TComponent;
    FViewFormat: TClipboardViewFormat;
    FOnChange: TNotifyEvent;
    function IsEmptyClipboard: Boolean;
    procedure ForwardMessage(var Message: TMessage);
    procedure WMSize(var Message: TMessage); message WM_SIZE;
    procedure WMDestroyClipboard(var Message: TMessage); message WM_DESTROYCLIPBOARD;
    procedure WMChangeCBChain(var Message: TWMChangeCBChain); message WM_CHANGECBCHAIN;
    procedure WMDrawClipboard(var Message: TMessage); message WM_DRAWCLIPBOARD;
    procedure WMNCDestroy(var Message: TWMNCDestroy); message WM_NCDESTROY;
    procedure SetViewFormat(Value: TClipboardViewFormat);
    function GetClipboardFormatNames(Index: Integer): string;
  protected
    { Protected declarations }
    procedure CreateWnd; override;
    procedure DestroyWindowHandle; override;
    procedure Change; dynamic;
    procedure CreatePaintControl; virtual;
    function GetDrawFormat: TClipboardViewFormat; virtual;
    function ValidFormat(Format: TClipboardViewFormat): Boolean; dynamic;
    property ViewFormat: TClipboardViewFormat read FViewFormat write
      SetViewFormat stored False;
    property OnChange: TNotifyEvent read FOnChange write FOnChange;
  public
    { Public declarations }
    constructor Create(AOwner: TComponent); override;
    class function CanDrawFormat(ClipboardFormat: Word): Boolean;
    property ClipboardFormatNames[Index: Integer]: string read GetClipboardFormatNames;
  published
    property Color default clWindow;
    property ParentColor default False;
  end;

  TClipboardViewer = class(TCustomClipboardViewer)
  published
{$IFDEF RX_D4}
    property Anchors;
    property BiDiMode;
    property Constraints;
    property DragKind;
    property ParentBiDiMode;
{$ENDIF}
    property ViewFormat;
    property OnChange;
{$IFDEF RX_D5}
    property OnContextPopup;
{$ENDIF}
{$IFDEF WIN32}
    property OnStartDrag;
{$ENDIF}
{$IFDEF RX_D4}
    property OnEndDock;
    property OnStartDock;
{$ENDIF}
  end;

function ClipboardFormatToView(Value: Word): TClipboardViewFormat;

implementation

uses Grids, ClipIcon, MaxMin, RxTConst, {$IFNDEF WIN32} Str16, {$ENDIF}
  VCLUtils;

{ Utility routines }

function ClipboardFormatName(Format: Word): string;
var
  Buffer: array[0..255] of Char;
begin
  SetString(Result, Buffer, GetClipboardFormatName(Format, Buffer, 255));
  if Result = '' then
    case Format of
      CF_BITMAP: Result := 'Bitmap';
      CF_DIB: Result := 'DIB Bitmap';
      CF_DIF: Result := 'DIF';
      CF_METAFILEPICT: Result := 'Metafile Picture';
{$IFDEF WIN32}
      CF_ENHMETAFILE: Result := 'Enchanced Metafile';
{$ENDIF}
      CF_OEMTEXT: Result := 'OEM Text';
      CF_PALETTE: Result := 'Palette';
      CF_PENDATA: Result := 'Pen Data';
      CF_RIFF: Result := 'RIFF File';
      CF_SYLK: Result := 'SYLK';
      CF_TEXT: Result := 'Text';
      CF_TIFF: Result := 'Tag Image';
      CF_WAVE: Result := 'Wave';
    end;
end;

function ViewToClipboardFormat(Value: TClipboardViewFormat): Word;
begin
  case Value of
    cvDefault, cvUnknown, cvEmpty: Result := 0;
    cvText: Result := CF_TEXT;
    cvBitmap: Result := CF_BITMAP;
    cvMetafile: Result := CF_METAFILEPICT;
    cvPalette: Result := CF_PALETTE;
    cvOemText: Result := CF_OEMTEXT;
    cvPicture: Result := CF_PICTURE; { CF_BITMAP, CF_METAFILEPICT }
    cvComponent: Result := CF_COMPONENT; { CF_TEXT }
    cvIcon: Result := CF_ICON; { CF_BITMAP }
    else Result := 0;
  end;
end;

function ClipboardFormatToView(Value: Word): TClipboardViewFormat;
begin
  if Value = CF_TEXT then Result := cvText
  else if Value = CF_BITMAP then Result := cvBitmap
  else if Value = CF_METAFILEPICT then Result := cvMetafile
{$IFDEF WIN32}
  else if Value = CF_ENHMETAFILE then Result := cvMetafile
{$ENDIF}
  else if Value = CF_PALETTE then Result := cvPalette
  else if Value = CF_OEMTEXT then Result := cvOemText
  else if Value = CF_PICTURE then Result := cvPicture { CF_BITMAP, CF_METAFILEPICT }
  else if Value = CF_COMPONENT then Result := cvComponent { CF_TEXT }
  else if Value = CF_ICON then Result := cvIcon { CF_BITMAP }
  else Result := cvDefault;
end;

procedure ComponentToStrings(Instance: TComponent; Text: TStrings);
var
  Mem, Out: TMemoryStream;
begin
  Mem := TMemoryStream.Create;
  try
    Mem.WriteComponent(Instance);
    Mem.Position := 0;
    Out := TMemoryStream.Create;
    try
      ObjectBinaryToText(Mem, Out);
      Out.Position := 0;
      Text.LoadFromStream(Out);
    finally
      Out.Free;
    end;
  finally
    Mem.Free;
  end;
end;

{ TPaletteGrid }

const
  NumPaletteEntries = 256;

type
  TPaletteGrid = class(TDrawGrid)
  private
    FPaletteEntries: array[0..NumPaletteEntries - 1] of TPaletteEntry;
    FPalette: HPALETTE;
    FCount: Integer;
    FSizing: Boolean;
    procedure SetPalette(Value: HPALETTE);
    procedure UpdateSize;
    function CellColor(ACol, ARow: Longint): TColor;
    procedure DrawSquare(CellColor: TColor; CellRect: TRect; ShowSelector: Boolean);
  protected
    function GetPalette: HPALETTE; override;
    procedure DrawCell(ACol, ARow: Longint; ARect: TRect;
      AState: TGridDrawState); override;
    function SelectCell(ACol, ARow: Longint): Boolean; override;
    procedure WMSize(var Message: TWMSize); message WM_SIZE;
  public
    constructor Create(AOwner: TComponent); override;
    destructor Destroy; override;
    property Palette: HPALETTE read FPalette write SetPalette;
  end;

function CopyPalette(Palette: HPALETTE): HPALETTE;
var
  PaletteSize: Integer;
  LogSize: Integer;
  LogPalette: PLogPalette;
begin
  Result := 0;
  if Palette = 0 then Exit;
  GetObject(Palette, SizeOf(PaletteSize), @PaletteSize);
  LogSize := SizeOf(TLogPalette) + (PaletteSize - 1) * SizeOf(TPaletteEntry);
  GetMem(LogPalette, LogSize);
  try
    with LogPalette^ do
    begin
      palVersion := $0300;
      palNumEntries := PaletteSize;
      GetPaletteEntries(Palette, 0, PaletteSize, palPalEntry);
    end;
    Result := CreatePalette(LogPalette^);
  finally
    FreeMem(LogPalette, LogSize);
  end;
end;

constructor TPaletteGrid.Create(AOwner: TComponent);
begin
  inherited Create(AOwner);
  DefaultColWidth := 20;
  DefaultRowHeight := 20;
  Options := [];
  GridLineWidth := 0;
  FixedCols := 0;
  FixedRows := 0;
  ColCount := 0;
  RowCount := 0;
  DefaultDrawing := False;
  ScrollBars := ssVertical;
end;

destructor TPaletteGrid.Destroy;
begin
  if FPalette <> 0 then DeleteObject(FPalette);
  inherited Destroy;
end;

procedure TPaletteGrid.UpdateSize;
var
  Rows: Integer;
begin
  if FSizing then Exit;
  FSizing := True;
  try
    ColCount := (ClientWidth - GetSystemMetrics(SM_CXVSCROLL)) div
      DefaultColWidth;
    Rows := FCount div ColCount;
    if FCount mod ColCount > 0 then Inc(Rows);
    RowCount := Max(1, Rows);
    ClientHeight := DefaultRowHeight * RowCount;
  finally
    FSizing := False;
  end;
end;

function TPaletteGrid.GetPalette: HPALETTE;
begin
  if FPalette <> 0 then Result := FPalette
  else Result := inherited GetPalette;
end;

procedure TPaletteGrid.SetPalette(Value: HPALETTE);
var
  I: Integer;
  ParentForm: TCustomForm;
begin
  if FPalette <> 0 then DeleteObject(FPalette);
  FPalette := CopyPalette(Value);
  FCount := Min(PaletteEntries(FPalette), NumPaletteEntries);
  GetPaletteEntries(FPalette, 0, FCount, FPaletteEntries);
  for I := FCount to NumPaletteEntries - 1 do
    FillChar(FPaletteEntries[I], SizeOf(TPaletteEntry), $80);
  UpdateSize;
  if Visible and (not (csLoading in ComponentState)) then begin
    ParentForm := GetParentForm(Self);
    if Assigned(ParentForm) and ParentForm.Active and
      Parentform.HandleAllocated then
      PostMessage(ParentForm.Handle, WM_QUERYNEWPALETTE, 0, 0);
  end;
end;

function TPaletteGrid.CellColor(ACol, ARow: Longint): TColor;
var
  PalIndex: Integer;
begin
  PalIndex := ACol + (ARow * ColCount);
  if PalIndex <= FCount - 1 then
    with FPaletteEntries[PalIndex] do
      Result := TColor(RGB(peRed, peGreen, peBlue))
  else Result := clNone;
end;

procedure TPaletteGrid.DrawSquare(CellColor: TColor; CellRect: TRect;
  ShowSelector: Boolean);
var
  SavePal: HPalette;
begin
  Canvas.Pen.Color := clBtnFace;
  with CellRect do Canvas.Rectangle(Left, Top, Right, Bottom);
  InflateRect(CellRect, -1, -1);
  Frame3D(Canvas, CellRect, clBtnShadow, clBtnHighlight, 2);
  SavePal := 0;
  if FPalette <> 0 then begin
    SavePal := SelectPalette(Canvas.Handle, FPalette, False);
    RealizePalette(Canvas.Handle);
  end;
  try
    Canvas.Brush.Color := CellColor;
    Canvas.Pen.Color := CellColor;
    with CellRect do Canvas.Rectangle(Left, Top, Right, Bottom);
  finally
    if FPalette <> 0 then SelectPalette(Canvas.Handle, SavePal, True);
  end;