STPGRID

Top  Previous  Next

unit Stpgrid;

 

interface

 

Uses

SysUtils, {$IFDEF WIN32} Windows, {$ELSE} WinTypes, WinProcs, {$ENDIF}

Messages, Classes, Graphics, Controls, Forms, Dialogs, StdCtrls,  ExtCtrls,

MaxMin, Grids, VCLUtils;

 

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;

 

 

procedure Register;

 

implementation

{ TPaletteGrid }

 

procedure Register;

begin

RegisterComponents('StellaMAP',[TPaletteGrid])

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;

if ShowSelector then begin

  Canvas.Brush.Color := Self.Color;

  Canvas.Pen.Color := Self.Color;

  InflateRect(CellRect, -1, -1);

  Canvas.DrawFocusRect(CellRect);

end;

end;

 

function TPaletteGrid.SelectCell(ACol, ARow: Longint): Boolean;

begin

Result := ((ACol = 0) and (ARow = 0)) or (CellColor(ACol, ARow) <> clNone);

end;

 

procedure TPaletteGrid.DrawCell(ACol, ARow: Longint; ARect: TRect;

AState: TGridDrawState);

var

Color: TColor;

begin

Color := CellColor(ACol, ARow);

if Color <> clNone then

  DrawSquare(PaletteColor(Color), ARect, gdFocused in AState)

else begin

  Canvas.Brush.Color := Self.Color;

  Canvas.FillRect(ARect);

end;

end;

 

procedure TPaletteGrid.WMSize(var Message: TWMSize);

begin

inherited;

UpdateSize;

end;

 

end.