Tweet
Hey Guys,
I've been puzzled about something Bob wrote in one of the sticky's in the Objects forum. It was called "What is an Object anyway?"
Specifically this...
How on earth do you implement a dialog box inside an object? Well this is the best I could come up and hopefully some of you can also jump in here with ideas.
I've been puzzled about something Bob wrote in one of the sticky's in the Objects forum. It was called "What is an Object anyway?"
Specifically this...
For example, a string array containing names and addresses (data) might be packaged with a subroutine (code) that displays a popup dialog to edit the data, another subroutine (code) to print mailing labels, and so forth. That's a great candidate for an object.
Code:
#COMPILER PBWIN
#COMPILE EXE
#DIM ALL
#INCLUDE ONCE "Win32api.inc"
'==============================================================================
' Constants
'------------------------------------------------------------------------------
%IDC_CONTACTS = 1000
%IDC_NAME = 1001
%IDC_ADDRESS = 1002
%IDC_PHONE = 1003
%IDC_EMAIL = 1004
%IDC_INSERT = 1005
%IDC_UPDATE = 1006
%IDC_DELETE = 1007
%IDC_STATIC = -1
'==============================================================================
' Get contacts interface from dialog handle
'------------------------------------------------------------------------------
FUNCTION GetContacts(BYVAL hDlg AS LONG) AS IContacts
DIM Contacts AS IContacts
DIM dwPointer AS DWORD
DIALOG GET USER hDlg, 0 TO dwPointer
IF (dwPointer) THEN
POKE DWORD, VARPTR(Contacts), dwPointer
IF ISOBJECT(Contacts) THEN
Contacts.AddRef()
FUNCTION = Contacts
END IF
END IF
END FUNCTION
'==============================================================================
' Contacts Dialog Box Handler
'------------------------------------------------------------------------------
CALLBACK FUNCTION ContactsProc()
DIM Contacts AS IContacts
DIM dwObject AS DWORD
'Get contacts object interface
Contacts = GetContacts(CB.HNDL)
IF ISNOTHING(Contacts) THEN
IF (CB.MSG = %WM_COMMAND) THEN
IF (CB.CTL = %IDCANCEL) THEN
IF (CB.CTLMSG = %BN_CLICKED) THEN
DIALOG END CB.HNDL, 0
END IF
END IF
END IF
EXIT FUNCTION
END IF
'Process message
SELECT CASE AS LONG CBMSG
CASE %WM_INITDIALOG
FUNCTION = Contacts.OnInitDialog(CB.HNDL, CB.WPARAM, CB.LPARAM)
CASE %WM_DESTROY
FUNCTION = Contacts.OnDestroy(CB.WPARAM, CB.LPARAM)
CASE %WM_COMMAND
FUNCTION = Contacts.OnCommand(CB.WPARAM, CB.LPARAM)
END SELECT
END FUNCTION
'==============================================================================
' Contact Entry Class
'------------------------------------------------------------------------------
CLASS CEntry
INSTANCE m_szName AS STRING
INSTANCE m_szAddress AS STRING
INSTANCE m_szPhone AS STRING
INSTANCE m_szEmail AS STRING
INTERFACE IEntry
INHERIT IUNKNOWN
'----------------------------------------------------------------------
'Get name
'----------------------------------------------------------------------
PROPERTY GET NAME() AS STRING
PROPERTY = m_szName
END PROPERTY
'----------------------------------------------------------------------
'Set name
'----------------------------------------------------------------------
PROPERTY SET NAME(BYVAL szName AS STRING)
m_szName = szName
END PROPERTY
'----------------------------------------------------------------------
'Get Address
'----------------------------------------------------------------------
PROPERTY GET Address() AS STRING
PROPERTY = m_szAddress
END PROPERTY
'----------------------------------------------------------------------
'Set Address
'----------------------------------------------------------------------
PROPERTY SET Address(BYVAL szAddress AS STRING)
m_szAddress = szAddress
END PROPERTY
'----------------------------------------------------------------------
'Get Phone
'----------------------------------------------------------------------
PROPERTY GET Phone() AS STRING
PROPERTY = m_szPhone
END PROPERTY
'----------------------------------------------------------------------
'Set Phone
'----------------------------------------------------------------------
PROPERTY SET Phone(BYVAL szPhone AS STRING)
m_szPhone = szPhone
END PROPERTY
'----------------------------------------------------------------------
'Get Email
'----------------------------------------------------------------------
PROPERTY GET Email() AS STRING
PROPERTY = m_szEmail
END PROPERTY
'----------------------------------------------------------------------
'Set Email
'----------------------------------------------------------------------
PROPERTY SET Email(BYVAL szEmail AS STRING)
m_szEmail = szEmail
END PROPERTY
END INTERFACE
END CLASS
'==============================================================================
' Contacts Class
'------------------------------------------------------------------------------
CLASS CContacts
INSTANCE m_Entry() AS IEntry
INSTANCE m_hDlg AS LONG
'--------------------------------------------------------------------------
' Append entry to array
'--------------------------------------------------------------------------
CLASS METHOD APPEND(Entry AS IEntry) AS LONG
DIM lRow AS LONG
TRY 'Check entry object
IF ISNOTHING(Entry) THEN ERROR %ERR_OBJECTERROR
lRow = UBOUND(m_Entry)
INCR lRow
REDIM PRESERVE m_Entry(lRow)
m_Entry(lRow) = Entry
METHOD = %TRUE
CATCH
METHOD = %FALSE
END TRY
END METHOD
'--------------------------------------------------------------------------
' Remove entry from array
'--------------------------------------------------------------------------
CLASS METHOD Remove(BYVAL lRow AS LONG) AS LONG
DIM lMinRow AS LONG
DIM lMaxRow AS LONG
TRY 'Get array bounds
lMinRow = LBOUND(m_Entry)
lMaxRow = UBOUND(m_Entry)
'Check row against array bounds
IF (lRow < lMinRow) THEN ERROR %ERR_SUBSCRIPTPOINTEROUTOFRANGE
IF (lRow > lMaxRow) THEN ERROR %ERR_SUBSCRIPTPOINTEROUTOFRANGE
'Release object
m_Entry(lRow) = NOTHING
'Allocate dword array over object array and delete element
REDIM Index(lMinRow TO lMaxRow) AS DWORD AT VARPTR(m_Entry(lMinRow))
ARRAY DELETE Index(lRow)
'Reallocate object array
IF (lMinRow = lMaxRow) THEN
ERASE m_Entry()
ELSE
DECR lMaxRow
REDIM PRESERVE m_Entry(lMinRow TO lMaxRow)
END IF
'Success
METHOD = %TRUE
CATCH
METHOD = %FALSE
END TRY
END METHOD
INTERFACE IContacts
INHERIT IUNKNOWN
'----------------------------------------------------------------------
' Initialize contacts with some data
'----------------------------------------------------------------------
METHOD Initialize() AS LONG
DIM Entry AS IEntry
DIM lIndex AS LONG
'Read data into array
FOR lIndex = 1 TO DATACOUNT STEP 4
Entry = CLASS "CEntry"
IF ISOBJECT(Entry) THEN
Entry.Name = READ$(lIndex + 0)
Entry.Address = READ$(lIndex + 1)
Entry.Phone = READ$(lIndex + 2)
Entry.Email = READ$(lIndex + 3)
me.Append(Entry)
END IF
NEXT
'Contact data
DATA "Dasher", "North Pole", "(123) 456-7890", "[email protected]"
DATA "Dancer", "North Pole", "(123) 456-7890", "[email protected]"
DATA "Prancer", "North Pole", "(123) 456-7890", "[email protected]"
DATA "Vixen", "North Pole", "(123) 456-7890", "[email protected]"
DATA "Comet", "North Pole", "(123) 456-7890", "[email protected]"
DATA "Cupid", "North Pole", "(123) 456-7890", "[email protected]"
DATA "Donner", "North Pole", "(123) 456-7890", "[email protected]"
DATA "Blitzen", "North Pole", "(123) 456-7890", "[email protected]"
END METHOD
'----------------------------------------------------------------------
' Show dialog box
'----------------------------------------------------------------------
METHOD ShowDialog() AS LONG
DIM dwStyleEx AS DWORD
DIM dwStyle AS DWORD
DIM lResult AS LONG
'Setup listbox styles
dwStyle = %WS_CHILD OR %WS_VISIBLE OR %WS_TABSTOP OR %WS_VSCROLL OR %LBS_NOTIFY OR %LBS_NOINTEGRALHEIGHT
dwStyleEx = %WS_EX_CLIENTEDGE OR %WS_EX_LEFT OR %WS_EX_LTRREADING OR %WS_EX_RIGHTSCROLLBAR
'Create dialog box and add controls
DIALOG NEW 0, "Contacts", 70, 70, 201, 151, TO m_hDlg
CONTROL ADD LISTBOX, m_hDlg, %IDC_CONTACTS, , 5, 5, 190, 55, dwStyle, dwStyleEx
CONTROL ADD LABEL, m_hDlg, %IDC_STATIC, "Name:", 5, 65, 55, 10
CONTROL ADD LABEL, m_hDlg, %IDC_STATIC, "Address:", 5, 80, 55, 10
CONTROL ADD LABEL, m_hDlg, %IDC_STATIC, "Phone #:", 5, 95, 55, 10
CONTROL ADD LABEL, m_hDlg, %IDC_STATIC, "Email:", 5, 110, 55, 10
CONTROL ADD TEXTBOX, m_hDlg, %IDC_NAME, "", 65, 65, 130, 10
CONTROL ADD TEXTBOX, m_hDlg, %IDC_ADDRESS, "", 65, 80, 130, 10
CONTROL ADD TEXTBOX, m_hDlg, %IDC_PHONE, "", 65, 95, 130, 10
CONTROL ADD TEXTBOX, m_hDlg, %IDC_EMAIL, "", 65, 110, 130, 10
CONTROL ADD BUTTON, m_hDlg, %IDC_INSERT, "Insert", 5, 130, 45, 15
CONTROL ADD BUTTON, m_hDlg, %IDC_UPDATE, "Update", 55, 130, 45, 15
CONTROL ADD BUTTON, m_hDlg, %IDC_DELETE, "Delete", 105, 130, 45, 15
CONTROL ADD BUTTON, m_hDlg, %IDCANCEL, "Close", 155, 130, 40, 15
'Assign ME object pointer to dialog user data
DIALOG SET USER m_hDlg, 0, OBJPTR(ME)
'Show dialog box
DIALOG SHOW MODAL m_hDlg, CALL ContactsProc TO lResult
METHOD = lResult
END METHOD
'----------------------------------------------------------------------
' Refresh ListBox contents
'----------------------------------------------------------------------
METHOD ReloadListBox() AS LONG
DIM Entry AS IEntry
DIM lIndex AS LONG
DIM lRow AS LONG
'Check dialog handle
IF (m_hDlg = 0) THEN
METHOD = %FALSE
EXIT METHOD
END IF
'Save current selection and reset content
LISTBOX GET SELECT m_hDlg, %IDC_CONTACTS TO lIndex
LISTBOX RESET m_hDlg, %IDC_CONTACTS
'Add entry strings to listbox
FOR lRow = 0 TO UBOUND(m_Entry)
Entry = m_Entry(lRow)
IF ISOBJECT(Entry) THEN
LISTBOX ADD m_hDlg, %IDC_CONTACTS, Entry.Name & ", " & Entry.Address
LISTBOX SET USER m_hDlg, %IDC_CONTACTS, (lRow + 1), lRow
Entry = NOTHING
END IF
NEXT
'Restore selection
LISTBOX SELECT m_hDlg, %IDC_CONTACTS, MIN(lIndex, UBOUND(m_Entry) + 1)
END METHOD
'----------------------------------------------------------------------
' Reset name, address, phone and email controls
'----------------------------------------------------------------------
METHOD ResetControls() AS LONG
IF (m_hDlg) THEN
CONTROL SET TEXT m_hDlg, %IDC_NAME, ""
CONTROL SET TEXT m_hDlg, %IDC_ADDRESS, ""
CONTROL SET TEXT m_hDlg, %IDC_PHONE, ""
CONTROL SET TEXT m_hDlg, %IDC_EMAIL, ""
END IF
END METHOD
'----------------------------------------------------------------------
' Update dialog box controls
'----------------------------------------------------------------------
METHOD UpdateControls() AS LONG
DIM Entry AS IEntry
DIM lIndex AS LONG
DIM lRow AS LONG
'Check dialog handle
IF (m_hDlg = 0) THEN
METHOD = %FALSE
EXIT METHOD
END IF
'Get currently selected item index
LISTBOX GET SELECT m_hDlg, %IDC_CONTACTS TO lIndex
IF (lIndex = 0) THEN
CONTROL DISABLE m_hDlg, %IDC_UPDATE
CONTROL DISABLE m_hDlg, %IDC_DELETE
me.ResetControls()
ELSE
CONTROL ENABLE m_hDlg, %IDC_UPDATE
CONTROL ENABLE m_hDlg, %IDC_DELETE
LISTBOX GET USER m_hDlg, %IDC_CONTACTS, lIndex TO lRow
IF (lRow < LBOUND(m_Entry)) OR (lRow > UBOUND(m_Entry)) THEN
me.ResetControls()
METHOD = %FALSE
EXIT METHOD
END IF
Entry = m_Entry(lRow)
IF ISNOTHING(Entry) THEN
me.ResetControls()
METHOD = %FALSE
EXIT METHOD
END IF
CONTROL SET TEXT m_hDlg, %IDC_NAME, Entry.Name
CONTROL SET TEXT m_hDlg, %IDC_ADDRESS, Entry.Address
CONTROL SET TEXT m_hDlg, %IDC_PHONE, Entry.Phone
CONTROL SET TEXT m_hDlg, %IDC_EMAIL, Entry.Email
END IF
END METHOD
'----------------------------------------------------------------------
' Handle WM_INITDIALOG
'----------------------------------------------------------------------
METHOD OnInitDialog(BYVAL hDlg AS LONG, BYVAL wParam AS LONG, BYVAL lParam AS LONG) AS LONG
m_hDlg = hDlg
me.ReloadListBox()
me.UpdateControls()
METHOD = %TRUE
END METHOD
'----------------------------------------------------------------------
' Handle WM_DESTROY
'----------------------------------------------------------------------
METHOD OnDestroy(BYVAL wParam AS LONG, BYVAL lParam AS LONG) AS LONG
METHOD = %TRUE
END METHOD
'----------------------------------------------------------------------
' Handle WM_COMMAND
'----------------------------------------------------------------------
METHOD OnCommand(BYVAL wParam AS LONG, BYVAL lParam AS LONG) AS LONG
DIM wMessage AS WORD
DIM hListBox AS DWORD
DIM lRow AS LONG
DIM lIndex AS LONG
DIM Entry AS IEntry
DIM szName AS STRING
DIM szAddress AS STRING
DIM szPhone AS STRING
DIM szEmail AS STRING
'Extract control message
wMessage = HI(WORD, wParam)
SELECT CASE LO(WORD, wParam)
CASE %IDC_INSERT
IF (wMessage = %BN_CLICKED) THEN
Entry = CLASS "CEntry"
IF ISOBJECT(Entry) THEN
CONTROL GET TEXT m_hDlg, %IDC_NAME TO szName
CONTROL GET TEXT m_hDlg, %IDC_ADDRESS TO szAddress
CONTROL GET TEXT m_hDlg, %IDC_PHONE TO szPhone
CONTROL GET TEXT m_hDlg, %IDC_EMAIL TO szEmail
IF LEN(szName) THEN
Entry.Name = szName
Entry.Address = szAddress
Entry.Phone = szPhone
Entry.Email = szEmail
IF me.Append(Entry) THEN
me.ReloadListBox()
END IF
END IF
END IF
END IF
CASE %IDC_UPDATE
IF (wMessage = %BN_CLICKED) THEN
'Get currently selected row
LISTBOX GET SELECT m_hDlg, %IDC_CONTACTS TO lIndex
IF (lIndex = 0) THEN
me.UpdateControls()
EXIT METHOD
END IF
'Get index from item data
LISTBOX GET USER m_hDlg, %IDC_CONTACTS, lIndex TO lRow
'Check index against entry array bounds
IF (lRow < LBOUND(m_Entry)) THEN EXIT METHOD
IF (lRow > UBOUND(m_Entry)) THEN EXIT METHOD
'Get entry reference
Entry = m_Entry(lRow)
IF ISNOTHING(Entry) THEN
EXIT METHOD
END IF
'Update entry data
CONTROL GET TEXT m_hDlg, %IDC_NAME TO szName
CONTROL GET TEXT m_hDlg, %IDC_ADDRESS TO szAddress
CONTROL GET TEXT m_hDlg, %IDC_PHONE TO szPhone
CONTROL GET TEXT m_hDlg, %IDC_EMAIL TO szEmail
IF LEN(szName) THEN
Entry.Name = szName
Entry.Address = szAddress
Entry.Phone = szPhone
Entry.Email = szEmail
me.ReloadListBox()
me.UpdateControls()
END IF
END IF
CASE %IDC_DELETE
IF (wMessage = %BN_CLICKED) THEN
'Get currently selected row
LISTBOX GET SELECT m_hDlg, %IDC_CONTACTS TO lIndex
IF (lIndex = 0) THEN
me.UpdateControls()
EXIT METHOD
END IF
'Get index from item data
LISTBOX GET USER m_hDlg, %IDC_CONTACTS, lIndex TO lRow
'Check index against entry array bounds
IF (lRow < LBOUND(m_Entry)) THEN EXIT METHOD
IF (lRow > UBOUND(m_Entry)) THEN EXIT METHOD
me.Remove(lRow)
me.ReloadListBox()
me.UpdateControls()
END IF
CASE %IDC_CONTACTS
IF (wMessage = %LBN_SELCHANGE) THEN
me.UpdateControls()
END IF
CASE %IDCANCEL
IF (wMessage = %BN_CLICKED) THEN
DIALOG END m_hDlg, 0
END IF
END SELECT
END METHOD
END INTERFACE
END CLASS
'==============================================================================
' Application entry point
'------------------------------------------------------------------------------
FUNCTION PBMAIN() AS LONG
DIM Contacts AS IContacts
Contacts = CLASS "CContacts"
IF ISOBJECT(Contacts) THEN
Contacts.Initialize()
Contacts.ShowDialog()
END IF
END FUNCTION
Comment