Oxygen Basic
Programming => Example Code => Topic started by: Aurel on February 20, 2020, 12:03:52 PM
-
Hello Charles....and others ..of course
when subclassing work in a Dialog based app,as you may see in topic about line numbers.
But in Window based app from what i tried ,and believe me i tried all possible options using all possible
examples i can find on net to make it right.
No mather what version of SetWindowLong i use ,program simply crush when i try to run.
Compilation work fine witohut errors.
I tried with both older A043 and with last 0.2.8 varsion 32 bit.
I tried the same method which is used in dialog app to get it work as you can see in code.
I am using awinh037.inc with which i compiled and run my AurelEdit program in latest 0.2.8 version so i think
that is not problem in include ( i hope)
I don't know how to run this code using wincore ? sorry...
here is code:
$ Filename "ARichLN.exe" ' Oxygen Basic
Include "RTL32.inc"
Include "awinh037.inc"
#lookahead
'api calls for subclasing + some GDI functions(! you can put it inside include file)
! CallWindowProc Lib "user32.dll" Alias "CallWindowProcA"(lpPrevWndFunc AS INT,hWnd AS INT,Msg AS INT,wParam AS INT,lParam AS INT) as INT
'! SetWindowLong Lib "user32.dll" Alias "SetWindowLongA"(hwnd AS int, nIndex AS INT, dwNewLong AS SYS) as INT
Declare Function SetWindowLong Lib "user32.dll" Alias "SetWindowLongA" (ByVal hctl As Long, ByVal nIndex As Long,byval dwNewLong As int) As Long
! GetDlgItem Lib "user32.dll" Alias "GetDlgItem" (ByVal hDlg As INT, ByVal nIDDlgItem As INT) As INT
! GetTextMetrics Lib "gdi32.dll" Alias "GetTextMetricsA" (ByVal hdc As Long, lpMetrics As TEXTMETRIC) As Long
! DrawText Lib "user32.dll" Alias "DrawTextA" (ByVal hdc As Long, ByVal lpStr As String, ByVal nCount As Long, lpRect As RECT, ByVal wFormat As Long) As Long
! GetCaretPos Lib "user32.dll" Alias "GetCaretPos"(lpPoint AS POINTAPI) as INT
! wsprintf Lib "user32.dll" Alias "wsprintfA" (ByVal lpzBuffer as Long, ByVal lpzFormat As String, Byval Number as Long) As long
'! editCallback (byval uWnd as int,byval uMsg as int,byval wParam as int, byval lParam as int) as int
Declare Function SaveDC Lib "gdi32.dll" (ByVal hdc As Long) As Long
Declare Function RestoreDC Lib "gdi32.dll" (ByVal hdc As Long, ByVal nSavedDC As Long) As Long
Declare Function CreateRectRgn Lib "gdi32.dll" (ByVal X1 As Long, ByVal Y1 As Long, ByVal X2 As Long, ByVal Y2 As Long) As Long
Declare Function SelectClipRgn Lib "gdi32.dll" (ByVal hdc As Long, ByVal hRgn As Long) As Long
'! SetWindowLongPtr Lib "user32.dll" Alias "SetWindowLongA" (ByVal hctl As sys, ByVal nIndex As Long, ByVal dwNewLong As sys) As sys
'extern lib "user32.dll"
'! SetWindowLong "SetWindowLongA"
'create window
INT win,x=200,y=220,w=600,h=480,wstyle = WS_MINMAXSIZE
win = SetWindow("RichEdit control ",x,y,w,h,0,wstyle)
INT button0,b0ID=100
button0 = SetButton(win,18,4,80,26,"OPEN (X)",0x50001000,0x200,b0ID)
'richedit
INT hRich,richID = 400
'hRich = SetRichEdit (win, 20,50,500,380,"", 1412518084, 0x200, richID)
'create margin on richedit control
% MARGIN_X = 70
SendMessage hRich, EM_SETMARGINS, EC_LEFTMARGIN, MARGIN_X
'subclass richedit to his own callback function
sys editProc '= SetWindowLong (GetDlgItem( win, richID), GWL_WNDPROC, @editCallback)
'print "editProc:" + str(editProc)
int hcont
Wait() 'message loop
'main window callback function ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
Function WndProc (sys hwnd,wmsg,wparam,lparam) as int callback
win = hwnd
SELECT hwnd
CASE win
'dret = CallWindowProc(editProc,hWnd, wMsg,wParam,lParam)
Select wmsg
Case WM_CREATE
hRich = SetRichEdit (win, 20,50,500,380,"", 1412518084, 0x200, richID)
'.............. next line cause app crush ???? .........................
editProc = SetWindowLong( GetDlgItem( hwnd, richID), GWL_WNDPROC, @editCallback)
'.................................................................................
Case WM_CLOSE
CloseWindow(win)
EndProgram()
End Select
END SELECT
Return Default
End Function
'~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~11
'richedit callback function
Function editCallback(sys hwnd , uMsg, wParam , lParam ) as int callback
POINTAPI pt
CHAR sz[16]
DWORD lc
RECT crect
sys rgn
int dret
sys hDC
int line
int charpos
' Select wMsg
' Case WM_PAINT
dret = CallWindowProc(editProc,hWnd, uMsg,wParam,lParam)
'print "DRET:" + str(dret)
if uMsg = WM_PAINT
lc=SendMessage(hwnd,EM_GETLINECOUNT,0,0)
if lc
hDC = GetDC(hwnd)
SaveDC(hDC)
GetClientRect(hwnd, crect)
rgn = CreateRectRgn(crect.left,crect.top,crect.right,crect.bottom)
SelectClipRgn(hDC,rgn)
';fnx br = SelectObject,ebx,rv(CreateSolidBrush,bkColor)
'% PATCOPY 0x00F00021
BitBlt(hDC,0,0,MARGIN_X,crect.bottom, hDC,0,0,PATCOPY)
';fn DeleteObject,rv(SelectObject,ebx,br)
line=SendMessage(hwnd,EM_GETFIRSTVISIBLELINE,0,0)
while line <= lc
charpos = SendMessage(hwnd,EM_LINEINDEX,line,0)
exit if charpos == -1
SendMessage(hwnd,EM_POSFROMCHAR,&pt,charpos)
exit if pt.y > crect.bottom
'wide char
wsprintf(&sz,"%lu",line+1)
TextOut(hDC,0,pt.y,sz,len(sz))
line++
wend
RestoreDC(hDC,-1)
DeleteObject(rgn)
ReleaseDC(hwnd,hDC)
end if
end if
return dret
'Return 0
' End Select
' 0 Return CallWindowProc (editProc, hwnd, uMsg, wParam, lParam)
'return 0
End Function
-
Hi
Charles , i have found in folder examples\WinGUI
program callled UniversalButtons ,program is really cool and remind me on old abandoned compiler
which use same shapes for gui elements...
how ever i found this method of subclassing which is used in that program
i hope that should work :
'Subclass all the buttons to the same procedure...
glpButtonProc = GetWindowLongPtr(hButton, GWL_WNDPROC)
SetWindowLongPtr(hButton, GWL_WNDPROC, @ButtonProc)
-
Hi Charles
I am stuck with this two api calls.
I am using last o2 0.2.8.
After i create richedit control i use api GetWindowLongPtr ( hwnd,gwlData)
and app compile fine ...then when i tried to run i get error that function is not loaded.
Same function is used in example UniversalButton and there work... ???
I am now totally confused, how is possible that same function not work ?
Just to let you know i declerd it first on usual way...then
when not work i tried with
extern lib "user32.dll"
also compile fine but exit with same error
then i tried
uses user
also nothing
then with
include "user.inc"
also nothing
-
Hi Aurel,
if you do not include corewin.inc (e.g. dialogs.inc already includes corewin.inc) you should check user.inc and windata.inc to find out how Charles handled Set/GetWindowLong and Set/GetWindowLongPtr for 32 and 64 bit mode. As already stated, the Set/GetWindowLongPtr functions are not provided in the 32-bit version of user32.dll and a work-around must be used to satisfy both systems.
-
if you do not include corewin.inc (e.g. dialogs.inc already includes corewin.inc) you should check user.inc and windata.inc to find out how Charles handled Set/GetWindowLong and Set/GetWindowLongPtr for 32 and 64 bit mode. As already stated, the Set/GetWindowLongPtr functions are not provided in the 32-bit version of user32.dll and a work-around must be used to satisfy both systems.
Hi Roland
Thanks on points...i looked into user.inc and i found this:
#ifdef mode64bit
! GetClassLongPtr "GetClassLongPtrA"
! SetClassLongPtr "SetClassLongPtrA"
! GetWindowLongPtr "GetWindowLongPtrA"
! SetWindowLongPtr "SetWindowLongPtrA"
! GetClassLongPtrW
! SetClassLongPtrW
! GetWindowLongPtrW
! SetWindowLongPtrW
#endif
In winData.inc is also similar:
#ifndef mode64bit
def GetClassLongPtr GetClassLong
def SetClassLongPtr SetClassLong
def GetWindowLongPtr GetWindowLong
def SetWindowLongPtr SetWindowLong
def GetClassLongPtrW GetClassLongW
def SetClassLongPtrW SetClassLongW
def GetWindowLongPtrW GetWindowLongW
def SetWindowLongPtrW SetWindowLongW
#endif
And in MinWin.inc is this:
#ifdef mode64bit
! GetWindowLongPtr "GetWindowLongPtrA" '2
! SetWindowLongPtr "SetWindowLongPtrA" '3
#endif
As i can see there is and looks to me that is only for 64bit systems, but how then work on 32bit in example
UniversalButton ...that must be some kind of trick?
Only difference is that is def used insted ! - declare function ..right.
-
In program UniversalButton button is subclassed inside function
'-----------------------------------------------------------------------------
' Step Three: -Create the button, Subclass it,
' -Create the instance data,
' -and Return the new buttons handle.
'-----------------------------------------------------------------------------
function FinalCreateTheButton(string szCaption, ' caption
dword Wstyle, ' style
RECT *rc, ' top/left corner
sys hparent, ' parent hWnd
int ID) as sys ' ID
sys hButton
dword dWstyle
tagCTLDATA *ptCD 'PTR
'default style...
dWstyle = BS_OWNERDRAW or WS_TABSTOP or _
BS_PUSHBUTTON or BS_NOTIFY 'or WS_DISABLED
dwstyle = dWstyle or Wstyle
'Create the owner-draw push button...
hButton = CreateWindowEx(0,"BUTTON",
szCaption,
dWstyle,
rc.Left, rc.Top,
rc.Right, rc.Bottom,
hparent, ID,
ghInst, null )
if hButton = 0 then mbox "Error in FinalCreateTheButton: Cannot CreateWindowEx hbutton"
'Subclass all the buttons to the same procedure...
glpButtonProc = GetWindowLongPtr(hButton, GWL_WNDPROC)
SetWindowLongPtr(hButton, GWL_WNDPROC, @ButtonProc)
'assign new region to a window
SetWindowRgn(hButton, m_hRgn, bTrue)
'create this controls instance data...
CtlDataCreate(hButton)
'add the final updates to instance data
&ptCD = GetProp(hButton,"ptCTLDATA")
ptCD.hButton = hButton
ptCD.idbutton = ID
return hButton 'return the handle
end function
-
I downloaded your code of your first message. I did not look very much to it, but I replaced your wrappings with corewin.inc and modified int win to sys win. (handles and pointers must be sys).
I can run your code JIT-compiled and I can also create a 32 bit executable which works. 64-bit exe does not work.
All this is a sign that your wrappings are not correct. You have to compare your wrapper functions with Win32 Help file or similiar SDK documentation. There is a lot of info in Internet if you want to look for differences of Win32 and Win64. The most important rule is looking for handles and pointers. You can also look in the include files and in the WinGui demos, when sys is used; sys is 4 bytes in Win32, 8 bytes in Win64. Int is always 4 bytes. Also different constants are used sometimes for Win64, also for dialog or window classes. It is a hardworking bed, but it is necessary.
$ Filename "ARichLN.exe" ' Oxygen Basic
'Include "RTL32.inc"
'uses rtl64 ' does not work
Include "awinh037.inc"
use corewin
// #lookahead
/*
'api calls for subclasing + some GDI functions(! you can put it inside include file)
! CallWindowProc Lib "user32.dll" Alias "CallWindowProcA"(lpPrevWndFunc AS INT,hWnd AS INT,Msg AS INT,wParam AS INT,lParam AS INT) as INT
'! SetWindowLong Lib "user32.dll" Alias "SetWindowLongA"(hwnd AS int, nIndex AS INT, dwNewLong AS SYS) as INT
Declare Function SetWindowLong Lib "user32.dll" Alias "SetWindowLongA" (ByVal hctl As Long, ByVal nIndex As Long,byval dwNewLong As int) As Long
! GetDlgItem Lib "user32.dll" Alias "GetDlgItem" (ByVal hDlg As INT, ByVal nIDDlgItem As INT) As INT
! GetTextMetrics Lib "gdi32.dll" Alias "GetTextMetricsA" (ByVal hdc As Long, lpMetrics As TEXTMETRIC) As Long
! DrawText Lib "user32.dll" Alias "DrawTextA" (ByVal hdc As Long, ByVal lpStr As String, ByVal nCount As Long, lpRect As RECT, ByVal wFormat As Long) As Long
! GetCaretPos Lib "user32.dll" Alias "GetCaretPos"(lpPoint AS POINTAPI) as INT
! wsprintf Lib "user32.dll" Alias "wsprintfA" (ByVal lpzBuffer as Long, ByVal lpzFormat As String, Byval Number as Long) As long
'! editCallback (byval uWnd as int,byval uMsg as int,byval wParam as int, byval lParam as int) as int
Declare Function SaveDC Lib "gdi32.dll" (ByVal hdc As Long) As Long
Declare Function RestoreDC Lib "gdi32.dll" (ByVal hdc As Long, ByVal nSavedDC As Long) As Long
Declare Function CreateRectRgn Lib "gdi32.dll" (ByVal X1 As Long, ByVal Y1 As Long, ByVal X2 As Long, ByVal Y2 As Long) As Long
Declare Function SelectClipRgn Lib "gdi32.dll" (ByVal hdc As Long, ByVal hRgn As Long) As Long
'! SetWindowLongPtr Lib "user32.dll" Alias "SetWindowLongA" (ByVal hctl As sys, ByVal nIndex As Long, ByVal dwNewLong As sys) As sys
'extern lib "user32.dll"
'! SetWindowLong "SetWindowLongA"
*/
'create window
sys win
INT x=200,y=220,w=600,h=480,wstyle = WS_MINMAXSIZE
win = SetWindow("RichEdit control ",x,y,w,h,0,wstyle)
INT button0,b0ID=100
button0 = SetButton(win,18,4,80,26,"OPEN (X)",0x50001000,0x200,b0ID)
'richedit
'no more changes, but should be checked
[
/code]
-
Thanks Arnold
All this is a sign that your wrappings are not correct
.
Nothing is wrong with my wrapper as i said before but I suspect that main problem might be in types
INT to SYS , also i don't understand why i must use sys when i using 32bit.
OK i will try change this and if work i will try on win7-64bit two , because i have dual boot win7 - 32,64
;)
-
As a proof of the concept I removed corewin.inc and did the declarations (using the Win32 Helpfile) of SetWindowLong, CallWindowProc, GetDlgItem. The declaration of wsprintf I did not change, the other functions I used unptrotyped, but can be adapted. It seems you forgot the byval approach in SetWindowLong function. Applying these modifications the app will run too (in 32-bit)
$ Filename "ARichLN.exe" ' Oxygen Basic
'Include "RTL32.inc"
'uses rtl64 ' does not work
Include "awinh037.inc"
// #lookahead
/*
'api calls for subclasing + some GDI functions(! you can put it inside include file)
! CallWindowProc Lib "user32.dll" Alias "CallWindowProcA"(lpPrevWndFunc AS INT,hWnd AS INT,Msg AS INT,wParam AS INT,lParam AS INT) as INT
'! SetWindowLong Lib "user32.dll" Alias "SetWindowLongA"(hwnd AS int, nIndex AS INT, dwNewLong AS SYS) as INT
Declare Function SetWindowLong Lib "user32.dll" Alias "SetWindowLongA" (ByVal hctl As Long, ByVal nIndex As Long,byval dwNewLong As int) As Long
! GetDlgItem Lib "user32.dll" Alias "GetDlgItem" (ByVal hDlg As INT, ByVal nIDDlgItem As INT) As INT
! GetTextMetrics Lib "gdi32.dll" Alias "GetTextMetricsA" (ByVal hdc As Long, lpMetrics As TEXTMETRIC) As Long
! DrawText Lib "user32.dll" Alias "DrawTextA" (ByVal hdc As Long, ByVal lpStr As String, ByVal nCount As Long, lpRect As RECT, ByVal wFormat As Long) As Long
! GetCaretPos Lib "user32.dll" Alias "GetCaretPos"(lpPoint AS POINTAPI) as INT
! wsprintf Lib "user32.dll" Alias "wsprintfA" (ByVal lpzBuffer as Long, ByVal lpzFormat As String, Byval Number as Long) As long
'! editCallback (byval uWnd as int,byval uMsg as int,byval wParam as int, byval lParam as int) as int
Declare Function SaveDC Lib "gdi32.dll" (ByVal hdc As Long) As Long
Declare Function RestoreDC Lib "gdi32.dll" (ByVal hdc As Long, ByVal nSavedDC As Long) As Long
Declare Function CreateRectRgn Lib "gdi32.dll" (ByVal X1 As Long, ByVal Y1 As Long, ByVal X2 As Long, ByVal Y2 As Long) As Long
Declare Function SelectClipRgn Lib "gdi32.dll" (ByVal hdc As Long, ByVal hRgn As Long) As Long
'! SetWindowLongPtr Lib "user32.dll" Alias "SetWindowLongA" (ByVal hctl As sys, ByVal nIndex As Long, ByVal dwNewLong As sys) As sys
'extern lib "user32.dll"
'! SetWindowLong "SetWindowLongA"
*/
'! SetWindowLong Lib "user32.dll" Alias "SetWindowLongA" (sys hwnd, dword nIndex, dword dwNewLong) as sys
! SetWindowLong Lib "user32.dll" Alias "SetWindowLongA" (byval hwnd as sys, byval nIndex as dword, byval dwNewLong as dword) as sys
! CallWindowProc Lib "user32.dll" Alias "CallWindowProcA" (byval lpPrevWndFunc AS sys,byval hWnd AS sys,byval Msg AS uint,byval wParam AS sys,byval lParam AS sys) as sys
! GetDlgItem Lib "user32.dll" (ByVal hDlg As sys, ByVal nIDDlgItem As INT) As sys
! wsprintf Lib "user32.dll" Alias "wsprintfA" (ByVal lpzBuffer as Long, ByVal lpzFormat As String, Byval Number as Long) As long
Declare Function CreateRectRgn Lib "gdi32.dll"
Declare Function SaveDC Lib "gdi32.dll"
Declare Function RestoreDC Lib "gdi32.dll"
Declare Function SelectClipRgn Lib "gdi32.dll"
....
-
Arnold
As a proof that is not wrong with my include i checked each api function with corewin and without
forgot the byval approach in SetWindowLong function
yes you are right, i made so many changes in testing... ::)
and i get it finally what is wrong ,is not problem in sys or int ( long is problematic a little) then
in different shape of
! CallWindowProc Lib "user32.dll" Alias "CallWindowProcA"(sys pPrevWndFunc ,hWnd ,uMsg ,wParam ,lParam ) as int
and above shape work when old with byVal, byRef which i have used before not work.
This might be , just might be because i don't have tested it yet on 64bit too.
of course this is not first time, i was suspicious because awinh.inc work with other programs in new 0.2.8. veersion.
Also i don't know that #lookahead now don't have effect ??
All in all, thank you very much on testing this program Arnold :)
Also i know what i must replace in awinh.
Of course thanks to Charles ;)
Here is code:
$ Filename "ARichLN.exe" ' Oxygen Basic
Include "RTL32.inc"
Include "awinh037.inc"
#lookahead ' work without #lookahead ???
'use corewin
'api calls for subclasing + some GDI functions(! you can put it inside include file)~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
! CallWindowProc Lib "user32.dll" Alias "CallWindowProcA"(sys pPrevWndFunc ,hWnd ,uMsg ,wParam ,lParam ) as int
'~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
! GetDlgItem Lib "user32.dll" Alias "GetDlgItem" (ByVal hDlg As INT, ByVal nIDDlgItem As INT) As INT
! GetTextMetrics Lib "gdi32.dll" Alias "GetTextMetricsA" (ByVal hdc As Long, lpMetrics As TEXTMETRIC) As Long
'! DrawText Lib "user32.dll" Alias "DrawTextA" (ByVal hdc As Long, ByVal lpStr As String, ByVal nCount As Long, lpRect As RECT, ByVal wFormat As Long) As Long
! GetCaretPos Lib "user32.dll" Alias "GetCaretPos"(lpPoint AS POINTAPI) as INT
! wsprintf Lib "user32.dll" Alias "wsprintfA" (ByVal lpzBuffer as sys, ByVal lpzFormat As String, Byval Number as int) As int
'! editCallback (byval uWnd as int,byval uMsg as int,byval wParam as int, byval lParam as int) as int
! SaveDC Lib "gdi32.dll" (ByVal hdc As int) As int
! RestoreDC Lib "gdi32.dll" (ByVal hdc As int, ByVal nSavedDC As int) As sys
! CreateRectRgn Lib "gdi32.dll" (ByVal X1 As int, ByVal Y1 As int, ByVal X2 As int, ByVal Y2 As int) As int
! SelectClipRgn Lib "gdi32.dll" (ByVal hdc As int, ByVal hRgn As int) As int
'use corewin
! GetWindowLong Lib "user32.dll" Alias "GetWindowLongA" (ByVal hctl As int, ByVal nIndex As int) As int
! SetWindowLong Lib "user32.dll" Alias "SetWindowLongA" (ByVal hctl As int, ByVal nIndex As int, byval dwNewLong As int) As int
'declare function GetWindowLongPtr Lib "user32.dll" Alias "GetWindowLongPtrA"(ByVal hctl As Long, ByVal gwlData As Long) As int
'declare function SetWindowLongPtr Lib "user32.dll" Alias "SetWindowLongPtrA" (ByVal hctl As long, ByVal nIndex As Long, dwNewLong As sys) As int
! BitBlt Lib "gdi32.dll" (ByVal hDestDC As int, ByVal x As int, ByVal y As int, ByVal nWidth As int, ByVal nHeight As int, ByVal hSrcDC As int, ByVal xSrc As int, ByVal ySrc As int, ByVal dwRop As int) As int
'use corewin
'create window
INT win
INT x=200,y=220,w=600,h=480,wstyle = WS_MINMAXSIZE
win = SetWindow("RichEdit control ",x,y,w,h,0,wstyle)
INT button0,b0ID=100
button0 = SetButton(win,18,4,80,26,"OPEN (X)",0x50001000,0x200,b0ID)
'richedit
INT hRich
int richID = 400
hRich = SetRichEdit (win, 20,50,500,380,"", 1412518084, 0x200, richID)
'create margin on richedit control
% MARGIN_X = 70
SendMessage hRich, EM_SETMARGINS, EC_LEFTMARGIN, MARGIN_X
INT editProc = GetWindowLong( hrich, GWL_WNDPROC)
'subclass richedit to his own callback function
SetWindowLong(hRich, GWL_WNDPROC, @editCallback)
'print "editProc:" + str(editProc)
'int hcont
Wait() 'message loop
'main window callback function ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
Function WndProc (sys hwnd,wmsg,wparam,lparam) as int callback
win = hwnd
SELECT hwnd
CASE win
Select wmsg
Case WM_CREATE
'hRich = SetRichEdit (win, 20,50,500,380,"", 1412518084, 0x200, richID)
'hcont = GetDlgItem( win, richID)
'editProc = GetWindowLong( hrich, GWL_WNDPROC)
' print "hcont:" + str(hcont)
'SetWindowLong(hrich, GWL_WNDPROC, @editCallback)
'print "editProc:" + str(editProc)
Case WM_CLOSE
CloseWindow(win)
EndProgram()
End Select
END SELECT
Return Default
End Function
'~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~11
'richedit callback function
Function editCallback(sys hwnd , uMsg, wParam , lParam ) as int callback
POINTAPI pt
CHAR sz[16]
DWORD lc
RECT crect
INT rgn
int dret
INT hDC
int line
int charpos
' Select wMsg
' Case WM_PAINT
dret = CallWindowProc( editProc,hWnd, uMsg,wParam,lParam)
'print "DRET:" + str(dret)
if uMsg = WM_PAINT
lc=SendMessage(hwnd,EM_GETLINECOUNT,0,0)
if lc
hDC = GetDC(hwnd)
SaveDC(hDC)
GetClientRect(hwnd, crect)
rgn = CreateRectRgn(crect.left,crect.top,crect.right,crect.bottom)
SelectClipRgn(hDC,rgn)
';fnx br = SelectObject,ebx,rv(CreateSolidBrush,bkColor)
'% PATCOPY 0x00F00021
BitBlt (hDC,0,0,MARGIN_X,crect.bottom, hDC,0,0,PATCOPY)
';fn DeleteObject,rv(SelectObject,ebx,br)
line=SendMessage(hwnd,EM_GETFIRSTVISIBLELINE,0,0)
while line <= lc
charpos = SendMessage(hwnd,EM_LINEINDEX,line,0)
exit if charpos == -1
SendMessage(hwnd,EM_POSFROMCHAR,&pt,charpos)
exit if pt.y > crect.bottom
'wide char
wsprintf(&sz,"%lu",line+1)
TextOut(hDC,0,pt.y,sz,len(sz))
line++
wend
RestoreDC(hDC,-1)
DeleteObject(rgn)
ReleaseDC(hwnd,hDC)
end if
end if
return dret
'Return 0
' End Select
Return CallWindowProc (editProc, hwnd, uMsg, wParam, lParam)
'return 0
End Function
just add back color and set font ,it looks better
-
Hi
As next step i would like to add simply syntax coloring(highlite) of some keywords-
I found one example on Garry Beene site with Borje Hagsteen syntax coloring on richedit control.
It work very well well on PBwin i also tried so i don't se reason why would not work in o2.
-
But first easy thing.
I look into another Garry example with context menu and looks to me really simple and
( Garry have really big amount of great and simple exmples how to do programming :) )
i must say that i don't see similar version in other gui programs which use ScreenToClient method.
So i add one subroutine in which i create PopUpMenu:
SUB RichEditPopUpMenu()
richMenu = CreatePopupMenu ()
'addsub menu items with ID
AppendMenu (richMenu, 0, 700, strptr "CUT")
'SetMenuItemBitmaps(submenu1, 0,MF_BYPOSITION , mImg1, 0) 'add menu item bitmap
AppendMenu (richMenu, 0, 701, strptr "COPY")
'SetMenuItemBitmaps(submenu1, 1,MF_BYPOSITION , mImg2, 0)
AppendMenu (richMenu, 0, 702, strptr "PASTE")
'SetMenuItemBitmaps(submenu1, 2,MF_BYPOSITION , mImg3, 0)
AppendMenu (richMenu, 0, 703, strptr "SELECT_ALL")
'SetMenuItemBitmaps(submenu1, 3,MF_BYPOSITION , mImg4, 0)
END SUB
then just under message events add this:
Case WM_CONTEXTMENU
mousex = LoWord(lParam) : mousey = HiWord(lParam) 'get mouse coordinate
GetClientRect(hRich, rcRE)
TrackPopupMenu (richMenu, 0, mousex, mousey, 0, hRich, rcRE ) 'put context menu where mouse is
and work well, i just need to add menu id chacks to get CUT/COPY/PASTE functions
-
And now with bitmaps on context menu
$ Filename "ARichLN.exe" ' Oxygen Basic v0.2.8 / Aurel 27.2.2020
Include "RTL32.inc"
Include "awinh037.inc"
#lookahead
'api calls for subclasing + some GDI functions(! you can put it inside include file)
! CallWindowProc Lib "user32.dll" Alias "CallWindowProcA"(sys pPrevWndFunc ,hWnd ,uMsg ,wParam ,lParam ) as int
! GetDlgItem Lib "user32.dll" Alias "GetDlgItem" (ByVal hDlg As INT, ByVal nIDDlgItem As INT) As INT
! GetTextMetrics Lib "gdi32.dll" Alias "GetTextMetricsA" (ByVal hdc As Long, lpMetrics As TEXTMETRIC) As Long
'! DrawText Lib "user32.dll" Alias "DrawTextA" (ByVal hdc As Long, ByVal lpStr As String, ByVal nCount As Long, lpRect As RECT, ByVal wFormat As Long) As Long
! GetCaretPos Lib "user32.dll" Alias "GetCaretPos"(lpPoint AS POINTAPI) as INT
! wsprintf Lib "user32.dll" Alias "wsprintfA" (ByVal lpzBuffer as sys, ByVal lpzFormat As String, Byval Number as int) As int
! SaveDC Lib "gdi32.dll" (ByVal hdc As int) As int
! RestoreDC Lib "gdi32.dll" (ByVal hdc As int, ByVal nSavedDC As int) As sys
! CreateRectRgn Lib "gdi32.dll" (ByVal X1 As int, ByVal Y1 As int, ByVal X2 As int, ByVal Y2 As int) As int
! SelectClipRgn Lib "gdi32.dll" (ByVal hdc As int, ByVal hRgn As int) As int
'use corewin
! GetWindowLong Lib "user32.dll" Alias "GetWindowLongA" (ByVal hctl As int, ByVal nIndex As int) As int
! SetWindowLong Lib "user32.dll" Alias "SetWindowLongA" (ByVal hctl As int, ByVal nIndex As int, byval dwNewLong As int) As int
'declare function GetWindowLongPtr Lib "user32.dll" Alias "GetWindowLongPtrA"(ByVal hctl As Long, ByVal gwlData As Long) As int
'declare function SetWindowLongPtr Lib "user32.dll" Alias "SetWindowLongPtrA" (ByVal hctl As long, ByVal nIndex As Long, dwNewLong As sys) As int
! BitBlt Lib "gdi32.dll" (ByVal hDestDC As int, ByVal x As int, ByVal y As int, ByVal nWidth As int, ByVal nHeight As int, ByVal hSrcDC As int, ByVal xSrc As int, ByVal ySrc As int, ByVal dwRop As int) As int
'use corewin
'create window
INT win
INT x=200,y=220,w=600,h=480,wstyle = WS_MINMAXSIZE
'context menu
% WM_CONTEXTMENU = 123
INT richMenu , mousex , mousey, submenu1
win = SetWindow("RichEdit control ",x,y,w,h,0,wstyle)
''load menu bitmaps
INT mImg1 = LoadImage(0, "imgData\mImg1.bmp", 0, 16, 16, 24)
INT mImg2 = LoadImage(0, "imgData\mImg2.bmp", 0, 16, 16, 24)
INT mImg3 = LoadImage(0, "imgData\mImg3.bmp", 0, 16, 16, 24)
INT mImg4 = LoadImage(0, "imgData\mImg4.bmp", 0, 16, 16, 24)
'print "img:" str (mImg1)
INT button0,b0ID=100
button0 = SetButton(win,18,4,80,26,"OPEN (X)",0x50001000,0x200,b0ID)
'richedit
INT hRich
int richID = 400
hRich = SetRichEdit (win, 20,50,500,380,"", 1412518084, 0x200, richID)
'set font & back color
ControlFont(hRich, 16, 8, 400, "Courier New") : SetRichEditBackColor hRich, RGB(240,234,180)
'create margin on richedit control
% MARGIN_X = 70
SendMessage hRich, EM_SETMARGINS, EC_LEFTMARGIN, MARGIN_X
INT editProc = GetWindowLong( hrich, GWL_WNDPROC)
'subclass richedit to his own callback function
SetWindowLong(hRich, GWL_WNDPROC, @editCallback)
'init context popup_menu and set client rect to richedit
RECT rcRE
RichEditPopUpMenu()
'load menu bitmaps
Wait() 'message loop
'main window callback function ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
Function WndProc (sys hwnd,wmsg,wparam,lparam) as int callback
win = hwnd
SELECT hwnd
CASE win
Select wmsg
Case WM_CREATE
Case WM_CONTEXTMENU
mousex = LoWord(lParam) : mousey = HiWord(lParam) 'get mouse coordinate
GetClientRect(hRich, rcRE)
TrackPopupMenu (richMenu, 0, mousex, mousey, 0, hRich, rcRE ) 'put context menu where mouse is
'TrackPopupMenu (hMenu As INT, wFlags As INT, x As INT, y As INT, nReserved As INT, hwnd As INT, lprc As RECT) As INT
Case WM_CLOSE
CloseWindow(win)
EndProgram()
End Select
END SELECT
Return Default
End Function
'~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~11
'richedit callback function
Function editCallback(sys hwnd , uMsg, wParam , lParam ) as int callback
POINTAPI pt
CHAR sz[16]
DWORD lc
RECT crect
INT rgn
int dret
INT hDC
int line
int charpos
dret = CallWindowProc( editProc,hWnd, uMsg,wParam,lParam)
if uMsg = WM_PAINT
lc=SendMessage(hwnd,EM_GETLINECOUNT,0,0)
if lc
hDC = GetDC(hwnd)
SaveDC(hDC)
GetClientRect(hwnd, crect)
rgn = CreateRectRgn(crect.left,crect.top,crect.right,crect.bottom)
SelectClipRgn(hDC,rgn)
';fnx br = SelectObject,ebx,rv(CreateSolidBrush,bkColor)
'% PATCOPY 0x00F00021
BitBlt (hDC,00,0,MARGIN_X,crect.bottom, hDC,0,0,PATCOPY)
';fn DeleteObject,rv(SelectObject,ebx,br)
line=SendMessage(hwnd,EM_GETFIRSTVISIBLELINE,0,0)
while line <= lc
charpos = SendMessage(hwnd,EM_LINEINDEX,line,0)
exit if charpos == -1
SendMessage(hwnd,EM_POSFROMCHAR,&pt,charpos)
exit if pt.y > crect.bottom
'wide char
wsprintf(&sz,"%lu",line+1)
TextOut(hDC,40,pt.y,sz,len(sz))
line++
wend
RestoreDC(hDC,-1)
DeleteObject(rgn)
ReleaseDC(hwnd,hDC)
end if
end if
return dret
'else
Return CallWindowProc (editProc, hwnd, uMsg, wParam, lParam)
End Function
'
SUB RichEditPopUpMenu()
richMenu = CreatePopupMenu ()
'addsub menu items with ID
AppendMenu (richMenu, 0, 700, strptr "CUT")
SetMenuItemBitmaps(richMenu, 0 , MF_BYPOSITION , mImg1, 0) 'add menu item bitmap
AppendMenu (richMenu, 0, 701, strptr "COPY")
SetMenuItemBitmaps(richMenu, 1, MF_BYPOSITION , mImg2, 0)
AppendMenu (richMenu, 0, 702, strptr "PASTE")
SetMenuItemBitmaps(richMenu, 2, MF_BYPOSITION , mImg3, 0)
AppendMenu (richMenu, 0, 703, strptr "SELECT_ALL")
SetMenuItemBitmaps(richMenu, 3, MF_BYPOSITION , mImg4, 0)
END SUB
-
Open button replaced with iconButton:
I just draw one in aWiconsLite, also i add resizing of richedit control.
INT button1, b1ID = 100 : % ICONBUTTON = 1409351744
button1 = SetButton(win,10,2,48,48,"", ICONBUTTON, 0,b1ID)
INT icon1 = LoadImage(0, "imgData\icOpen.ico", 1, 32, 32, 24) 'load icon...
SendMessage( button1, 247, 1, icon1) 'add icon to button...
-
Here is a version where cut/copy/paste/selectAll work
under editCallback function
PS.Charles...it looks to me that latest 0.2.8 have some problems with simple
new line comment with '
inside if /end if block
must be something with lexer?
$ Filename "ARichLN.exe" ' Oxygen Basic v0.2.8 / Aurel 28.2.2020
Include "RTL32.inc"
Include "awinh037.inc"
#lookahead
'api calls for subclasing + some GDI functions(! you can put it inside include file)
! CallWindowProc Lib "user32.dll" Alias "CallWindowProcA"(sys pPrevWndFunc ,hWnd ,uMsg ,wParam ,lParam ) as int
! GetDlgItem Lib "user32.dll" Alias "GetDlgItem" (ByVal hDlg As INT, ByVal nIDDlgItem As INT) As INT
! GetTextMetrics Lib "gdi32.dll" Alias "GetTextMetricsA" (ByVal hdc As Long, lpMetrics As TEXTMETRIC) As Long
'! DrawText Lib "user32.dll" Alias "DrawTextA" (ByVal hdc As Long, ByVal lpStr As String, ByVal nCount As Long, lpRect As RECT, ByVal wFormat As Long) As Long
! GetCaretPos Lib "user32.dll" Alias "GetCaretPos"(lpPoint AS POINTAPI) as INT
! wsprintf Lib "user32.dll" Alias "wsprintfA" (ByVal lpzBuffer as sys, ByVal lpzFormat As String, Byval Number as int) As int
! SaveDC Lib "gdi32.dll" (ByVal hdc As int) As int
! RestoreDC Lib "gdi32.dll" (ByVal hdc As int, ByVal nSavedDC As int) As sys
! CreateRectRgn Lib "gdi32.dll" (ByVal X1 As int, ByVal Y1 As int, ByVal X2 As int, ByVal Y2 As int) As int
! SelectClipRgn Lib "gdi32.dll" (ByVal hdc As int, ByVal hRgn As int) As int
'use corewin
! GetWindowLong Lib "user32.dll" Alias "GetWindowLongA" (ByVal hctl As int, ByVal nIndex As int) As int
! SetWindowLong Lib "user32.dll" Alias "SetWindowLongA" (ByVal hctl As int, ByVal nIndex As int, byval dwNewLong As int) As int
! GetSystemMenu Lib "user32.dll" (ByVal hwnd As Int, ByVal revert As Int) As Int
! EnableMenuItem Lib "user32.dll" (ByVal menu As Int, ByVal IDeEnableItem As Int, ByVal enable As Int) As Int
'declare function GetWindowLongPtr Lib "user32.dll" Alias "GetWindowLongPtrA"(ByVal hctl As Long, ByVal gwlData As Long) As int
'declare function SetWindowLongPtr Lib "user32.dll" Alias "SetWindowLongPtrA" (ByVal hctl As long, ByVal nIndex As Long, dwNewLong As sys) As int
! BitBlt Lib "gdi32.dll" (ByVal hDestDC As int, ByVal x As int, ByVal y As int, ByVal nWidth As int, ByVal nHeight As int, ByVal hSrcDC As int, ByVal xSrc As int, ByVal ySrc As int, ByVal dwRop As int) As int
'use corewin
'create window
INT win
INT x=200,y=220,w=800,h=600,wstyle = WS_MINMAXSIZE
'context menu
% WM_CONTEXTMENU = 123
INT richMenu , mousex , mousey, submenu1
win = SetWindow("RichEdit control ",x,y,w,h,0,wstyle)
''load menu bitmaps...
INT mImg1 = LoadImage(0, "imgData\mImg1.bmp", 0, 16, 16, 24)
INT mImg2 = LoadImage(0, "imgData\mImg2.bmp", 0, 16, 16, 24)
INT mImg3 = LoadImage(0, "imgData\mImg3.bmp", 0, 16, 16, 24)
INT mImg4 = LoadImage(0, "imgData\mImg4.bmp", 0, 16, 16, 24)
'buttons init...............................................................................
'icon button -> 1409351744 , normal -> 0x50001000
'IconButton( bhwnd ,_bx , _by , _bw, _bh, _ibicon , _bflag , _ext , _cID )
INT button1, b1ID = 100 : % ICONBUTTON = 1409351744
button1 = SetButton(win,10,2,48,48,"", ICONBUTTON, 0,b1ID)
INT icon1 = LoadImage(0, "imgData\icOpen.ico", 1, 32, 32, 24) 'load icon...
SendMessage( button1, 247, 1, icon1) 'add icon to button...
'richedit...................................................................................
INT hRich : INT richID = 400 : INT rx = 10,ry = 54, rw = 600, rh = 480
hRich = SetRichEdit (win, rx, ry, rw, rh,"", 1412518084, 0x200, richID)
'set font & back color...
ControlFont(hRich, 16, 8, 400, "Consolas") : SetRichEditBackColor hRich, RGB(240,234,180)
'create margin on richedit control...
% MARGIN_X = 70
SendMessage hRich, EM_SETMARGINS, EC_LEFTMARGIN, MARGIN_X
INT editProc = GetWindowLong( hrich, GWL_WNDPROC)
'subclass richedit to his own callback function
SetWindowLong(hRich, GWL_WNDPROC, @editCallback)
'init context popup_menu and set client rect to richedit
RECT rcRE
RichEditPopUpMenu()
'enable menu items - MF_ENABLED = 0
EnableMenuItem ( richMenu, 700, 0)
'load menu bitmaps
Wait() 'message loop
'main window callback function ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
Function WndProc (sys hwnd,wmsg,wparam,lparam) as int callback
win = hwnd
SELECT hwnd
CASE win
SELECT wmsg
Case WM_COMMAND
controlID = LoWord(wParam) 'get control ID
notifyCode = HiWord(wParam) 'get notification message
Select controlID
CASE b1ID
'open file
If notifycode=0
MsgBox "Open File","Open"
End If
End Select
'----------------------------------------------------------------------------------------------
Case WM_CONTEXTMENU
mousex = LoWord(lParam) : mousey = HiWord(lParam) 'get mouse coordinate
GetClientRect(hRich, rcRE)
TrackPopupMenu (richMenu, 0, mousex, mousey, 0, hRich, rcRE ) 'put context menu where mouse is
'TrackPopupMenu (hMenu As INT, wFlags As INT, x As INT, y As INT, nReserved As INT, hwnd As INT, lprc As RECT) As INT
Case WM_CLOSE
CloseWindow(win)
EndProgram()
Case WM_SIZE
GetSize(win,x,y,w,h)
MoveWindow(hRich, 10, 54, (w-rw/2)+114, (h-36)-32 , 1)
END SELECT
END SELECT
Return Default
End Function
'~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~11
'richedit callback function
Function editCallback(sys hwnd , uMsg, wParam , lParam ) as int callback
POINTAPI pt
CHAR sz[16]
DWORD lc
RECT crect
INT rgn
int dret
INT hDC
int line
int charpos
dret = CallWindowProc( editProc,hWnd, uMsg,wParam,lParam)
if uMsg = WM_PAINT
lc=SendMessage(hwnd,EM_GETLINECOUNT,0,0)
if lc
hDC = GetDC(hwnd)
SaveDC(hDC)
GetClientRect(hwnd, crect)
rgn = CreateRectRgn(crect.left,crect.top,crect.right,crect.bottom)
SelectClipRgn(hDC,rgn)
BitBlt (hDC,00,0,MARGIN_X,crect.bottom, hDC,0,0,PATCOPY)
line=SendMessage(hwnd,EM_GETFIRSTVISIBLELINE,0,0)
while line <= lc
charpos = SendMessage(hwnd,EM_LINEINDEX,line,0)
exit if charpos == -1
SendMessage(hwnd,EM_POSFROMCHAR,pt,charpos)
exit if pt.y > crect.bottom
'wide char
wsprintf(&sz,"%lu",line+1)
TextOut(hDC,40,pt.y,sz,len(sz))
line++
wend
RestoreDC(hDC,-1)
DeleteObject(rgn)
ReleaseDC(hwnd,hDC)
end if
elseif uMsg = WM_COMMAND
select wparam
case 700 : SendMessage(hwnd,WM_CUT,0,0)
case 701 : SendMessage(hwnd,WM_COPY,0,0)
case 702 : SendMessage(hwnd,WM_PASTE,0,0)
case 703 : SendMessage(hwnd,EM_SETSEL ,0,-1)
end select
end if
return dret
Return CallWindowProc (editProc, hwnd, uMsg, wParam, lParam)
End Function
'
SUB RichEditPopUpMenu()
richMenu = CreatePopupMenu ()
'addsub menu items with ID
AppendMenu (richMenu, 0, 700, strptr "CUT")
SetMenuItemBitmaps(richMenu, 0 , MF_BYPOSITION , mImg1, 0) 'add menu item bitmap
AppendMenu (richMenu, 0, 701, strptr "COPY")
SetMenuItemBitmaps(richMenu, 1, MF_BYPOSITION , mImg2, 0)
AppendMenu (richMenu, 0, 702, strptr "PASTE")
SetMenuItemBitmaps(richMenu, 2, MF_BYPOSITION , mImg3, 0)
AppendMenu (richMenu, 0, 703, strptr "SELECT_ALL")
SetMenuItemBitmaps(richMenu, 3, MF_BYPOSITION , mImg4, 0)
END SUB
-
Hi Aurel,
Can you show me the problem you had with comments in an if block?
-
Hello Charles
Yes of course and i think is the best to show you a image when error jump.
it looks to me like o2 recognize elseif under commented line ?
I just guess...
-
I myself would code:
if <condition> then exit while
I am also used to code (though not mandatory):
if <condition> then
-
Aurel,
The error message indicates youhave a wrong declaration for CreateRectRgn. If you use corewin then you won't need one.
-
Aurel,
The error message indicates youhave a wrong declaration for CreateRectRgn. If you use corewin then you won't need one.
Ok Charles ,
but what commented 'elseif have with api function
IF is written as is in code semple then work without problem...and that is strange.