Hello Charles
i tried to do subclassing a textbox, it can be compile without errors but it fail to run.
what would be the cause of this problem ? the code is as below
i have also attached its zip file
' Textbox_Subclass.O2bas
$ filename "TB_Subclass.exe"
uses rtl64
uses User
uses corewin
uses dialogs
'#lookahead
'Equates
% IDC_TEXTBOX1 = 1001
% IDC_LABEL1 = 1002
% GWLP_WNDPROC = -4
sys OldTextboxProc
sys hDlg
' define the code pointer
def codeptr @ %1
declare FUNCTION TextboxProc(hDlg, wMsg AS uint,_
wtParam AS sys, ltParam AS sys) AS sys
'=================================
sub winmain()
LOCAL hDlg AS DWORD
Dialog( 236, 174, 302, 344, "TextBox Subclass Example",
WS_OVERLAPPEDWINDOW or DS_SETFONT,
8, "MS Sans Serif" )
EDITTEXT("", IDC_TEXTBOX1, 8, 8, 217, 84 , &h50010000, _
ES_MULTILINE OR WS_VISIBLE OR WS_EX_CLIENTEDGE)
LText( " ", IDC_LABEL1, 8, 241, 217, 24)
CreateModalDialog( null, @DlgProc, 0)
END FUNCTION
'=================================
function DlgProc( sys hDlg, uint uMsg, sys wParam, lParam ) as int callback
select case uMsg
CASE WM_INITDIALOG
OldTextboxProc = SetWindowLongPtr(GetDlgItem(hDlg, IDC_TEXTBOX1),_
GWLP_WNDPROC, CODEPTR(TextboxProc))
CASE WM_DESTROY
SetWindowLongPtr GetDlgItem(hDlg, IDC_TEXTBOX1), GWLP_WNDPROC, OldTextboxProc
END SELECT
END FUNCTION
'======================================
' Subclass procedure for the Textbox to detect what
' ASCII values were key in
FUNCTION TextboxProc(hDlg, wMsg AS uint,_
wtParam AS sys, ltParam AS sys) AS sys
'
sys hLabText1=GetDlgItem(hDlg, IDC_LABEL1)
SELECT CASE wMsg
CASE WM_KEYDOWN
SetWindowText (hLabText1, "You have entered ASCII "+ str(wtParam))
END SELECT
FUNCTION = CallWindowProc(OldTextboxProc, hDlg, wMsg, wtParam, ltParam)
END FUNCTION
==============================================
'MAIN CODE start
winmain()
It was translated from PB
' Textbox Subclass.bas
'' An example to subclass the textbox and catch the WM_KEYDOWN,
' WM_KEYUP, or WM_CHAR messages for each key press. Then get the
' current value of the text box and then determine if this new key will
' cause an illegal value and act accordingly.
#COMPILE EXE
#DIM ALL
#INCLUDE "win32api.inc"
%IDC_TEXTBOX1 = 1001
%IDC_LABEL1 = 1002
GLOBAL OldTextboxProc AS DWORD
'=================================
FUNCTION PBMAIN () AS LONG
LOCAL hDlg AS DWORD
DIALOG NEW PIXELS, 0, "TextBox Subclass Example", _
236, 174, 302, 344, %WS_POPUP OR %WS_BORDER OR _
%WS_DLGFRAME OR %WS_SYSMENU OR %WS_CLIPSIBLINGS OR %WS_VISIBLE OR _
%DS_MODALFRAME OR %DS_3DLOOK OR %DS_NOFAILCREATE OR %DS_SETFONT,_
%WS_EX_CONTROLPARENT OR %WS_EX_LEFT OR %WS_EX_LTRREADING OR _
%WS_EX_RIGHTSCROLLBAR, TO hDlg
CONTROL ADD TEXTBOX, hDlg, %IDC_TEXTBOX1, "", 8, 8, 217, 84,_
%WS_VSCROLL OR %WS_HSCROLL OR %ES_MULTILINE OR %WS_VISIBLE OR _
%ES_WANTRETURN OR %ES_LEFT OR %WS_BORDER, %WS_EX_CLIENTEDGE
CONTROL ADD LABEL, hDlg, %IDC_LABEL1, "", 8, 241, 217, 24
DIALOG SHOW MODAL hDlg, CALL DlgProc
END FUNCTION
'=================================
CALLBACK FUNCTION DlgProc
SELECT CASE AS LONG CBMSG
CASE %WM_INITDIALOG
OldTextboxProc = SetWindowLong(GetDlgItem(CBHNDL, %IDC_TEXTBOX1),_
%GWL_WNDPROC, CODEPTR(TextboxProc))
CASE %WM_DESTROY
SetWindowLong GetDlgItem(CBHNDL, %IDC_TEXTBOX1), %GWL_WNDPROC, OldTextboxProc
END SELECT
END FUNCTION
'======================================
' Subclass procedure for the Textbox to detect what
' ASCII values were key in
FUNCTION TextboxProc(BYVAL hWnd AS LONG, BYVAL wMsg AS LONG,_
BYVAL wParam AS LONG, BYVAL lParam AS LONG) AS LONG
'
SELECT CASE wMsg
CASE %WM_KEYDOWN
CONTROL SET TEXT GetParent(hWnd), %IDC_LABEL1,_
"You have entered ASCII "+FORMAT$(wParam, "000")
END SELECT
FUNCTION = CallWindowProc(OldTextboxProc, hWnd, wMsg, wParam, lParam)
END FUNCTION
Hi Chris,
I have no experience with Subclassing or DDT. Can you do it in PB first, without the DDT.
The posted O2 code doesn't even compile. Apparently, CreateModalDialog has a fourth parameter.
Hello Jose
You need to include the latest Dialog.ini ( by Roland)
It is already in the zip file that i have attached in the first post
the below is the Dialog.ini
with this new Dialog.ini you should be able to compile
'library functions for creating dialogs at runtime in memory
'coded according to Win32 Help file
'
'based on
'dialogs.bas in:
'https://www.freebasic.net/forum/viewtopic.php?t=5667
'dialogs.inc in:
'MASM32 SDK
uses corewin
uses generics
#ifdef review
uses console
#endif
'some classes for using InitCommonControlsEx
% WC_HEADER="SysHeader32"
% TOOLBARCLASSNAME="ToolbarWindow32"
% STATUSCLASSNAME="msctls_statusbar32"
% TRACKBAR_CLASS="msctls_trackbar32"
% UPDOWN_CLASS="msctls_updown32"
% PROGRESS_CLASS="msctls_progress32"
% WC_LISTVIEW="SysListView32"
% WC_TREEVIEW="SysTreeView32"
% WC_TABCONTROL="SysTabControl32"
% ANIMATE_CLASS="SysAnimate32"
% RICHEDIT_CLASS10A="RICHEDIT"
% RICHEDIT_CLASS="RichEdit20A"
% MSFTEDIT_CLASS="RichEdit50W"
% MONTHCAL_CLASS="SysMonthCal32"
% DATETIMEPICK_CLASS="SysDateTimePick32"
% WC_IPADDRESS="SysIPAddress32"
% HOTKEY_CLASS="msctls_hotkey32"
% REBARCLASSNAME="ReBarWindow32"
% WC_PAGESCROLLER="SysPager"
% WC_NATIVEFONTCTL="NativeFontCtl"
% WC_COMMCTRL_DRAGLISTMSG="commctrl_DragListMsg"
% WC_COMBOBOXEX="ComboBoxEx32"
% TOOLTIPS_CLASS="tooltips_class32"
'==============================================================================
'Items needed to run dialogs.inc
% DS_SETFONT=0x40
% SS_LEFT=0
% SS_CENTER=1
% SS_RIGHT=2
% SS_ICON=3
% SS_BITMAP=0x0E
% SS_NOTIFY=0x0100
% CBS_SIMPLE=1
% CBS_DROPDOWN=2
% CBS_DROPDOWNLIST=3
% CBS_SORT=0x0100
% CBS_HASSTRINGS=0x0200
% ES_SAVESEL=0x8000
'some often used constants
% DS_CENTER=0x0800
% LR_LOADFROMFILE=0x0010
% IMAGE_BITMAP=0
% IMAGE_ICON=1
% ICON_SMALL=0
% ICON_BIG=1
% WM_SETICON=0x80
% STM_SETIMAGE=0x172
% SWP_NOMOVE=2
% SWP_NOREDRAW=8
% COLOR_WINDOW=5
% SM_CXBORDER=5
% SM_CYBORDER=6
% SWP_NOZORDER=4
% HWND_TOPMOST= -1
% HORZRES=8
% VERTRES=10
% ODS_SELECTED=1
% WM_DRAWITEM=0x2B
% SRCCOPY=0xCC0020
% SB_SETTEXT=0x401
% SB_SETPARTS=0x404
'MultiByteToWideChar
% CP_ACP=0
% MB_PRECOMPOSED=1
'WinApi types
packed type DLGTEMPLATE 'template for dialog box
dword style
dword dwExtendedStyle
word cdit 'number of items
short x 'in dialog box units
short y
short cx 'width
short cy 'height
end type
'immediately followed by some data
packed type DLGITEMTEMPLATE 'template for a control in a dialog box
dword style
dword dwExtendedStyle
short x 'in dialog box units
short y
short cx 'width
short cy 'height
word id 'control identifier
end type
'immediately followed by some data
'needed for menus
% GRAYED=MF_GRAYED
% CHECKED=MF_CHECKED
% OWNERDRAW=MF_OWNERDRAW
string tab=chr(9)
'needed for accelerators
% FVIRTKEY=1 'TRUE
% FNOINVERT=0x02
% FSHIFT=0x04
% FCONTROL=0x08
% FALT=0x10
type ACCEL
byte fVirt
word key
word cmd
end type
'====================================================================
sys g_memptr 'points to an address in memory
int g_dialog_width 'for centering a control in a dialog.
int g_Ccount 'controls actually created
sys g_lpdtptr 'pointer to initial DLGTEMPLATE struc
'====================================================================
'macros
macro align_2(v) {v+=1 : v = v and -2}
macro align_4(v) {v+=3 : v = v and -4}
macro make_ustring(text,memptr, count)
int count = MultiByteToWideChar( CP_ACP, MB_PRECOMPOSED,
text,
-1,
memptr,
len(text)+1 )
memptr += count*2
end macro
macro set_val(i,v) {i=v : g_memptr+=sizeof(i)}
'====================================================================
' Create a modal dialog from the dialog box template pointed to by lpdt.
' hParent should be null if the dialog is the main window of the application.
'
' DialogBoxIndirectParam function does not return until EndDialog.
' rval returns whatever was specified as result of EndDialog.
'
function CreateModalDialog( sys hParent, sys *lpDialogProc, dwInitParam, optional lpdt=g_lpdtptr) as sys
sys rval
rval = DialogBoxIndirectParam( GetModuleHandle(null),
lpdt,
hParent,
@lpDialogProc,
dwInitParam )
if rval=-1 then
mbox "Creating modal Dialog failed. Stop!"
#ifdef review
printl "Error: rval = " rval
printl "Enter to end ... ": waitkey
#endif
ExitProcess(0)
end if
freememory lpdt
return rval
end function
'====================================================================
' Create a modeless dialog from the dialog box template pointed to by lpdt.
' hParent should be null if the dialog is the main window of the application.
'
' CreateDialogIndirectParam function will use DestroyWindow to return
' rval normally returns the handle to the dialog window.
'
' WS_VISIBLE style is required for a modeless dialog to be visible.
'
function CreateModelessDialog( sys hParent, sys *lpDialogProc, lParamInit, optional lpdt=g_lpdtptr) as sys
sys rval
rval = CreateDialogIndirectParam( GetModuleHandle(null),
lpdt,
hParent,
@lpDialogProc,
lParamInit )
if rval=0 then
mbox "Cannot create modeless Dialog. Stop!"
#ifdef review
printl "Error: rval = " rval
printl "Enter to end ... ": waitkey
#endif
ExitProcess(0)
end if
freememory lpdt
return rval
end function
'====================================================================
' Initialize the essential members of the DLGTEMPLATE structure,
' the menu, class, and title arrays, and optionally the font
' point size and typeface array. Returns a pointer to the next
' WORD following the title or typeface array in g_memptr, and a
' pointer to the allocated memory in lpdt.
'
' Parameter cdit must match the number of controls defined.
' If the value is too high then the function that creates the
' dialog will fail. If the value is too low then one or more
' of the controls will not be created.
'
'
sub Dialog( short x,y,cx,cy, string title, dword style,
optional short pointSize=0, string typeFace="", dword extStyle=0)
#ifdef review
printl "sub Dialog: try to create Dialog template structure"
#endif
if g_lpdtptr then freememory g_lpdtptr
g_lpdtptr=getmemory 20480 '1024*20
word cdit at g_lpdtptr+sizeof(dword)*2 'lpdt.cdit
cdit = 0
g_dialog_width = cx
DLGTEMPLATE lpdt at g_lpdtptr
lpdt.style = style
lpdt.dwExtendedStyle = extStyle
lpdt.cdit = cdit
lpdt.x = x
lpdt.y = y
lpdt.cx = cx
lpdt.cy = cy
' Set g_memptr to the menu array that follows the structure.
g_memptr = g_lpdtptr + sizeof(lpdt)
word menu_ at g_memptr : set_val(menu_, 0)
word class_ at g_memptr : set_val(class_, 0)
'title array and set g_memptr to next WORD following the title array.
make_ustring( title, g_memptr )
'if DS_SETFONT then point size and typeface
if style and DS_SETFONT then
word pointsize_ at g_memptr : set_val(pointsize_, pointSize)
make_ustring( typeFace, g_memptr )
end if
g_Ccount=0
end sub
'====================================================================
' General-purpose control definition starting at g_memptr, initializes
' the essential members of a DLGITEMTEMPLATE structure and
' the class, caption and creation data arrays.
'
' For the class array - six predefined system (User32) classes -
' use "BUTTON", "EDIT", "STATIC", "LISTBOX", "SCROLLBAR", and "COMBOBOX".
' For common controls use the class strings defined for comctl32.dll.
'
' Caption array can specify the caption or initial text for the control,
' or the ordinal value of a resource in the executable file.
' Specify a caption or initial text in the caption parameter,
' or an ordinal value in the rid (ResourceID) parameter. If the
' rid parameter is non-zero then the caption parameter is ignored.
'
' There is no support for creation data.
'
' The tab order of the controls in a dialog is determined by the order in which
' the controls are created and which controls have the WS_TABSTOP style.
'
' To center the control in the dialog horizontally specify -1 for the x parameter.
' This feature will not work correctly for an auto-sized control.
'
sub control( string caption, word cid, string _class, dword style=0, short x,y,cx,cy,
optional extStyle = 0, short rid=0 )
if x = -1 then x = (g_dialog_width - cx) / 2
'--------------------------------------------------------------
'must be dword boundary
'--------------------------------------------------------------
align_4(g_memptr)
'initialize the essential members of the structure.
'establish the base style as WS_CHILD or WS_VISIBLE.
DLGITEMTEMPLATE lpdit at g_memptr
lpdit.style = WS_CHILD or WS_VISIBLE or style
lpdit.dwExtendedStyle = extStyle
lpdit.x = x
lpdit.y = y
lpdit.cx = cx
lpdit.cy = cy
lpdit.id = cid
'set g_memptr to the class array that follows the structure.
g_memptr += sizeof(lpdit)
'initialize the class array and set g_memptr to the next WORD
make_ustring( _class, g_memptr )
'initialize the caption array and set g_memptr to the next WORD
if rid then
word class_ at g_memptr : set_val(class_, 0xffff)
word rid_ at g_memptr : set_val(rid_, rid)
else
make_ustring( caption, g_memptr )
end if
'skip the first element of the creation data, set it to zero (no creation data).
align_2(g_memptr)
word create_data at g_memptr : set_val(create_data, 0)
g_Ccount+=1
#ifdef review
printl "Controls created: " g_Ccount
#endif
word cdit at g_lpdtptr+sizeof(dword)*2 'lpdt.cdit
cdit=g_Ccount
end sub
'====================================================================
' The following specialized control definition procedures are
' simply wrappers for the general-purpose procedure.
'====================================================================
'PUSHBUTTON, PUSHBOX, DEFPUSHBUTTON, CHECKBOX, AUTOCHECKBOX, AUTO3STATE, STATE3, RADIOBUTTON, AUTORADIOBUTTON, GROUPBOX
sub PUSHBUTTON( string caption, word cid, short x,y,cx,cy, optional dword style=0, extStyle=0, rid=0 )
Control( caption, cid, "BUTTON", BS_PUSHBUTTON or WS_TABSTOP or style, x,y,cx,cy, extStyle, rid )
end sub
sub PUSHBOX( string caption, word cid, short x,y,cx,cy, optional dword style=0, extStyle=0, rid=0 )
Control( caption, cid, "BUTTON", BS_PUSHBOX or WS_TABSTOP or style, x,y,cx,cy, extStyle, rid )
end sub
sub DEFPUSHBUTTON( string caption, word cid, short x,y,cx,cy, optional dword style=0, extStyle=0, rid=0 )
Control( caption, cid, "BUTTON", BS_DEFPUSHBUTTON or WS_TABSTOP or style, x,y,cx,cy, extStyle, rid )
end sub
sub CHECKBOX( string caption, word cid, short x,y,cx,cy, optional dword style=0, extStyle=0, rid=0 )
Control( caption, cid, "BUTTON", BS_CHECKBOX or WS_TABSTOP or BS_NOTIFY or style, x,y,cx,cy, extStyle, rid )
end sub
sub AUTOCHECKBOX( string caption, word cid, short x,y,cx,cy, optional dword style=0, extStyle=0, rid=0 )
Control( caption, cid, "BUTTON", BS_AUTOCHECKBOX or WS_TABSTOP or BS_NOTIFY or style, x,y,cx,cy, extStyle, rid )
end sub
sub AUTO3STATE( string caption, word cid, short x,y,cx,cy, optional dword style=0, extStyle=0, rid=0 )
Control( caption, cid, "BUTTON", BS_AUTO3STATE or WS_TABSTOP or BS_NOTIFY or style, x,y,cx,cy, extStyle, rid )
end sub
sub STATE3( string caption, word cid, short x,y,cx,cy, optional dword style=0, extStyle=0, rid=0 )
Control( caption, cid, "BUTTON", BS_3STATE or WS_TABSTOP or BS_NOTIFY or style, x,y,cx,cy, extStyle, rid )
end sub
sub RADIOBUTTON( string caption, word cid, short x,y,cx,cy, optional dword style=0, extStyle=0, rid=0 )
Control( caption, cid, "BUTTON", BS_AUTORADIOBUTTON or WS_TABSTOP or BS_NOTIFY or style, x,y,cx,cy, extStyle, rid )
end sub
sub AUTORADIOBUTTON( string caption, word cid, short x,y,cx,cy, optional dword style=0, extStyle=0, rid=0 )
Control( caption, cid, "BUTTON", BS_AUTORADIOBUTTON or WS_TABSTOP or BS_NOTIFY or style, x,y,cx,cy, extStyle, rid )
end sub
sub GROUPBOX( string caption, word cid, short x,y,cx,cy, optional dword style=0, extStyle=0, rid=0 )
Control( caption, cid, "BUTTON", BS_GROUPBOX or WS_TABSTOP or style, x,y,cx,cy, extStyle, rid )
end sub
'====================================================================
'EDITTEXT, MultiLineText
sub EDITTEXT( string caption, word cid, short x,y,cx,cy, optional dword style=0, extStyle=0, rid=0 )
Control( caption, cid, "EDIT", ES_LEFT or WS_BORDER or WS_TABSTOP or ES_AUTOHSCROLL or style, x,y,cx,cy,
WS_EX_CLIENTEDGE or WS_EX_ACCEPTFILES or extStyle, rid )
end sub
sub MultiLineText( string caption, word cid, short x,y,cx,cy, optional dword style=0, extStyle=0, rid=0 )
Control( caption, cid, "EDIT", ES_LEFT|WS_BORDER|WS_TABSTOP|WS_GROUP|WS_VSCROLL|WS_HSCROLL|ES_MULTILINE|ES_AUTOVSCROLL|ES_AUTOHSCROLL|ES_WANTRETURN|style,x,y,cx,cy,
WS_EX_CLIENTEDGE or WS_EX_ACCEPTFILES or extStyle, rid )
end sub
'====================================================================
'LTEXT, RTEXT, CTEXT, ICON, Bitmap
sub LTEXT( string caption, word cid, short x,y,cx,cy, optional dword style=0, extStyle=0, rid=0 )
Control( caption, cid, "STATIC", SS_LEFT or SS_NOTIFY or style, x,y,cx,cy, extStyle, rid )
end sub
sub RTEXT( string caption, word cid, short x,y,cx,cy, optional dword style=0, extStyle=0, rid=0 )
Control( caption, cid, "STATIC", SS_RIGHT or SS_NOTIFY or style, x,y,cx,cy, extStyle, rid )
end sub
sub CTEXT( string caption, word cid, short x,y,cx,cy, optional dword style=0, extStyle=0, rid=0 )
Control( caption, cid, "STATIC", SS_CENTER or SS_NOTIFY or style, x,y,cx,cy, extStyle, rid )
end sub
sub ICON( string caption, word cid, optional short x=0,y=0,cx=0,cy=0, dword style=0, extStyle=0, rid=0 )
Control( caption, cid, "STATIC", SS_ICON or SS_NOTIFY or style, x,y,cx,cy, extStyle, rid )
end sub
sub Bitmap( string caption, word cid, optional short x=0,y=0,cx=0,cy=0, dword style=0, extStyle=0, rid=0 )
Control( caption, cid, "STATIC", SS_BITMAP or SS_NOTIFY or style, x,y,cx,cy, extStyle, rid )
end sub
'====================================================================
'LISTBOX
sub LISTBOX( string caption, word cid, short x,y,cx,cy, optional dword style=0, extStyle=0, rid=0 )
Control( "", cid, "LISTBOX", WS_VSCROLL or WS_BORDER or WS_TABSTOP or LBS_NOTIFY or style, x,y,cx,cy,
WS_EX_CLIENTEDGE or WS_EX_ACCEPTFILES or extStyle, 0 )
end sub
'====================================================================
'SimpleCombo, SortedCombo, COMBOBOX, DropDownList
sub SimpleCombo( string caption,word cid, short x,y,cx,cy, optional dword style=0, extStyle=0, rid=0 )
Control( "", cid, "COMBOBOX", WS_VSCROLL or CBS_DROPDOWN or CBS_HASSTRINGS or WS_TABSTOP or style, x,y,cx,cy,
WS_EX_CLIENTEDGE or WS_EX_ACCEPTFILES or extStyle, 0 )
end sub
sub SortedCombo( string caption, word cid, short x,y,cx,cy, optional dword style=0, extStyle=0, rid=0 )
Control( "", cid, "COMBOBOX", WS_VSCROLL or CBS_DROPDOWN or CBS_HASSTRINGS or CBS_SORT or WS_TABSTOP or style, x,y,cx,cy,
WS_EX_CLIENTEDGE or WS_EX_ACCEPTFILES or extStyle, 0 )
end sub
sub COMBOBOX(string caption, word cid, short x,y,cx,cy, optional dword style=0, extStyle=0, rid=0 )
Control( "", cid, "COMBOBOX", CBS_SIMPLE or WS_TABSTOP or style, x,y,cx,cy, extStyle, rid )
end sub
sub DropDownList( string caption, word cid, short x,y,cx,cy, optional dword style=0, extStyle=0, rid=0 )
Control( "", cid, "COMBOBOX", WS_VSCROLL or CBS_DROPDOWNLIST or CBS_HASSTRINGS or WS_TABSTOP or style, x,y,cx,cy,
WS_EX_CLIENTEDGE or WS_EX_ACCEPTFILES or extStyle, 0 )
end sub
'====================================================================
'SCROLLBAR, VScrollBar
sub SCROLLBAR( string caption, word cid, short x,y,cx,cy, optional dword style=0, extStyle=0, rid=0 )
Control( "", cid, "SCROLLBAR", SBS_HORZ or WS_TABSTOP or style, x,y,cx,cy, extStyle, 0 )
end sub
sub VScrollBar( string caption, word cid, short x,y,cx,cy, optional dword style=0, extStyle=0, rid=0 )
Control( "", cid, "SCROLLBAR", SBS_VERT or WS_TABSTOP or style, x,y,cx,cy, extStyle, 0 )
end sub
'====================================================================
' To use a Rich Edit control your app must first call LoadLibrary to load the appropriate DLL
' RICHED32.DLL for version 1.
' RICHED20.DLL for version 2 or 3,
' MSFTEDIT.DLL for version 4.1
'====================================================================
' This procedure is coded for version 1.
sub RichEdit1( string caption, word cid, short x,y,cx,cy, optional dword style=0, extStyle=0, rid=0 )
Control( caption, cid, RICHEDIT_CLASS10A, WS_TABSTOP or WS_VSCROLL or ES_AUTOVSCROLL or ES_SAVESEL or ES_MULTILINE or WS_BORDER or ES_WANTRETURN or style, x,y,cx,cy,
WS_EX_CLIENTEDGE or WS_EX_ACCEPTFILES or extStyle, rid )
end sub
' This procedure is coded for version 2 or 3.
sub RichEdit( string caption, word cid, short x,y,cx,cy, optional dword style=0, extStyle=0, rid=0 )
Control( caption, cid, RICHEDIT_CLASS, WS_TABSTOP or WS_VSCROLL or ES_AUTOVSCROLL or ES_SAVESEL or ES_MULTILINE or WS_BORDER or ES_WANTRETURN or style, x,y,cx,cy,
WS_EX_CLIENTEDGE or WS_EX_ACCEPTFILES or extStyle, rid )
end sub
' This procedure is coded for version 4.1.
sub MsftEdit( string caption, word cid, short x,y,cx,cy, optional dword style=0, extStyle=0, rid=0 )
Control( caption, cid, MSFTEDIT_CLASS, WS_TABSTOP or WS_VSCROLL or ES_AUTOVSCROLL or ES_SAVESEL or ES_MULTILINE or WS_BORDER or ES_WANTRETURN or style, x,y,cx,cy,
WS_EX_CLIENTEDGE or WS_EX_ACCEPTFILES or extStyle, rid )
end sub
'====================================================================
sub init_common_controls(optional dword classes=0)
' create a structure of INITCOMMONCONTROLSEX
INITCOMMONCONTROLSEXt iccex
iccex.dwSize=sizeof(iccex)
'Register Common Controls
if classes!=0 then
'set own value
iccex.dwICC=classes
else
'use default
iccex.dwICC= 0xffff
/*
0x0001 or ' ICC_LISTVIEW_CLASSES - list view and header control classes.
0x0002 or ' ICC_TREEVIEW_CLASSES - tree view and tooltip control classes.
0x0004 or ' ICC_BAR_CLASSES - toolbar, status bar, trackbar, and tooltip control classes.
0x0008 or ' ICC_TAB_CLASSES - tab and tooltip control classes.
0x0010 or ' ICC_UPDOWN_CLASS - up-down control class.
0x0020 or ' ICC_PROGRESS_CLASS - progress bar control class.
0x0040 or ' ICC_HOTKEY_CLASS - hot key control class.
0x0080 or ' ICC_ANIMATE_CLASS - animate control class.
0x00ff or ' ICC_WIN95_CLASSES - animate control, header, hot key,
' list view, progress bar, status bar, tab,
' tooltip, toolbar, trackbar, tree view,
' and up-down control classes.
0x0100 or ' ICC_DATE_CLASSES - date and time picker control class.
0x0200 or ' ICC_USEREX_CLASSES - ComboBoxEx class.
0x0400 or ' ICC_COOL_CLASSES - rebar control class.
0x0800 or ' ICC_INTERNET_CLASSES - IP address class.
0x1000 or ' ICC_PAGESCROLLER_CLASS - pager control class.
0x2000 or ' ICC_NATIVEFNTCTL_CLASS - native font control class
0x4000 or ' ICC_STANDARD_CLASSES - one of the intrinsic User32 control classes.
' The user controls include button, edit, static,
' listbox, combobox, and scroll bar.
0x8000 ' ICC_LINK_CLASS - hyperlink control class.
*/
end if
InitCommonControlsEx(@iccex)
end sub
'==============================================================================
'Menus, PopupMenus
int g_MnuLv[10] 'Main Menu or PopupMenu and 9 levels of SubMenus
int g_Midx 'Menu index
macro MENU(hMenu)
hMenu=CreateMenu
g_Midx=1
g_MnuLv[1]=hMenu
end macro
'Vertical Main Popup Menu
macro PopupMENU(hMenu)
hMenu=CreatePopupMenu
g_Midx=1
g_MnuLv[1]=hMenu
end macro
sub BEGIN(optional int none=0)
end sub
sub POPUP(string item)
sys hSubM=CreateMenu
g_Midx+=1 : g_MnuLv[g_Midx]=hSubM
AppendMenu( g_MnuLv[g_Midx-1], MF_POPUP, g_MnuLv[g_Midx], item )
end sub
sub MENUITEM(string item, optional sys id=0, uint uflags=MF_STRING)
if lcase(item) = "separator" then
AppendMenu(g_MnuLv[g_Midx], MF_SEPARATOR, 0, 0)
else
AppendMenu(g_MnuLv[g_Midx], uflags, id, item )
end if
end sub
sub ENDMenu(optional int=0)
g_Midx-=1
end sub
'==============================================================================
It compiles but it doesn't run in my computer.
BTW it's hard to test anything that comes with O2. You try to run an example that uses WinUtil.inc and you get sFile not defined.
function GetDropFiles(sys hDropParam) As string
===============================================
string sDropFiles, sFiles
sys i,e,le
e=DragQueryFile(hDropParam, -1, null, 0)-1
'
for i = 0 To e
le=DragQueryFile(hDropParam, i, null, 1)
sfile=space le
DragQueryFile(hDropParam, i, StrPtr sFile, le+1)
If Ucase(mid(sFile, -4)) = ".LNK"
else
sDropFiles+= sFile + chr(13,10)
end if
next i
return sDropFiles
end function
Then you define sFile as string, and you get another error in co=wparam >>16 because co is not defined. Looks like they have been tested with #autodim on.
I find no problems with the drag-and-drop example. I went through all the examples after o2 was changed to #autodim off (10 May 2018), and resolved nearly all of them.
If there is a simple sub-classing example in PB available, we could port it to o2 as a standard WinGui example.
Hello all
i was able to compile the DragAndDrop.o2bas with no problem and the compile file works
maybe you would need to download the latest build of OxygenBasicProgress.zip ?
Hello all
here is the subclass textbox in windows SDK style in PB
' Multi Line Textbox Noicon.bas
' SDK Windows with subclass Textbox
#COMPILE EXE
#DIM ALL
#INCLUDE "Win32Api.inc"
%Edit01 = 101
%Button = 201
GLOBAL ghInstance AS DWORD
GLOBAL pEditProc AS DWORD
'==================================
' Subclass textbox
FUNCTION EditSubclassProc(BYVAL hwnd AS DWORD, BYVAL wMsg AS DWORD, _
BYVAL wParam AS DWORD, BYVAL lParam AS LONG) AS LONG
SELECT CASE AS LONG wMsg
CASE %WM_CHAR
IF wParam = %VK_Tab THEN
IF (GetAsyncKeyState(%VK_SHIFT) AND &H8000) THEN
SetFocus(GetNextDlgTabItem(GetParent(hwnd), GetFocus(), %TRUE)) 'Previous
ELSE
SetFocus(GetNextDlgTabItem(GetParent(hwnd), GetFocus(), %FALSE)) 'Next
END IF
FUNCTION = %FALSE
EXIT FUNCTION
END IF
CASE %WM_DESTROY
SetWindowLong(hWnd, %GWL_WNDPROC, pEditProc)
END SELECT
FUNCTION = CallWindowProc(pEditProc, hwnd, wMsg, WParam, LParam)
END FUNCTION
'===============================
' callback procedure
FUNCTION MainProc(BYVAL hWnd AS DWORD, BYVAL uMsg AS DWORD, _
BYVAL wParam AS DWORD, BYVAL lParam AS LONG) AS LONG
DIM SelStart(0 TO 1) AS STATIC LONG
DIM SelEnd(0 TO 1) AS STATIC LONG
STATIC hEdit01 AS DWORD
STATIC hButton AS DWORD
STATIC hFont AS DWORD
STATIC hFocusBak AS DWORD
SELECT CASE uMsg
CASE %WM_CREATE
hFont = CreateFont(16, 0, 0, 0, 0, 0, 0, 0, 0, 4, 0, 0, 0, "Segoe UI") 'Segoe UI, 9
hEdit01 = CreateWindowEx(%WS_EX_CLIENTEDGE, _ 'Extended styles
"Edit", _ 'Class name
"Edit 01, focus when TAB or SHIFT-TAB is used.", _ 'Caption
%WS_CHILD OR %WS_VISIBLE OR %WS_TABSTOP OR _ 'Window styles
%ES_LEFT OR %ES_AUTOHSCROLL OR %ES_WANTRETURN OR _ 'Class styles
%ES_NOHIDESEL OR %ES_MULTILINE, _ 'Class styles
55, 50, _ 'Left, top
235, 100, _ 'Width, height
hWnd, %Edit01, _ 'Handle of parent, control ID
ghInstance, BYVAL %NULL) 'Handle of instance, creation parameters
SendMessage(hEdit01, %WM_SETFONT, hFont, %TRUE)
pEditProc = SetWindowLong(hEdit01, %GWL_WNDPROC, CODEPTR(EditSubclassProc)) 'Subclass the control
hButton = CreateWindowEx(%NULL, _ 'Extended styles
"Button", _ 'Class name
"&Button", _ 'Caption
%WS_CHILD OR %WS_VISIBLE OR %WS_TABSTOP OR _ 'Window styles
%BS_PUSHBUTTON OR %BS_CENTER OR %BS_VCENTER, _ 'Class styles
130, 295, _ 'Left, top
100, 35, _ 'Width, height
hWnd, %Button, _ 'Handle of parent, control ID
ghInstance, BYVAL %NULL) 'Handle of instance, creation parameters
SendMessage(hButton, %WM_SETFONT, hFont, %TRUE)
SetFocus(hEdit01)
EXIT FUNCTION
CASE %WM_COMMAND
SELECT CASE LOWRD(wParam)
CASE %Edit01
IF HIWRD(wParam) = %EN_KILLFOCUS THEN
SendMessage(LPARAM, %EM_GETSEL, VARPTR(SelStart(0)), VARPTR(SelEnd(0)))
END IF
IF HIWRD(wParam) = %EN_SETFOCUS THEN
SendMessage(LPARAM, %EM_SETSEL, SelStart(0), SelEnd(0))
END IF
CASE %Button, %IDOK
IF (HIWRD(wParam) = %BN_CLICKED) OR (HI(WORD, wParam) = 1) THEN
WinBeep(1500, 100) : WinBeep(1500, 100)
END IF
CASE %IDCANCEL
IF (HIWRD(wParam) = %BN_CLICKED) OR (HI(WORD, wParam) = 1) THEN
SendMessage(hWnd, %WM_CLOSE, 0, 0)
END IF
END SELECT
CASE %WM_SETFOCUS
IF hFocusBak THEN
SetFocus(hFocusBak)
END IF
CASE %WM_NCACTIVATE
IF wParam = %WA_INACTIVE THEN
hFocusBak = GetFocus()
END IF
CASE %WM_SIZE
IF wParam <> %SIZE_MINIMIZED THEN
MoveWindow(hEdit01, 20, 20, LO(WORD, lParam) - 40, HI(WORD, lParam) / 2 - 50, %TRUE)
MoveWindow(hButton, (LO(WORD, lParam) - 100) / 2, HI(WORD, lParam) - 47, 100, 35, %TRUE)
END IF
CASE %WM_DESTROY
DeleteObject(hFont)
PostQuitMessage(0)
EXIT FUNCTION
END SELECT
FUNCTION = DefWindowProc(hWnd, uMsg, wParam, lParam)
END FUNCTION
'=================================
FUNCTION WINMAIN(BYVAL hInstance AS DWORD, BYVAL hPrevInstance AS DWORD, _
BYVAL pszCmdLine AS ASCIIZ POINTER, BYVAL nCmdShow AS LONG) AS LONG
LOCAL zClassName AS ASCIIZ * %MAX_PATH 'Class name
LOCAL WinClass AS WNDCLASSEX 'Class information
LOCAL TagMessage AS TAGMSG 'Message information
LOCAL hWnd AS DWORD 'Handle of main window
ghInstance = hInstance
'Register the Form1 window
zClassName = "Form1_Class"
WinClass.cbSize = SIZEOF(WinClass) 'Size of WNDCLASSEX structure
WinClass.style = %CS_DBLCLKS 'Class styles
WinClass.lpfnWndProc = CODEPTR(MainProc) 'Address of window procedure used by class
WinClass.cbClsExtra = 0 'Extra class bytes
WinClass.cbWndExtra = 0 'Extra window bytes
WinClass.hInstance = ghInstance 'Instance of the process that is registering the window
WinClass.hCursor = LoadCursor(%NULL, BYVAL %IDC_ARROW) 'Handle of class cursor
WinClass.hbrBackground = %COLOR_BTNFACE + 1 'Brush used to fill background of window's client area
WinClass.lpszMenuName = %NULL 'Resource identifier of the class menu
WinClass.lpszClassName = VARPTR(zClassName) 'Class name
IF RegisterClassEx(WinClass) THEN
'Create the Form1 window
hWnd = CreateWindowEx(%WS_EX_WINDOWEDGE, _ 'Extended styles
"Form1_Class", _ 'Class name
"Focus on dual multi line edit", _ 'Caption
%WS_OVERLAPPEDWINDOW OR %WS_VISIBLE, _ 'Window styles
(GetSystemMetrics(%SM_CXSCREEN) - 480) / 2, _ 'Left
(GetSystemMetrics(%SM_CYSCREEN) - 450) / 2, _ 'Top
480, 450, _ 'Width, height
%HWND_DESKTOP, %NULL, _ 'Handle of owner, menu handle
ghInstance, BYVAL %NULL) 'Handle of instance, creation parameters
IF hWnd THEN 'If window could be created
'Make the window visible and update client area
ShowWindow(hWnd, nCmdShow)
UpdateWindow(hWnd)
WHILE GetMessage(TagMessage, BYVAL %NULL, 0, 0) > 0
IF IsDialogMessage(hWnd, TagMessage) = 0 THEN
TranslateMessage(TagMessage)
DispatchMessage(TagMessage)
END IF
WEND
FUNCTION = TagMessage.wParam
END IF
ELSE
FUNCTION = %TRUE
END IF
END FUNCTION
This works:
$ filename "test3.exe"
uses rtl64
uses MinWin
uses User
#lookahead
%GWLP_WNDPROC = -4
function WinMain() as sys
WndClass wc
MSG wm
sys inst = GetModuleHandle 0
sys hwnd, wwd, wht, wtx, wty, tax
wc.style = CS_HREDRAW or CS_VREDRAW
wc.lpfnWndProc = &WndProc
wc.cbClsExtra = 0
wc.cbWndExtra = 0
wc.hInstance = GetModuleHandle 0
wc.hIcon=LoadIcon 0, IDI_APPLICATION
wc.hCursor=LoadCursor 0,IDC_ARROW
wc.hbrBackground = GetStockObject WHITE_BRUSH
wc.lpszMenuName =0
wc.lpszClassName =@"Demo"
RegisterClass (&wc)
Wwd = 320 : Wht = 200
Tax = GetSystemMetrics SM_CXSCREEN
Wtx = (Tax - Wwd) /2
Tax = GetSystemMetrics SM_CYSCREEN
Wty = (Tax - Wht) /2
hwnd = CreateWindowEx(0,wc.lpszClassName,"OXYGEN BASIC",WS_OVERLAPPEDWINDOW,Wtx,Wty,Wwd,Wht,0,0,inst,0)
sys hEdit = CreateWindowEx(WS_EX_CLIENTEDGE, _
"Edit", _
"", _
WS_CHILD OR WS_VISIBLE OR WS_TABSTOP, _
20, 30, _
250, 25, _
hWnd, 102, _
inst, 0)
SetProp(hedit, "OLDWNDPROC", SetWindowLongPtr(hEdit, GWLP_WNDPROC, &EditSubclassProc))
SetFocus hEdit
ShowWindow hwnd,SW_SHOW
UpdateWindow hwnd
WHILE GetMessage(&wm, 0, 0, 0) > 0
IF IsDialogMessage(hWnd, &wm) = 0 THEN
TranslateMessage(&wm)
DispatchMessage(&wm)
END IF
WEND
End Function
function WndProc (sys hWnd, wMsg, wParam, lparam) as sys callback
'==================================================================
SELECT wMsg
CASE WM_CREATE
EXIT FUNCTION
CASE WM_COMMAND
SELECT CASE LOWORD(wParam)
CASE IDCANCEL
' // If the Escape key has been pressed...
IF HIWORD(wParam) = BN_CLICKED THEN
' // ... close the application by sending a WM_CLOSE message
SendMessage hwnd, WM_CLOSE, 0, 0
EXIT FUNCTION
END IF
END SELECT
CASE WM_DESTROY
PostQuitMessage 0
END SELECT
function = DefWindowProc hWnd,wMsg,wParam,lParam
end function ' WndProc
FUNCTION EditSubclassProc (sys hWnd, wMsg, wParam, lparam) as sys callback
SELECT CASE wMsg
CASE WM_DESTROY
' // REQUIRED: Remove control subclassing
SetWindowLongPtr hwnd, GWLP_WNDPROC, RemoveProp(hwnd, "OLDWNDPROC")
CASE WM_KEYDOWN
SetWindowText GetParent(hwnd), "ASCII " & STR(wParam)
END SELECT
FUNCTION = CallWindowProc(GetProp(hwnd, "OLDWNDPROC"), hwnd, wMsg, wParam, lParam)
END FUNCTION
WinMain
Now Charles should talk us about the "callback" keyword. It does not work without it, but it is no documented in the "help" (?) file. I have lost two hours because of it >:(
Sorry about that, José. And many thanks for the ported example :)
The callback or external attribute is required so that the standard calling convention is used. In this instance, ms64. Also, a proc signature is not required when referencing callbacks: @WndProc.
An alternative way is to put such procedures within an extern block
Thanxx a lot Sir Jose
at last you have conquered the O2 SDK style windows and subclassing phenomenon
yeah, the lack of documentation would need to be address possibly in this case, the compiler
must flag out with an error message if the callback keyword is missing
in the callback function
Here's a more modern way of subclassing, using SetWindowSubclass:
$ filename "test4.exe"
uses rtl64
uses MinWin
uses User
uses Comctl
#lookahead
%GWLP_WNDPROC = -4
function WinMain() as sys
WndClass wc
MSG wm
sys inst = GetModuleHandle 0
sys hwnd, wwd, wht, wtx, wty, tax
wc.style = CS_HREDRAW or CS_VREDRAW
wc.lpfnWndProc = &WndProc
wc.cbClsExtra = 0
wc.cbWndExtra = 0
wc.hInstance = GetModuleHandle 0
wc.hIcon=LoadIcon 0, IDI_APPLICATION
wc.hCursor=LoadCursor 0,IDC_ARROW
wc.hbrBackground = GetStockObject WHITE_BRUSH
wc.lpszMenuName =0
wc.lpszClassName =@"Demo"
RegisterClass (&wc)
Wwd = 320 : Wht = 200
Tax = GetSystemMetrics SM_CXSCREEN
Wtx = (Tax - Wwd) /2
Tax = GetSystemMetrics SM_CYSCREEN
Wty = (Tax - Wht) /2
hwnd = CreateWindowEx(0,wc.lpszClassName,"OXYGEN BASIC",WS_OVERLAPPEDWINDOW,Wtx,Wty,Wwd,Wht,0,0,inst,0)
sys hEdit = CreateWindowEx(WS_EX_CLIENTEDGE, _
"Edit", _
"", _
WS_CHILD OR WS_VISIBLE OR WS_TABSTOP, _
20, 30, _
250, 25, _
hWnd, 102, _
inst, 0)
SetWindowSubclass hEdit, &EditSubclassProc, 102, 0
SetFocus hEdit
ShowWindow hwnd,SW_SHOW
UpdateWindow hwnd
WHILE GetMessage(&wm, 0, 0, 0) > 0
IF IsDialogMessage(hWnd, &wm) = 0 THEN
TranslateMessage(&wm)
DispatchMessage(&wm)
END IF
WEND
End Function
function WndProc (sys hWnd, uint wMsg, sys wParam, sys lparam) as sys callback
'==================================================================
SELECT wMsg
CASE WM_CREATE
EXIT FUNCTION
CASE WM_COMMAND
SELECT CASE LOWORD(wParam)
CASE IDCANCEL
' // If the Escape key has been pressed...
IF HIWORD(wParam) = BN_CLICKED THEN
' // ... close the application by sending a WM_CLOSE message
SendMessage hwnd, WM_CLOSE, 0, 0
EXIT FUNCTION
END IF
END SELECT
CASE WM_DESTROY
PostQuitMessage 0
END SELECT
function = DefWindowProc hWnd,wMsg,wParam,lParam
end function ' WndProc
FUNCTION EditSubclassProc (sys hWnd, uint wMsg, sys wParam, sys lparam, uIdSubclass, dwRefData) as sys callback
SELECT CASE wMsg
CASE WM_DESTROY
' // REQUIRED: Remove control subclassing
RemoveWindowSubclass hwnd, &EditSubclassProc, uIdSubclass
CASE WM_KEYDOWN
SetWindowText GetParent(hwnd), "ASCII " & STR(wParam)
END SELECT
FUNCTION = DefSubclassProc(hwnd, wMsg, wParam, lParam)
END FUNCTION
WinMain
[code]
And here's a more modern way to handle UDT member assignment:
........
WITH wc
.style = CS_HREDRAW or CS_VREDRAW
.lpfnWndProc = &WndProc
.cbClsExtra = 0
.cbWndExtra = 0
.hInstance = GetModuleHandle 0
.hIcon = LoadIcon 0, IDI_APPLICATION
.hCursor = LoadCursor 0,IDC_ARROW
.hbrBackground = GetStockObject WHITE_BRUSH
.lpszMenuName = 0
.lpszClassName = @"Demo"
END WITH
........
Thanxx all for your help, indeed now that O2 is progressing really well with your inputs.
Now there is some very bright light is shinning at the end of the tunnel