Category : Pascal Source Code
Archive   : TPW2VB.ZIP
Filename : CIRCLE3.PAS

 
Output of file : CIRCLE3.PAS contained in archive : TPW2VB.ZIP
library circle3;

{$R circle3.RES}
{$D Opaque Software © - Circle3 Demo}


uses wintypes, winprocs, tpw2vb, strings;


{//---------------------------------------------------------------------------
// Resource ID's
//---------------------------------------------------------------------------
// Toolbox bitmap resource IDs.
//---------------------------------------------------------------------------}
const
IDBMP_Circle = 8000;
IDBMP_CircleDOWN = 8001;
IDBMP_CircleMONO = 8003;
IDBMP_CircleEGA = 8006;

{//---------------------------------------------------------------------------
// Constants used by dialog boxes
//---------------------------------------------------------------------------}
const
DI_OK = 1;
DI_CANCEL = 2;
DI_REDOPT = 105;
DI_GREENOPT = 106;
DI_BLUEOPT = 107;

{//---------------------------------------------------------------------------
// Procedure Declarations
//---------------------------------------------------------------------------}

{//---------------------------------------------------------------------------
// Global Variables and Constants
//---------------------------------------------------------------------------}
const
CLASS_FLASHPOPUP = 'FCPopup';
taskDevEnvironment: THandle = 0;
var
ipropDialog: Word;
hctlDialog: HCtl;

{//---------------------------------------------------------------------------
// CIRCLE control data and structs
//---------------------------------------------------------------------------}
type
PCircle = ^TCircle;
TCircle = record
rectDrawInto: TRect;
CircleShape: Enum; { Changed from SHORT to demonstrate ENUM prop }
FlashColor: LongInt;
Font: HFont;
Caption: Hsz;
end;

{//---------------------------------------------------------------------------
// Private messages
//---------------------------------------------------------------------------}
const
CM_OPENFLASHDLG = WM_User + 1;

{//---------------------------------------------------------------------------
// Property list
//---------------------------------------------------------------------------
// Define the consecutive indicies for the properties
//---------------------------------------------------------------------------}
const
IPROP_Circle_CTLNAME = 0;
IPROP_Circle_INDEX = 1;
IPROP_Circle_BACKCOLOR = 2;
IPROP_Circle_LEFT = 3;
IPROP_Circle_TOP = 4;
IPROP_Circle_WIDTH = 5;
IPROP_Circle_HEIGHT = 6;
IPROP_Circle_VISIBLE = 7;
IPROP_Circle_PARENT = 8;
IPROP_Circle_DRAGMODE = 9;
IPROP_Circle_DRAGICON = 10;
IPROP_Circle_TAG = 11;
IPROP_Circle_CircleShape = 12;
IPROP_Circle_FlashColor = 13;
IPROP_Circle_CAPTION = 14;
IPROP_Circle_FONTNAME = 15;
IPROP_Circle_FONTBOLD = 16;
IPROP_Circle_FONTITALIC = 17;
IPROP_Circle_FONTSTRIKE = 18;
IPROP_Circle_FONTUNDER = 19;
IPROP_Circle_FONTSIZE = 20;
IPROP_Circle_BORDERSTYLE = 21;

{// List of enumeration for CircleShape ENUM property}
SHAPE_CIRCLE = 0;
SHAPE_OVAL = 1;
SHAPE_MAX = 1;

Property_CircleShape: TPROPINFO =
(
npszName: NPnt(PChar('CircleShape'));
fl: DT_Enum or PF_fGetData or PF_fSetMsg or PF_fSaveData;
offsetData: 8;
infoData: 0;
dataDefault: Shape_Circle;
npszEnumList: NPnt(PChar( '0 - Circle' +#0+
'1 - Oval' +#0+#0)) ;
enumMax: Shape_Max
);

Property_FlashColor: TPROPINFO =
(
npszName: NPnt(PChar('FlashColor'));
fl: DT_Color or PF_fGetData or PF_fSetData or
PF_fSaveData or PF_fEditable;
offsetData: 9;
infoData: 0;
dataDefault: 0;
npszEnumList: 0;
enumMax: 0
);

const
PropListCircle : array[0..26]of PPROPINFO =
(
PPROPINFO_STD_CTLNAME,
PPROPINFO_STD_INDEX,
PPROPINFO_STD_BACKCOLOR,
PPROPINFO_STD_LEFT,
PPROPINFO_STD_TOP,
PPROPINFO_STD_WIDTH,
PPROPINFO_STD_HEIGHT,
PPROPINFO_STD_VISIBLE,
PPROPINFO_STD_PARENT,
PPROPINFO_STD_DRAGMODE,
PPROPINFO_STD_DRAGICON,
PPROPINFO_STD_TAG,
PPropInfo(@Property_CircleShape),
PPropInfo(@Property_FlashColor),
PPROPINFO_STD_CAPTION,
PPROPINFO_STD_FONTNAME,
PPROPINFO_STD_FONTBOLD,
PPROPINFO_STD_FONTITALIC,
PPROPINFO_STD_FONTSTRIKE,
PPROPINFO_STD_FONTUNDER,
PPROPINFO_STD_FONTSIZE,
PPROPINFO_STD_BORDERSTYLEOFF,
PPROPINFO_STD_TABINDEX,
PPROPINFO_STD_TABSTOP,
PPROPINFO_STD_ENABLED,
PPROPINFO_STD_MOUSEPOINTER,
0
);

{//---------------------------------------------------------------------------
// Event procedure parameter prototypes
//---------------------------------------------------------------------------}


{//---------------------------------------------------------------------------
// Event list
//---------------------------------------------------------------------------
// Define the consecutive indicies for the events
//---------------------------------------------------------------------------}
const
IEVENT_CIRCLE_CLICKIN = 0;
IEVENT_CIRCLE_CLICKOUT = 1;
IEVENT_CIRCLE_DRAGDROP = 2;
IEVENT_CIRCLE_DRAGOVER = 3;

Paramtypes_ClickIn: array[0..2]of Word = (ET_R4, ET_R4, ET_SD);

Event_ClickIn: TEVENTINFO = (
npszName: NPnt(PChar('ClickIn'));
cParms: 3;
cwParms: 6;
npParmTypes: NPnt(@Paramtypes_ClickIn);
npszParmProf: NPnt(PChar('X As Single,Y As Single,Caption As String'));
fl: 0
);

Event_ClickOut: TEVENTINFO = (
npszName: NPnt(PChar('ClickOut'));
cParms: 0;
cwParms: 0;
npParmTypes: 0;
npszParmProf: 0;
fl: 0
);

EventListCircle: array[0..4]of PEVENTINFO = (
PEventInfo(@Event_ClickIn),
PEventInfo(@Event_ClickOut),
PEVENTINFO_STD_DRAGDROP,
PEVENTINFO_STD_DRAGOVER,
0
);

{//---------------------------------------------------------------------------
// Return TRUE if the given coordinates are inside of the circle.
//---------------------------------------------------------------------------}
function InCircle(Circle: PCircle; xcoord, ycoord: Integer):Boolean;
var
a, b, x, y: Double;
prect: ^TRect;
begin
prect := @Circle^.rectDrawInto;
a := (prect^.right - prect^.left) / 2;
b := (prect^.bottom - prect^.top) / 2;
x := xcoord - (prect^.left + prect^.right) / 2;
y := ycoord - (prect^.top + prect^.bottom) / 2;
InCircle := ((x * x) / (a * a) + (y * y) / (b * b) <= 1);
end;

{//---------------------------------------------------------------------------
// Paint the circle in the FlashColor.
//---------------------------------------------------------------------------}
procedure FlashCircle(Circle: PCircle; DC: HDC);
var
hbr, hbrOld: HBrush;
prect: ^TRect;
begin
hbrOld := 0;
prect := @Circle^.rectDrawInto;
hbr := CreateSolidBrush(RGBColor(Circle^.FlashColor));
if Boolean(hbr) then
hbrOld := SelectObject(DC, hbr);
Ellipse(DC, prect^.left, prect^.top, prect^.right, prect^.bottom);
if Boolean(hbr) then
begin
SelectObject(DC, hbrOld);
DeleteObject(hbr);
end;
end;

{//---------------------------------------------------------------------------
// Handle painting by drawing circle into the given hdc.
//---------------------------------------------------------------------------}
procedure PaintCircle(Circle: PCircle; Wnd: HWnd; DC: HDC);
var
hbr, hbrOld: HBrush;
tmpStr: LPStr;
FontOld: HFont;
prect: ^TRect;
begin
hbrOld := 0;
prect := @Circle^.rectDrawInto;
hbr := SendMessage(GetParent(Wnd), WM_CTLCOLOR,
DC, MAKELONG(Wnd, 0));
hbrOld := SelectObject(DC, hbr);
Ellipse(DC, prect^.left, prect^.top, prect^.right, prect^.bottom);

FontOld := SelectObject(DC, Circle^.Font);
tmpStr := VBDerefHsz(Circle^.Caption);
DrawText(DC, tmpStr, -1, Circle^.rectDrawInto,
DT_VCENTER or DT_CENTER or DT_SINGLELINE);
SelectObject(DC, fontOld);
SelectObject(DC, hbrOld);
end;

{//---------------------------------------------------------------------------
// TYPEDEF for parameters to the ClickIn event.
//---------------------------------------------------------------------------}
type
TClickInParams = record
ClickString: HLStr;
Y, X: ^Float;
Index: Pointer
end;

{//---------------------------------------------------------------------------
// Use the hwnd's client size to determine the bounding rectangle for the
// circle. If CircleShape is TRUE, then we need to calculate a square
// centered in prect.
//---------------------------------------------------------------------------}
procedure RecalcArea(Circle: PCircle; Wnd: HWnd);
var
prect: ^TRect;
begin
prect := @Circle^.rectDrawInto;
GetClientRect(Wnd, Circle^.rectDrawInto);
if Circle^.CircleShape <> SHAPE_OVAL then
if prect^.right > prect^.bottom then
begin
prect^.left := (prect^.right - prect^.bottom) div 2;
prect^.right := prect^.left + prect^.bottom;
end
else if prect^.bottom > prect^.right then
begin
prect^.top := (prect^.bottom - prect^.right) div 2;
prect^.bottom := prect^.top + prect^.right;
end;
end;

{//---------------------------------------------------------------------------
// Fire the ClickIn event, passing the x,y coords of the click. Also pass
// the current caption of the Circle control, to demonstrate passing strings
// to event procedures.
//---------------------------------------------------------------------------}
procedure FireClickIn(Control: HCtl; Wnd: HWnd; x, y: Integer);
var
params: TClickInParams;
VBx, VBy: Float;
cbCaption, err: Integer;
strBuf: array[0..19]of char;
begin

VBx := VBXPixelsToTwips(x);
VBy := VBYPixelsToTwips(y);
params.X := @VBx;
params.Y := @VBy;

cbCaption := GetWindowText(Wnd, strBuf, 20);
params.ClickString := VBCreateHlstr(@strBuf, cbCaption);
err := VBFireEvent(Control, IEVENT_CIRCLE_CLICKIN, @params);
VBDestroyHlstr(params.ClickString);
end;

{//---------------------------------------------------------------------------
// Fire the ClickOut event.
//---------------------------------------------------------------------------}
procedure FireClickOut(Control: HCtl);
begin
VBFireEvent(Control, IEVENT_CIRCLE_CLICKOUT, nil);
end;

{//---------------------------------------------------------------------------
// Create our property popup-window. Since we want to put up a dialog, this
// window never becomes visible. Instead, when asked to become visible, it
// will post a message to itself, remining it to put up our dialog.
//
// NOTE: May return nil!
//---------------------------------------------------------------------------}
function HwndInitFlashPopup: HWnd;
begin
HwndInitFlashPopup := CreateWindow('FCPopup', nil, ws_Popup,
0, 0, 0, 0, 0, 0, HInstance, nil);
end;

{//---------------------------------------------------------------------------
// An array mapping option buttons to RGB colors.
//---------------------------------------------------------------------------}
const
mpidcolor: array[0..2]of LongInt = ( $ff, $ff00, $ff0000 );

{//---------------------------------------------------------------------------

// The Dialog Procedure for the FlashColor property dialog.
//---------------------------------------------------------------------------}
function FlashDlgProc(Wnd: HWnd; Msg, WParam: Word;
LParam: LongInt): Bool; export;
var
rect: TRect;
nx, ny, width, height, i: Integer;
const
ColorOld: LongInt = 0;
begin
case Msg of
WM_InitDialog: begin
{// Position dialog so it looks nice:}
GetWindowRect(Wnd, rect);
width := rect.right - rect.left;
height := rect.bottom - rect.top;
nx := (GetSystemMetrics(SM_CXSCREEN) - width) div 2;
ny := (GetSystemMetrics(SM_CYSCREEN) - height) div 3;
MoveWindow(Wnd, nx, ny, width, height, FALSE);
{// Remember the old value of this property, so we can restore it
// on cancel:}
if Boolean(VBGetControlProperty(hctlDialog, ipropDialog, @ColorOld)) then
EndDialog(Wnd, 0);
{// If the current color matches one of the option button colors,
// then set that option button:}
for i :=0 to 2 do
if mpidcolor[i] = colorOld then
CheckRadioButton(Wnd, DI_REDOPT, DI_BLUEOPT, i+DI_REDOPT);
FlashDlgProc := True;
exit;
end;

WM_Command:
case WParam of
idOk: begin
EndDialog(Wnd, 1);
FlashDlgProc := True;
exit;
end;
idCancel: begin
EndDialog(Wnd, 0);
VBSetControlProperty(hctlDialog, ipropDialog, colorOld);
FlashDlgProc := True;
exit;
end;
DI_RedOpt,
DI_GreenOpt,
DI_BlueOpt: begin
CheckRadioButton(Wnd, DI_REDOPT, DI_BLUEOPT, WParam);
VBSetControlProperty(hctlDialog, ipropDialog,
mpidcolor[WParam - DI_REDOPT]);
FlashDlgProc := True;
exit;
end;
else
FlashDlgProc := False;
end;
else
FlashDlgProc := False;
end;
end;

{//---------------------------------------------------------------------------
// We asked to show ourself, remain invisible and post a CM_OPENFlashDLG to
// ourself. When we receive this message, open the dialog box.
//---------------------------------------------------------------------------}
function FlashPopupWndProc(Wnd: HWnd; Msg, WParam: Word;
LParam: LongInt): LongInt; export;
begin
case Msg of
WM_SHOWWINDOW:
if Boolean(WParam) then
begin
PostMessage(Wnd, CM_OPENFlashDLG, 0, 0);
FlashPopupWndProc := 0;
exit;
end;

CM_OPENFlashDLG: begin
VBDialogBoxParam(HInstance, 'FlashDlg', @FlashDlgProc, 0);
FlashPopupWndProc := 0;
exit;
end;

end;
FlashPopupWndProc := DefWindowProc(Wnd, Msg, WParam, LParam);
end;

{//---------------------------------------------------------------------------
// Control Procedure
// This routine is called for all VB and Windows Msgs.
//---------------------------------------------------------------------------}
function CircleCtlProc(Control: HCtl; Wnd: HWnd;
Msg, WParam: Word; LParam: LongInt):LongInt; export;
var
Circle: PCircle;
DC: HDC;
SZ: Hsz;
tmpStr: PChar;

cch: Word;
LGet: PLongInt;
ps: TPaintStruct;
begin
case Msg of
WM_CREATE: begin
Circle := PCircle(VBDerefControl(Control));
Circle^.CircleShape := SHAPE_CIRCLE;
Circle^.FlashColor := 0;
VBSetControlProperty(Control, IPROP_CIRCLE_BACKCOLOR, 255);
{// *** pcircle may now be invalid due to call to VB API ***}
end;

WM_LBUTTONDOWN,
WM_LBUTTONDBLCLK: begin
Circle := PCircle(VBDerefControl(Control));
if InCircle(Circle, LOWORD(LParam), HIWORD(LParam)) then
begin
DC := GetDC(Wnd);
FlashCircle(Circle, DC);
ReleaseDC(Wnd, DC);
FireClickIn(Control, Wnd, LOWORD(LParam), HIWORD(LParam));
{// *** pcircle may now be invalid due to call to VB API ***
// *** inside this function *** }
end
else
FireClickOut(Control);
{// *** pcircle may now be invalid due to call to VB API ***
// *** inside this function ***}
end;

WM_LBUTTONUP: begin
Circle := PCircle(VBDerefControl(Control));
if InCircle(Circle, LOWORD(LParam), HIWORD(LParam)) then
begin
DC := GetDC(Wnd);
PaintCircle(Circle, Wnd, DC);
ReleaseDC(Wnd, DC);
end;
end;

WM_SETFONT: begin
Circle := PCircle(VBDerefControl(Control));
Circle^.Font := HFont(WParam);
CircleCtlProc := VBDefControlProc(Control, Wnd, Msg, WParam, LParam);
exit;
end;

WM_GETFONT: begin
Circle := PCircle(VBDerefControl(Control));
CircleCtlProc := Circle^.Font;
exit;
end;

WM_SETTEXT: begin
Circle := PCircle(VBDerefControl(Control));
if Boolean(Circle^.Caption) then
VBDestroyHsz(Circle^.Caption);
{// *** pcircle may now be invalid due to call to VB API ***}
Sz := VBCreateHsz(Control, PChar(LParam));
{// *** pcircle may now be invalid due to call to VB API ***}
Circle := PCircle(VBDerefControl(Control));
Circle^.Caption := Sz;
InvalidateRect(Wnd, nil, TRUE);
CircleCtlProc := 0;
exit;
end;

WM_GETTEXT: begin

Circle := PCircle(VBDerefControl(Control));
if Circle^.Caption = nil then
begin
LGet := PLongInt(LParam);
LGet^ := 0;
WParam := 1;
end
else
begin
tmpStr := VBDerefHsz(Circle^.Caption);
cch := lstrlen(tmpStr) + 1;
if WParam > cch then
WParam := cch;
StrLCopy(PChar(LParam), tmpStr, WParam);
PChar(LParam)[WParam - 1] := #0;
end;
CircleCtlProc := WParam -1;
exit;
end;

WM_GETTEXTLENGTH: begin
Circle := PCircle(VBDerefControl(Control));
if Circle^.Caption = nil then
CircleCtlProc := 0
else
CircleCtlProc := lstrlen(VBDerefHsz(Circle^.Caption));
exit;
end;

WM_PAINT: begin
Circle := PCircle(VBDerefControl(Control));
if Boolean(WParam) then
PaintCircle(Circle, Wnd, HDC(WParam))
else
begin
BeginPaint(Wnd, ps);
PaintCircle(Circle, Wnd, ps.hdc);
EndPaint(Wnd, ps);
end;
end;

WM_SIZE: begin
Circle := PCircle(VBDerefControl(Control));
RecalcArea(Circle, Wnd);
end;

VBM_SETPROPERTY:
case WParam of
IPROP_Circle_CircleShape: begin
Circle := PCircle(VBDerefControl(Control));
Circle^.CircleShape := Enum(LParam);
RecalcArea(Circle, Wnd);
InvalidateRect(Wnd, nil, TRUE);
CircleCtlProc := 0;
exit;
end;
end;

VBM_INITPROPPOPUP:
case WParam of
{// Un-commenting the following line will enable our custom
// popup instead of the color palette, when setting the
// backcolor:
// case IPROP_CIRCLE_BACKCOLOR:}
IPROP_CIRCLE_FLASHCOLOR: begin
hctlDialog := Control;
ipropDialog := WParam;
CircleCtlProc := HwndInitFlashPopup;
exit
end;
end;

end;
CircleCtlProc := VBDefControlProc(Control, Wnd, Msg, WParam, LParam);
end;

{//---------------------------------------------------------------------------
// Model struct
//---------------------------------------------------------------------------
// Define the control model (using the event and property structures).
//---------------------------------------------------------------------------}
const
modelCircle: TMODEL = (
usVersion: VB_VERSION; {VB version used by control}
fl: 0; { Bitfield structure}
ctlproc: TFarProc(@CircleCtlProc); {the control proc.}
fsClassStyle: cs_VRedraw or cs_HRedraw; { window class style}
flWndStyle: 0; {default window style}
cbCtlExtra: sizeof(TCircle); { # bytes alloc'd for HCTL structure}
idBmpPalette: IDBMP_Circle; { BITMAP id for tool palette}
DefCtlName: NPnt(PChar('Circle3_')); { default control name prefix}
ClassName: NPnt(PChar('Circle3')); { Visual Basic class name}
ParentClassName: 0; { Parent window class if subclassed}
proplist: ofs(PropListCircle) ; { Property list}
eventlist: ofs(EventListCircle); { Event list}
nDefProp: 0; { index of default property}
nDefEvent: 0 { index of default event}
);

{//---------------------------------------------------------------------------
// Register custom control.
// This routine is called by VB when the custom control DLL is
// loaded for use.
//---------------------------------------------------------------------------}
function VBINITCC(usVersion: Word; fRunTime: Boolean): Boolean; export;
var
Class: TWndClass;
begin
if not fRuntime then
begin
class.style := 0;
class.lpfnWndProc := @FlashPopupWndProc;
class.cbClsExtra := 0;
class.cbWndExtra := 0;
class.hInstance := HInstance;
class.hIcon := 0;
class.hCursor := 0;
class.hbrBackground := 0;
class.lpszMenuName := nil;
class.lpszClassName := 'FCPopup';

RegisterClass(class);
taskDevEnvironment := GetCurrentTask;
end;

VBINITCC := VBRegisterModel(HInstance, modelCircle);
end;

{//---------------------------------------------------------------------------
// Unregister the property popup used to set FlashColor, if this unload
// is from the development environment.
//---------------------------------------------------------------------------}
procedure VBTERMCC; export;
begin
{// Unregister popup class if this is from the development environment}
if taskDevEnvironment = GetCurrentTask then
begin
UnregisterClass('FCPopup', HInstance);
taskDevEnvironment := 0;
end;
end;


exports
VBINITCC index 2,
CircleCtlProc index 3,
FlashDlgProc index 4,
VBTERMCC,
FlashPopupWndProc;

begin

end.


  3 Responses to “Category : Pascal Source Code
Archive   : TPW2VB.ZIP
Filename : CIRCLE3.PAS

  1. Very nice! Thank you for this wonderful archive. I wonder why I found it only now. Long live the BBS file archives!

  2. This is so awesome! 😀 I’d be cool if you could download an entire archive of this at once, though.

  3. But one thing that puzzles me is the “mtswslnkmcjklsdlsbdmMICROSOFT” string. There is an article about it here. It is definitely worth a read: http://www.os2museum.com/wp/mtswslnk/