PASCAL - BLRPLT.ZIP - COLOR.PAS

 
Output of file : COLOR.PAS contained in archive : BLRPLT.ZIP

{This is Charles Petzold's ABOUT2 example adapted to OWL and Borland Custom
Controls. The skeleton code was generated by BoilerPlate and the necessary
details have been added. It's meant to illustrate several techniques often
used in dialogs.

1. Using a bitmap button (idd_Paint) and the wm_DrawItem message to draw
whatever you want in the dialog.

2. Using the wm_CtlColor message to change fonts, colors.

3. Adding an icon to a dialog.

This particular dialog does not use the transfer method. Use colortst.pas
to test this unit.
}

Unit Color;

Interface
uses
WinTypes, WinProcs,
{$ifdef VER70}
Objects, OWindows, ODialogs, Strings, OStdDlgs, OStdWnds, Validate,
{$else}
WObjects, Strings, StdDlgs, StdWnds,
{$endif}
BWCC, WinDos;

const
idd_Black = 110;
idd_Blue = 111;
idd_Green = 112;
idd_Cyan = 113;
idd_Red = 114;
idd_Magenta = 115;
idd_Yellow = 116;
idd_White = 117;
idd_Ellipse = 103;
idd_Rectangle = 104;
IDD_Title = 101;
idd_Paint = 108;
About2Dlg = 200;

{the color and shape choices are stored in these variables}
CurrentColor : integer = idd_Black;
CurrentFigure : integer = idd_Rectangle;

type

PColorDialog = ^TColorDialog;
TColorDialog = Object(TDialog)
About2 : PStatic;
Paint : PButton;
ThisColor, ThisFigure : integer;
Font : hFont;

constructor Init(AParent : PWindowsObject);
procedure iddBlack(var Msg : TMessage); virtual + id_First + idd_Black;
procedure iddBlue(var Msg : TMessage); virtual + id_First + idd_Blue;
procedure iddGreen(var Msg : TMessage); virtual + id_First + idd_Green;
procedure iddCyan(var Msg : TMessage); virtual + id_First + idd_Cyan;
procedure iddRed(var Msg : TMessage); virtual + id_First + idd_Red;
procedure iddMagenta(var Msg : TMessage); virtual + id_First + idd_Magenta;
procedure iddYellow(var Msg : TMessage); virtual + id_First + idd_Yellow;
procedure iddWhite(var Msg : TMessage); virtual + id_First + idd_White;
procedure iddEllipse(var Msg : TMessage); virtual + id_First + idd_Ellipse;
procedure iddRectangle(var Msg : TMessage); virtual + id_First + idd_Rectangle;
Procedure wmCtlColor(var Msg : TMessage); virtual wm_First + wm_CtlColor;
Procedure wmDrawItem(var Msg : TMessage); virtual wm_First + wm_DrawItem;
procedure PaintTheBlock(Color, Shape : integer);
function CanClose : boolean; virtual;
destructor Done; virtual;
procedure SetupWindow; virtual;
end;

Implementation

{----------------TColorDialog.Init}
constructor TColorDialog.Init(AParent : PWindowsObject);
Var
Control : PControl;
begin
TDialog.Init(AParent, PChar(About2Dlg));

About2 := New(PStatic, InitResource(@Self, IDD_Title, 80));
Paint := New(PButton, InitResource(@Self, idd_Paint));
ThisColor := CurrentColor;
ThisFigure := CurrentFigure;
end;

{-----------------TColorDialog.CanClose}
function TColorDialog.CanClose : boolean;
var
Result : Boolean;
begin
Result := TDialog.CanClose;
if Result then
begin
CurrentColor := ThisColor; {update the outside globals if OK hit}
CurrentFigure := ThisFigure;
end;
CanClose := Result;
end;

{-----------------TColorDialog.Done}
destructor TColorDialog.Done;
begin
DeleteObject(Font);
TDialog.Done;
end;

{-----------------TColorDialog.SetupWindow}
procedure TColorDialog.SetupWindow;
var
LogFont : TLogFont;
begin
TDialog.SetupWindow;
with LogFont do {get a larger font for the title}
begin
FillChar(LogFont, Sizeof(LogFont), 0);
StrCopy(lfFaceName, 'MS Sans Serif');
lfHeight := 30;
lfWeight := FW_Bold;
Font := CreateFontIndirect(LogFont);
end;

{initialize the checkboxes}
CheckRadioButton(hWindow, idd_Black, idd_White, ThisColor);
CheckRadioButton(hWindow, idd_Ellipse, idd_Rectangle, ThisFigure);
end;

{----------------TColorDialog.PaintTheBlock}
procedure TColorDialog.PaintTheBlock(Color, Shape : integer);
begin
ThisColor := Color;
ThisFigure := Shape;
InvalidateRect(Paint^.hWindow, Nil, True); {force repaint}
UpdateWindow(Paint^.hWindow);
end;

{-----------------TColorDialog.iddBlack}
procedure TColorDialog.iddBlack(var Msg : TMessage);
begin
PaintTheBlock(idd_Black, ThisFigure);
end;

{-----------------TColorDialog.iddBlue}
procedure TColorDialog.iddBlue(var Msg : TMessage);
begin
PaintTheBlock(idd_Blue, ThisFigure);
end;

{-----------------TColorDialog.iddGreen}
procedure TColorDialog.iddGreen(var Msg : TMessage);
begin
PaintTheBlock(idd_Green, ThisFigure);
end;

{-----------------TColorDialog.iddCyan}
procedure TColorDialog.iddCyan(var Msg : TMessage);
begin
PaintTheBlock(idd_Cyan, ThisFigure);
end;

{-----------------TColorDialog.iddRed}
procedure TColorDialog.iddRed(var Msg : TMessage);
begin
PaintTheBlock(idd_Red, ThisFigure);
end;

{-----------------TColorDialog.iddMagenta}
procedure TColorDialog.iddMagenta(var Msg : TMessage);
begin
PaintTheBlock(idd_Magenta, ThisFigure);
end;

{-----------------TColorDialog.iddYellow}

procedure TColorDialog.iddYellow(var Msg : TMessage);
begin
PaintTheBlock(idd_Yellow, ThisFigure);
end;

{-----------------TColorDialog.iddWhite}
procedure TColorDialog.iddWhite(var Msg : TMessage);
begin
PaintTheBlock(idd_White, ThisFigure);
end;

{-----------------TColorDialog.iddEllipse}
procedure TColorDialog.iddEllipse(var Msg : TMessage);
begin
PaintTheBlock(ThisColor, idd_Ellipse);
end;

{-----------------TColorDialog.iddRectangle}
procedure TColorDialog.iddRectangle(var Msg : TMessage);
begin
PaintTheBlock(ThisColor, idd_Rectangle);
end;

{-----------------TColorDialog.wmCtlColor}
Procedure TColorDialog.wmCtlColor(var Msg : TMessage);
{wParam, display context handle of child window
lParamLo, window handlw of child window
lParamHi, type of child window such as cntcolor_Listbox}
begin
with Msg do
if lParamLo = About2^.hWindow then {if it's the title}
begin {Note: Use an ordinary Text control for idd_Title, not BWCC control}
SelectObject(wParam, Font);
SetTextColor(wParam, RGB(255, 0, 0));
SetBkMode(wParam, Transparent);
Result := GetStockObject(LtGray_Brush);
end
else DefWndProc(Msg); {must be called for all messages not processed here}
end;

{-----------------TColorDialog.wmDrawItem}
Procedure TColorDialog.wmDrawItem(var Msg : TMessage);
{lParam points to TDrawItemStruct}
const
Colors : array[idd_Black..idd_White] of LongInt =
(0, $FF0000, $FF00, $FFFF00, $FF, $FF00FF, $FFFF, $FFFFFF);
var
Brush : hBrush;
Pen : hPen;
begin
with PDrawItemStruct(Msg.lParam)^ do
if CtlID = idd_Paint then
begin
Brush := CreateSolidBrush(Colors[ThisColor]);
Brush := SelectObject(hDC, Brush); {save old brush}
Pen := CreatePen(PS_Solid, 0, Colors[ThisColor]);
Pen := SelectObject(hDC, Pen); {save old pen}
if ThisFigure = idd_Rectangle then
Rectangle(hDC, 0, 0, rcItem.Right, rcItem.Bottom)
else
begin
FillRect(hDC, rcItem, GetStockObject(LtGray_Brush));
Ellipse(hDC, 0, 0, rcItem.Right, rcItem.Bottom);
end;
DeleteObject(SelectObject(hDC, Brush)); {also restores old brush}
DeleteObject(SelectObject(hDC, Pen)); {also restores old pen}
end
else DefWndProc(Msg);
end;


end.