E-CTRL
Creating Custom
Controls
Overview
Enhance your user interface with custom controls beyond those VFP provides. Demonstration and discussion of thermometers, sliders, and other controls which can be added to your palette of tools. Issues involved with developing and integrating controls into VFP applications, including proper documentation, data binding, and limitations of using your own or third-party add-ins.
Slider Bar
A slider bar can be built from a line, an image, a textbox and an invisible shape. The line and image represent the slider, the textbox displays the value, and the shape is used as a sensitive area to detect the mouse movements. Key code snippets are included below. Complete code is provided on disk in SLIDER.VCX and COLORGET.SCX
DEFINE CLASS slider AS container
*-- Maximum value the slider can display
nmaxvalue = 100
*-- The value of the control.
value = 0
Name = "slider"
ADD OBJECT line1 AS line WITH ;
ADD OBJECT line2 AS line WITH ;
ADD OBJECT image1 AS image WITH ;
Picture = "slider1.bmp", ;
ADD OBJECT shape1 AS shape WITH ;
ADD OBJECT text1 AS textbox WITH ;
Value = 0, ;
*-- Occurs whenever Value changes. Used as a stub - containers don't ;
have a native InteractiveChange() event nor Value property.
PROCEDURE InteractiveChange
ENDPROC
PROCEDURE shape1.MouseMove
LPARAMETERS nButton, nShift, nXCoord, nYCoord
* if left mouse down, BITTEST() and in the range of the line
* Calculate the position of the X-coordinate relative to
* the position of the control on the form.
* OBJTOCLIENT() is a VFP 3 function which returns the
* pixel placement of the named object to the form.
* Subtracting the left value (the 2nd parameter) from
* the passed form XCoord returns the location to which
* the slider should be moved relative to the container.
nXCoord = nXCoord - OBJTOCLIENT(this.parent,2)
if bittest(nButton,0) AND ;
nXCoord >= this.left AND ;
nXCoord <= this.left + this.width
* center the image on the x-coordinate
this.parent.image1.left = nXCoord - .5 * this.parent.image1.width
this.parent.text1.value = ROUND(this.parent.nMaxValue *
(nXCoord-this.parent.line1.left) / ;
this.parent.line1.width,0)
endif
ENDPROC
PROCEDURE shape1.MouseDown
LPARAMETERS nButton, nShift, nXCoord, nYCoord
nXCoord = nXCoord - OBJTOCLIENT(this.parent,2)
this.parent.image1.left = nXCoord - .5 * this.parent.image1.width
this.parent.text1.value = ROUND(this.parent.nMaxValue *
(nXCoord-this.parent.line1.left) / ;
this.parent.line1.width,0)
ENDPROC
PROCEDURE text1.ProgrammaticChange
This.InteractiveChange()
ENDPROC
PROCEDURE text1.InteractiveChange
* Limit the value to between zero and nMaxValue ;
Catch a slide off the end of the bar sometimes ;
MouseMove or Click will overshoot by a pixel or two. ;
Also prevents keyboarding a value outside the range.
if this.value > this.parent.nMaxValue
this.value = this.parent.nMaxValue
endif
if this.value < 0
this.value = 0
endif
* Update the container's value
this.parent.value = this.value
* Fire the container's InteractiveChange() event
this.parent.InteractiveChange()
ENDPROC
ENDDEFINE
*
*-- EndDefine: slider
**************************************************
Thermometer
Thermometers come in all colors, orientations, and fill patterns (up or down, left or right). This example class gives you some ideas of how to produce these effects. The basic thermometer consists of two shapes, one for the outer frame and one to display the "mercury" as it fills or drains, and a label to display the value of the thermometer over time. Obviously, this basic control can be combined with other controls (labels and perhaps timers) on forms to produce the desired effect. Key code fragments are reproduced below. The class library is THRMOMTR.VCX and the demo form THRMDEMO.SCX.
*
DEFINE CLASS thermometer AS control
*-- Percentage Complete to be displayed
PROTECTED npctcomplete
npctcomplete = (1)
*-- Size of the frame around the thermometer
framewidth = 1
*-- Color Property for a sincle-color thermometer fill.
mercurycolor = 255
*-- Percent change which
will cause Mercury to be re-drawn.
Zero causes continual refesh.
Default to one.
interval = (1)
*-- Property which
determines if mercury fills from
bottom to top or left to right
orientation = (0)
*-- Percentage last used to update the thermometer's shape and text.
*-- Used to test if (Interval) has passed for updating.
PROTECTED noldpercent
noldpercent = (1)
ADD OBJECT shpthermframe1 AS shpthermframe WITH ;
ADD OBJECT shpmercury1 AS shpmercury WITH ;
ADD OBJECT lblcomplete AS lblpercent WITH ;
*-- Method called by
external objects with a parameter
*-- to update the percentage complete
PROCEDURE updatepct
lparameters nPctComplete
this.nPctComplete = nPctComplete
* redisplay text and shape if "Interval" is exceeded
if this.nPctComplete >= this.nOldPercent + this.Interval or ;
this.nPctComplete <= this.nOldPercent - this.Interval or ;
this.nPctComplete = 100
this.UpdateText() && re-display text
this.UpdateMercury() && re-display mercury
this.nOldPercent = this.nPctComplete
endif
ENDPROC
*-- Redraws the fill-in mercury shape. Called by UpdatePct()
PROTECTED PROCEDURE updatemercury
* Resize the mercury to show the new complete percentage
do case
case this.Orientation = 0 && default left-to-right
this.shpMercury1.Width=(this.nPctComplete/100) * ;
(this.width-2*this.shpThermFrame1.BorderWidth)
case this.Orientation = 1 && bottom-to-top
this.shpMercury1.Top = this.shpThermFrame1.BorderWidth + ;
((100-this.nPctComplete)/100) * ;
(this.Height-2*this.shpThermFrame1.BorderWidth)
this.shpMercury1.Height = (this.Height - ;
this.shpThermFrame1.BorderWidth) - ;
this.shpMercury1.Top
case this.Orientation = 99 && top-to-bottom "drain" effect
this.shpMercury1.Top = this.shpThermFrame1.BorderWidth + ;
(this.nPctComplete/100) * ;
(this.Height-2*this.shpThermFrame1.BorderWidth)
this.shpMercury1.Height = (this.Height - ;
this.shpThermFrame1.BorderWidth) - ;
this.shpMercury1.Top
otherwise
error 1560
endcase
ENDPROC
*-- Redisplays the label on the thermometer. Called by UpdatePct()
PROTECTED PROCEDURE updatetext
* Refresh the "percent complete" text
this.lblComplete.Caption=transform(this.nPctComplete,"@R 999%")
* Recenter the text string.
this.lblComplete.Left=(this.width-this.lblComplete.Width)/2
ENDPROC
PROCEDURE Init
* Store an inital 1 percent, because
* 3-d shapes do funny things with zero widths
this.nPctComplete = 1
* But we want the oldpercent to increment each "intervalth"
* amount (i.e., 5,10,15,... or 2,4,6,...) so it starts at zero
this.nOldPercent = 0
* Size the frame to the size of the control on the form
this.shpThermframe1.Height=this.Height
this.shpThermFrame1.Width=this.Width
this.shpThermFrame1.BorderWidth=this.FrameWidth
* Size the Mercury to fit within the borders of the frame
this.shpMercury1.Left=this.shpThermFrame1.BorderWidth
this.shpMercury1.FillColor=this.MercuryColor
do case
case this.Orientation = 0 && default left-to-right
this.shpMercury1.Top=this.shpThermFrame1.BorderWidth
this.shpMercury1.Height=this.height - ;
2*this.shpThermFrame1.Borderwidth
case this.Orientation = 1 && bottom-to-top fill
this.shpMercury1.Top=this.Height - ;
2 * this.shpThermFrame1.BorderWidth
this.shpMercury1.Height = 1
this.shpMercury1.Width=this.Width - ;
2*this.shpThermFrame1.Borderwidth
case this.Orientation = 99 && top-to-bottom "drain" effect
this.shpMercury1.Top = this.shpThermFrame1.BorderWidth
this.shpMercury1.Height = (this.Height - ;
this.shpThermFrame1.BorderWidth) - ;
this.shpMercury1.Top
this.shpMercury1.Width=this.Width - ;
2*this.shpThermFrame1.Borderwidth
otherwise
&& unacceptable property value
error 1560
endcase
* Center the label horizontally & vertically
this.lblComplete.Left=(this.Width-this.lblComplete.Width)/2
this.lblComplete.Top=(this.Height-this.lblComplete.Height)/2
ENDPROC
ENDDEFINE
*-- EndDefine: thermometer
**************************************************
Always On Top pushpin 
This is probably the simplest class coded. The pushpin is a checkbox with two graphics, one in the Picture property and one, the DownPicture property. Reverse the form's AlwaysOnTop property, swipe a thumbtack bitmap, and you're in business! Microsoft appears to have abandoned this graphical widget in favor of context-sensitive menu options.
WhatsThis? Help 
Unbeknownst to most FoxPro developers, FoxPro has had a context sensitive WhatsThis? Help system available since before the standard was introduced - in fact, since FoxPro/DOS was introduced! KEYBOARD'ing a Shift-F1starts the process.
Forms now (in version 5.0) have a WhatsThisButton
property, which will automatically invoke Help with the HelpContextID of the
selected control. In order to have a working WhatsThisButton, the form must
have a border (BorderStyle not set to 0-None), both Max and MinButtons must be
off (set to .F.) and the WhatsThisHelp property set to .T.
Disk ComboBox
This class uses several Windows API calls to detect all legal drives, determine their type, and obtain their volume names. Appropriate bitmaps for each type of drive are displayed, using the Picture property
DEFINE CLASS cbodisk AS cbo && derivative of baseclass ComboBox
PROCEDURE Init
*** Declare API calls ***
* GetLogicalDrives() returns a bitmap of "legal" logical drives
DECLARE INTEGER GetLogicalDrives in win32api
* GetVolumeInformation() returns volume names, serial numbers, ;
file sytstems, and other stuff.
DECLARE short GetVolumeInformation IN Win32API ;
STRING lpRootPathName, ;
STRING lpVolumeNameBuffer, ;
INTEGER nVolumeNameSize, ;
STRING lpVolumeSerialNumber, ;
STRING lpMaximumComponentLength, ;
STRING lpFileSystemFlags, ;
STRING lpFileSystemNameBuffer, ;
INTEGER nFileSystemNameSize
* GetDriveType() returns numeric type of drive
DECLARE INTEGER GetDriveType IN WIN32API ;
< fo style='mso-tab-count:3'> STRING lpRootPathName && address of root path
* GetDriveType RETURN VALUES:
#DEFINE DRIVE_NONE 0 && The drive type cannot be determined.
#DEFINE DRIVE_BAD 1 && The root directory does not exist.
#DEFINE DRIVE_REMOVABLE 2 && The drive can be removed from the drive.
#DEFINE DRIVE_FIXED 3 && The disk cannot be removed from the drive.
#DEFINE DRIVE_REMOTE 4 && The drive is a remote (network) drive.
#DEFINE DRIVE_CDROM 5 && The drive is a CD-ROM drive.
#DEFINE DRIVE_RAMDISK 6 && The drive is a RAM disk.
*** Get bitmap of legal drives ***
nDrive = GetLogicalDrives()
*** Assign drive letters, icons, and volume names to List ***
for i = 0 to 25
if bittest(nDrive,i) && this is a logical drive
lcDrive = CHR(ASC("A")+i)+":\" && translate to letter
IF lcDrive > "B:\" && 13-Feb-96: skip floppy drives
* Obtain the Volume Name
STORE SPACE(255) TO lpRootPathName, ;
lpVolumeNameBuffer, ;
lpVolumeSerialNumber, ;
lpMaximumComponentLength, ;
lpFileSystemFlags, ;
lpFileSystemNameBuffer
STORE 255 TO nVolumeNameSize, ;
nFileSystemNameSize
= GetVolumeInformation(lcDrive, ;
@lpVolumeNameBuffer, ;
@nVolumeNameSize, ;
@lpVolumeSerialNumber, ;
@lpMaximumComponentLength, ;
@lpFileSystemFlags, ;
@lpFileSystemNameBuffer, ;
@nFileSystemNameSize )
* Trim string at terminating 00h
IF AT(CHR(0),lpVolumeNameBuffer) > 0
lpVolumeNameBuffer = LEFT(lpVolumeNameBuffer, ;
AT(CHR(0),lpVolumeNameBuffer)-1)
ELSE
lpVolumeNameBuffer = ""
New ENDIF
ELSE
lpVolumeNameBuffer = ""
ENDIF lcDrive > "B:\" && 13-Feb-96: skip floppy drives
* Get the disk drive type
IF lcDrive > "B:\" && 13-Feb-96: skip floppy drives
lnDriveType = GetDriveType(lcDrive)
ELSE
lnDriveType = DRIVE_REMOVABLE
ENDIF lcDrive > "B:\" && 13-Feb-96: skip floppy drives
* Add the volume name after the call to GetDriveType
lcDrive = lcDrive + lpVolumeNameBuffer
*** Assign bitmaps to list items ***
DO CASE
CASE lnDriveType = DRIVE_NONE
* do nothing
CASE lnDriveType = DRIVE_BAD
* do nothing
CASE lnDriveType = DRIVE_REMOVABLE
this.AddItem(lcDrive)
this.Picture[this.ListCount] = "FLOPPY.BMP"
CASE lnDriveType = DRIVE_FIXED
this.AddItem(lcDrive)
this.Picture[this.ListCount] = "HARDDISK.BMP"
CASE lnDriveType = DRIVE_REMOTE
this.AddItem(lcDrive)
this.Picture[this.ListCount] = "NETDISK.BMP"
CASE lnDriveType = DRIVE_CDROM
this.AddItem(lcDrive)
this.Picture(this.ListCount) = "CDROM.BMP"
CASE lnDriveType = DRIVE_RAMDISK
this.AddItem(lcDrive)
this.Picture[this.ListCount] = "RAMDISK.BMP"
ENDCASE
ENDIF
NEXT
this.value = this.List[1]
ENDPROC
ENDDEFINE
*
*-- EndDefine: cbodisk
**************************************************.
Dialogs
Combining the disk combo box above with a few list boxes and text boxes turned out to be more of a design challenge than a typical Foxpro developer would have anticipated. A discussion of dialog boxes with complex controls and interactions and the design patterns to solve them.
New Widgets
Visual FoxPro 5.0 ships with a slew of new ActiveX controls.
New 
New ActiveX Controls which ship with Visual FoxPro 5.0
Common Controls: The equivalent of many of the dialogs we have had for years - GETFILE(), GETPRINTER(), GETCOLOR() - but with finer and more detailed control of the dialogs.
Statusbar Control: allows the simple creation of a multiple-panel status bar, with text or graphics in each of the panels.
Slider Control: Similar to the slider above
Toolbar Control: create ActiveX toolbars
Rich Textbox Control: Finally! Rich text displayable within a FoxPro form!
SysInfo: A handy control for testing system settings and receiving alerts to system changes.