It works but it leaves blank lines at the start, and line spacing too much. I think I can fix that.
You stated you think I could also do this with normal scroll bars by using the position of the scroller. I will try.
It works but it leaves blank lines at the start, and line spacing too much. I think I can fix that.
Code: Select all
'CODE BY UEZ, added some vertical scrolling
#include once "windows.bi"
#include "crt.bi"
Dim As MSG msg ' Message variable (stores massages)
Dim Shared As HWND hWndx, stc1, stc2 ' Window variable and object variables
Dim As HFONT xFont1, xFont2
Function WNDPROC(Byval hWnd As HWND, Byval uMsg As UINT, Byval wParam As WPARAM, Byval lParam As LPARAM) As LRESULT
Select Case Loword(wParam)
Case SB_THUMBTRACK
var p = Hiword(wParam)
MoveWindow(stc1,0,50-p,300,15,true)
MoveWindow(stc2,0,50+25-p,300,15,true)
SetScrollPos(hwnd,SB_VERT,p,true)
printf(!"%d\n",p)
End Select
Select Case uMsg
Case WM_DESTROY
PostQuitMessage(NULL)
Return 0
Case WM_LBUTTONDOWN
'dim as point p
'dim as lprect r
' getclientrect hwnd,r
'getcursorpos(@p)
'Screentoclient(hWnd, @p)
'printf(!"%d\n",hiword(wparam))
' beep
Case WM_CTLCOLORSTATIC
Dim As HDC hdcStatic = Cast(HDC, wParam)
Select Case lParam
Case stc1
SetTextColor(hdcStatic, &hFF0000) 'BGR
SetBkColor(hdcStatic, GetSysColor(COLOR_WINDOW))
Return Cast(INT_PTR, (GetSysColorBrush(COLOR_WINDOW)))
Case stc2
SetTextColor(hdcStatic, &h0000FF) 'BGR
SetBkColor(hdcStatic, GetSysColor(COLOR_WINDOW))
Return Cast(INT_PTR, (GetSysColorBrush(COLOR_WINDOW)))
End Select
Case Else
' getcursorpos
'Return 0
End Select
Return DefWindowProc(hWnd, uMsg, wParam, lParam)
End Function
Dim As WNDCLASS WinCls
#ifdef unicode
Dim szClassName As WString * 64
Dim szCaption As WString * 64
#else
Dim szClassName As ZString * 64
Dim szCaption As ZString * 64
#endif
szClassName = "FB_GUI"
With WinCls
.style = CS_HREDRAW Or CS_VREDRAW
.lpfnWndProc = Cast(WNDPROC, @WNDPROC)
.hInstance = GetModuleHandle(NULL)
.hIcon = LoadIcon(NULL, IDI_APPLICATION)
.hCursor = LoadCursor(NULL, IDC_ARROW)
.hbrBackground = GetSysColorBrush(COLOR_3DFACE) 'GetStockObject(WHITE_BRUSH)
.lpszMenuName = NULL
.lpszClassName = Strptr(szClassName)
End With
If RegisterClass(@WinCls) = False Then
MessageBox(NULL, "RegisterClass('WindowClass') FAIL!", "Error!", MB_OK Or MB_ICONERROR)
End
End If
' Create window
hWndx = CreateWindowEx( 0, szClassName, "", WS_OVERLAPPEDWINDOW Or WS_VISIBLE Or WS_VSCROLL , 100, 100, 500, 300, 0, 0, 0, 0 )
' Create 1st Static box
stc1 = CreateWindowEx( 0, "STATIC", "Line 1", WS_VISIBLE Or WS_CHILD, 0, 50, 300, 15, hWndx, 0, 0, 0 )
xFont1 = CreateFont(20, 0, 0, 0, FW_BOLD, 0, 0, 0, ANSI_CHARSET, False, False, DEFAULT_QUALITY, DEFAULT_PITCH Or FF_ROMAN, "Courier New")
SendMessage(stc1, WM_SETFONT, Cast(WPARAM, xFont1), True)
' Create 2nd static box
stc2 = CreateWindowEx( 0, "STATIC", "Line 2", WS_VISIBLE Or WS_CHILD, 0, 50+25, 300, 15, hWndx, 0, 0, 0 )
xFont2 = CreateFont(20, 0, 0, 0, FW_BOLD, 0, 0, 0, ANSI_CHARSET, False, False, DEFAULT_QUALITY, DEFAULT_PITCH Or FF_ROMAN, "Courier New")
SendMessage(stc2, WM_SETFONT, Cast(WPARAM, xFont2), True)
Dim As MSG uMsg
While GetMessage(@uMsg, 0, 0, 0)
TranslateMessage(@uMsg)
DispatchMessage(@uMsg)
Wend
DeleteObject(xFont1)
DeleteObject(xFont2)
Here it's :
Code: Select all
#Include Once "win\richedit.bi"
#Include Once "windows.bi"
Dim Shared richedit As HWND
Dim Shared clrrichedit As Integer=&hFFFFFF 'background color white
Declare Function fb_RichEdit (t As String,h As HWND,i As Integer,x As Integer,y As Integer,w As Integer,h As Integer,s As Integer=0,x As Integer=-1) As HWND
private function fb_RichEdit(Text As String,hWnd As HWND,id As Integer,X As Integer,Y As Integer,W As Integer, _
H As Integer,Style As Integer,Exstyle As Integer) As HWND
if LoadLibrary("RICHED20.DLL")=0 then
'todo fb_message("LOADLIBRARY ERROR","riched20.dll",MB_SYSTEMMODAL)
End If
Dim A As HWND
If Style=0 Then ' or WS_CLIPSIBLINGS
Style=WS_CHILD Or WS_VISIBLE Or ES_NOHIDESEL Or ES_READONLY Or _
WS_HSCROLL Or WS_VSCROLL Or ES_MULTILINE Or _
ES_AUTOVSCROLL Or ES_AUTOHSCROLL Or ES_WANTRETURN
End If
If Exstyle=-1 Then
Exstyle=WS_EX_CLIENTEDGE
End If
A=CreateWindowEx(Exstyle,"RichEdit20W",NULL,Style,X,Y,W,H,hWnd,Cast(HMENU,id),null,NULL)'
'''SetWindowRTFText(A,Text)
SendMessage(A,WM_SETFONT,Cast(WPARAM,GetStockObject(DEFAULT_GUI_FONT)),0)
Function=A
End Function
private function fb_setcolor(h As HWND,s As Integer,c As Integer,d As Integer) As Integer
'''#define WM_USER &h0400
'''#define EM_SETCHARFORMAT 1092 'wm_user+68
''#define CFM_COLOR &h40000000
''#define SCF_SELECTION 1
''#define SCF_WORD 2
''#define SCF_DEFAULT 0
''#define SCF_ALL 4
''#define CFE_AUTOCOLOR 1073741824
Dim lpcharformat As CHARFORMAT,selt As Integer
Select Case s
Case 0
selt=0 'set to the default format
Case 1
selt=SCF_ALL 'Applies the formatting to all text in the control.
Case 2
selt=SCF_SELECTION 'Applies the formatting to the current selection.
Case 3
selt=SCF_WORD Or SCF_SELECTION 'Applies the formatting to the selected word or words.
End Select
lpcharformat.cbsize=Len(charformat)
lpcharformat.crtextcolor=c
lpcharformat.dwmask= CFM_UNDERLINE Or CFM_BOLD Or CFM_COLOR Or CFM_ITALIC
If d=1 Then
lpcharformat.dweffects=CFE_AUTOCOLOR
ElseIf d=2 Then
lpcharformat.dweffects=CFE_UNDERLINE Or CFE_BOLD 'Or STRIKEOUT'
ElseIf d=3 Then
' lpcharformat.dweffects=CFE_ITALIC
End If
If sendmessage(h,EM_SETCHARFORMAT,selt,Cast(LPARAM,@lpcharformat))=0 Then
'todo fb_message("ERROR","Set color format")
Return FALSE
Else
Return TRUE
End If
End Function
private sub sel_line(l As Integer,c As Integer=0,s As Integer=0,h As HWND=richedit)
Dim d As Integer,f As Integer,range As charrange
d=SendMessage ( h , EM_LINEINDEX,l, 0)
f=SendMessage ( h , EM_LINEINDEX,l+1, 0)
range.cpmin=d :range.cpmax=f-1
SendMessage ( h , EM_exSETSEL,0,Cast(LPARAM,@range))
fb_setcolor(h,2,c,s)
SendMessage(h,EM_HIDESELECTION,1,0)
End Sub
#INCLUDE ONCE "windows.bi"
#Include "/win/commctrl.bi"
Dim As MSG msg ' Message variable (stores massages)
Dim As HWND hWndx, stc1 ' Window variable and object variables
DIM AS HFONT xFont
' Create window
hWndx = CreateWindowExa( 0, "#32770", "", WS_OVERLAPPEDWINDOW Or WS_VISIBLE or WS_VSCROLL, 100, 100, 500, 300, 0, 0, 0, 0 )
' Create 1st static box
stc1 = CreateWindowExa( 0, "STATIC", "Line 1", WS_VISIBLE Or WS_CHILD, 0, 0, 300, 15, hWndx, 0, 0, 0 )
xFont = CreateFonta(20, 0, 0, 0, FW_BOLD, 0, 0, 0, ANSI_CHARSET, FALSE, FALSE, DEFAULT_QUALITY, DEFAULT_PITCH OR FF_ROMAN, "Courier New")
SendMessage(stc1, WM_SETFONT, CAST(WPARAM, xFont), True)
' Create 2nd static box
stc1 = CreateWindowExa( 0, "STATIC", "Line 2", WS_VISIBLE Or WS_CHILD, 0, 15, 300, 15, hWndx, 0, 0, 0 )
xFont = CreateFonta(20, 0, 0, 0, FW_BOLD, 0, 0, 0, ANSI_CHARSET, FALSE, FALSE, DEFAULT_QUALITY, DEFAULT_PITCH OR FF_ROMAN, "Courier New")
SendMessage(stc1, WM_SETFONT, CAST(WPARAM, xFont), True)
richedit = fb_RichEdit("fb Edit Box",hwndx,0,3,65,475,100)
'sendmessage(richedit,EM_SETBKGNDCOLOR,0,clrrichedit) ''clear window
'ShowWindow(richedit,SW_SHOW)
setwindowtext(richedit,@("Line in red"+chr(13)+"Line in green"+chr(13)+"Line in blue"))
sel_line(0,&hFF)
sel_line(1,&hFF00)
sel_line(2,&hFF0000)
While GetMessage( @msg, 0, 0, 0 ) ' Get message from window
TranslateMessage( @msg )
DispatchMessage( @msg )
Select Case msg.hwnd
Case hWndx ' If msg is window hwnd: get messages from window
Select Case msg.message
Case 273
End
End Select
End Select
Wend