Subclassing a textbox

[Chris Chancellor]

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

Code Select Expand


' 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

Code Select Expand


' 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





[Charles Pegge]

Hi Chris,

I have no experience with Subclassing or DDT. Can you do it in PB first, without the DDT.

[José Roca]

The posted O2 code doesn't even compile. Apparently, CreateModalDialog has a fourth parameter.

[Chris Chancellor]

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

Code Select Expand


'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

'==============================================================================


[José Roca]

It compiles but it doesn't run in my computer.

[José Roca]

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.

Code Select Expand


  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.

[Charles Pegge]

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.

[Chris Chancellor]

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 ?

[Chris Chancellor]

Hello all

here is the subclass textbox in windows SDK style in PB

Code Select Expand


' 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


[José Roca]

This works:

Code Select Expand


$ 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


[José Roca]

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 

[Charles Pegge]

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

[Chris Chancellor]

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

[José Roca]

Here's a more modern way of subclassing, using SetWindowSubclass:

Code Select Expand


$ 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]


[Mike Lobanovsky]

And here's a more modern way to handle UDT member assignment:

Code Select Expand

........
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
........