jvclipboardviewer.pas

East make Tray Icon in delphi

{-----------------------------------------------------------------------------
The contents of this file are subject to the Mozilla Public License
Version 1.1 (the "License"); you may not use this file except in compliance
with the License. You may obtain a copy of the License at
http://www.mozilla.org/MPL/MPL-1.1.html

Software distributed under the License is distributed on an "AS IS" basis,
WITHOUT WARRANTY OF ANY KIND, either expressed or implied. See the License for
the specific language governing rights and limitations under the License.

The Original Code is: JvClipView.PAS, released on 2002-07-04.

The Initial Developers of the Original Code are: Fedor Koshevnikov, Igor Pavluk and Serge Korolev
Copyright (c) 1997, 1998 Fedor Koshevnikov, Igor Pavluk and Serge Korolev
Copyright (c) 2001,2002 SGB Software
All Rights Reserved.

You may retrieve the latest version of this file at the Project JEDI's JVCL home page,
located at http://jvcl.sourceforge.net

Known Issues:
-----------------------------------------------------------------------------}
// $Id: JvClipboardViewer.pas,v 1.25 2005/02/17 10:20:02 marquardt Exp $

unit JvClipboardViewer;

{$I jvcl.inc}
{$I windowsonly.inc}

interface

uses
  {$IFDEF UNITVERSIONING}
  JclUnitVersioning,
  {$ENDIF UNITVERSIONING}
  Windows, Messages, Classes, Graphics, 
  JvExForms;

type
  TClipboardViewFormat = (cvDefault, cvEmpty, cvUnknown, cvText, cvBitmap,
    cvMetafile, cvPalette, cvOemText, cvPicture, cvComponent, cvIcon);
  TJvOnImageEvent = procedure(Sender: TObject; Image: TBitmap) of object;
  TJvOnTextEvent = procedure(Sender: TObject; AText: string) of object;

  TJvCustomClipboardViewer = class(TJvExScrollBox)
  private
    FWndNext: HWND;
    FChained: Boolean;
    FPaintControl: TComponent;
    FViewFormat: TClipboardViewFormat;
    FOnChange: TNotifyEvent;
    FOnImage: TJvOnImageEvent;
    FOnText: TJvOnTextEvent;
    function IsEmptyClipboard: Boolean;
    procedure ForwardMessage(var Msg: TMessage);
    procedure WMDestroyClipboard(var Msg: TMessage); message WM_DESTROYCLIPBOARD;
    procedure WMChangeCBChain(var Msg: TWMChangeCBChain); message WM_CHANGECBCHAIN;
    procedure WMDrawClipboard(var Msg: TMessage); message WM_DRAWCLIPBOARD;
    procedure WMNCDestroy(var Msg: TWMNCDestroy); message WM_NCDESTROY;
    procedure SetViewFormat(Value: TClipboardViewFormat);
    function GetClipboardFormatNames(Index: Integer): string;
  protected
    procedure Loaded; override;
    procedure Resize; override;
    procedure CreateWnd; override;
    procedure DestroyWindowHandle; override;
    procedure DoImage(Image: TBitmap); dynamic;
    procedure DoText(const AText: string); dynamic;
    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;
    property OnImage: TJvOnImageEvent read FOnImage write FOnImage;
    property OnText: TJvOnTextEvent read FOnText write FOnText;
  public
    constructor Create(AOwner: TComponent); override;
    class function CanDrawFormat(ClipboardFormat: Word): Boolean;
    procedure EmptyClipboard;
    property ClipboardFormatNames[Index: Integer]: string read GetClipboardFormatNames;
  end;

  TJvClipboardViewer = class(TJvCustomClipboardViewer)
  published
    property Anchors;
    property BiDiMode;
    property Color default clWindow;
    property Constraints;
    property DragKind;
    property ParentBiDiMode;
    property ParentColor default False;
    property ViewFormat;
    property OnImage;
    property OnText;
    property OnChange;
    property OnContextPopup;
    property OnStartDrag;
    property OnEndDock;
    property OnStartDock;
  end;

function ClipboardFormatToView(Value: Word): TClipboardViewFormat;

{$IFDEF UNITVERSIONING}
const
  UnitVersioning: TUnitVersionInfo = (
    RCSfile: '$RCSfile: JvClipboardViewer.pas,v $';
    Revision: '$Revision: 1.25 $';
    Date: '$Date: 2005/02/17 10:20:02 $';
    LogPath: 'JVCL\run'
  );
{$ENDIF UNITVERSIONING}

implementation

uses
  Math, Controls, Forms, StdCtrls, ExtCtrls, Grids, Clipbrd,
  JvExGrids, JvJVCLUtils, JvJCLUtils, JvResources;

{ 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_TEXT:
        Result := 'Text';
      CF_BITMAP:
        Result := 'Bitmap';
      CF_METAFILEPICT:
        Result := 'Metafile Picture';
      CF_SYLK:
        Result := 'SYLK';
      CF_DIF:
        Result := 'DIF';
      CF_TIFF:
        Result := 'Tag Image';
      CF_OEMTEXT:
        Result := 'OEM Text';
      CF_DIB:
        Result := 'DIB Bitmap';
      CF_PALETTE:
        Result := 'Palette';
      CF_PENDATA:
        Result := 'Pen Data';
      CF_RIFF:
        Result := 'RIFF File';
      CF_WAVE:
        Result := 'Wave';
      // (rom) check for problems before uncomment
      //CF_UNICODETEXT:
      //  Result := 'Unicode text';
      CF_ENHMETAFILE:
        Result := 'Enchanced Metafile';
      //CF_HDROP:
      //  Result := 'Drop files';
      //CF_LOCALE:
      //  Result := 'Locale data';
    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
  case Value of
    CF_TEXT:
      Result := cvText;
    CF_BITMAP:
      Result := cvBitmap;
    CF_METAFILEPICT:
      Result := cvMetafile;
    CF_ENHMETAFILE:
      Result := cvMetafile;
    CF_PALETTE:
      Result := cvPalette;
    CF_OEMTEXT:
      Result := cvOemText;
  else
    Result := cvDefault;
  end;
  if Value = CF_ICON then
    Result := cvIcon // CF_BITMAP
  else
  if Value = CF_PICTURE then
    Result := cvPicture // CF_BITMAP, CF_METAFILEPICT
  else
  if Value = CF_COMPONENT then
    Result := cvComponent; // CF_TEXT
end;

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

//=== { TJvPaletteGrid } =====================================================

const
  NumPaletteEntries = 256;

type
  TJvPaletteGrid = class(TJvExDrawGrid)
  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 Resize; override;
  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 TJvPaletteGrid.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 TJvPaletteGrid.Destroy;
begin
  if FPalette <> 0 then
    DeleteObject(FPalette);
  inherited Destroy;
end;

procedure TJvPaletteGrid.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 TJvPaletteGrid.GetPalette: HPALETTE;
begin
  if FPalette <> 0 then
    Result := FPalette
  else
    Result := inherited GetPalette;
end;

procedure TJvPaletteGrid.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 TJvPaletteGrid.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 TJvPaletteGrid.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;
  if ShowSelector then
  begin
    Canvas.Brush.Color := Self.Color;
    Canvas.Pen.Color := Self.Color;
    InflateRect(CellRect, -1, -1);
    Canvas.DrawFocusRect(CellRect);