OpenEuphoria

Pastey demo/win32/window w/memstruct w/font change

• Posted by ne1uno Dec 06, 2011

--****  
-- === win32/window.exw  
--  
-- A Standard Windows Window coded at the primitive API level  
-- Most Euphoria programmers should simply use Win32Lib, wxWidgets, EuGTK or EuIUP!  
--  
 
include std/os.e  
include std/machine.e  
include std/dll.e  
include std/math.e  
include std/error.e  
include std/console.e 
 
--****  
-- === Windows Data Type constants for function/procedure calls 
 
public constant  
	C_BYTE = C_UCHAR,   
	C_BOOL = C_INT,  
	C_ATOM = C_USHORT,  
	C_WORD = C_USHORT,  
	C_DWORD=  C_ULONG,  
	C_WPARAM = C_POINTER,  
	C_LPARAM = C_POINTER,  
	C_HANDLE = C_POINTER,  
	C_HWND = C_POINTER,  
	C_LPSTR = C_POINTER,  
	C_COLORREF =  C_DWORD,    --0x00bbggrr  
	C_LANGID =  C_WORD,    
	$  
 
public constant C_LONG_PTR = C_POINTER 
 
public constant C_LRESULT = C_LONG_PTR  
 
--****  
-- === Windows Type constants for structs  
 
public memtype   
	char as BYTE,  
	int as BOOL,  
	int as INT,  
	unsigned int as UINT, 
	long as LONG,  
	unsigned long as ULONG,  
	double as DOUBLE,  
	short as WORD,  
	long as DWORD,  
	object as HANDLE,  
	object as HWND,  
	object as LPSTR,  
	object as WNDPROC, 
	object as WPARAM, 
	object as LPARAM, 
	$  
 
memstruct WNDCLASSEX  
	UINT cbSize  
	UINT style  
	WNDPROC lpfnWndProc  	--WNDPROC  
	INT cbClsExtra  
	INT cbWndExtra  
	HANDLE hInstance  	--HINSTANCE  
	HANDLE hIcon   		--HICON  
	HANDLE hCursor  	--HCURSOR  
	HANDLE hbrBackground 	--HBRUSH  
	LPSTR lpszMenuName  	--LPCSTR  
	LPSTR lpszClassName	--LPCSTR  
	HANDLE hIconSm		--HICON  
end memstruct  
 
memstruct POINT 
	LONG x 
	LONG y 
end memstruct 
 
memstruct RECT 
	LONG left 
	LONG top 
	LONG right 
	LONG bottom 
end memstruct 
 
memstruct PAINTSTRUCT  
	HANDLE hdc		--HDC  
	BOOL fErase  
	RECT rcPaint		--RECT  
	BOOL fRestore  
	BOOL fIncUpdate  
	BYTE rgbReserved[32]	--BYTE,32  
end memstruct  
 
memstruct MSG 
	HWND hwnd 
	UINT message 
	WPARAM wParam 
	LPARAM lParam 
	DWORD time 
	POINT pt 
end memstruct  
 
 
 
--from Mike Duffy Units 
-- create_font(hdc,"Courier New",12,FW_BOLD,0,0,0)  
 
public function create_font(atom hdc, sequence fontname="Veranda", 
	integer points=12, 
	integer weight=0, integer fitalic=0, 
	integer funderline=0, integer fstrikeout=0, atom pandf=0 
	) 
	atom hfont, lpszFace, ppi, lfheight 
 
	ppi = c_func(GetDeviceCaps,{hdc,LOGPIXELSY})  
	lfheight = -(floor((points*ppi)/72)) 
	lpszFace = allocate_string(fontname, 1) 
	hfont = c_func(CreateFont, 
		{lfheight,	-- logical height of font  
		 0,			-- logical average character width  
		 0,			-- angle of escapement  
		 0,			-- base-line orientation angle  
		 weight,		-- font weight  
		 fitalic,			-- italic attribute flag  
		 funderline,		-- underline attribute flag  
		 fstrikeout,		-- strikeout attribute flag  
		 DEFAULT_CHARSET,	-- character set identifier  
		 OUT_DEFAULT_PRECIS,	-- output precision  
		 CLIP_DEFAULT_PRECIS,	-- clipping precision  
		 DEFAULT_QUALITY,	-- output quality  
		 or_all({DEFAULT_PITCH,FF_DONTCARE,pandf}),-- 0 pitch and family  
		 lpszFace 			-- pointer to typeface name string  
		} 
	) 
	return hfont 
end function 
 
 
 
constant CS_HREDRAW = 2,  
	CS_VREDRAW = 1  
 
constant SW_SHOWNORMAL = 1  
 
constant WM_CREATE = #01,  
	WM_PAINT  = #0F,  
	WM_DESTROY= #02  
 
constant SND_FILENAME = #00020000,  
	SND_ASYNC    = #00000001  
	 
constant DT_SINGLELINE = #0020,  
	DT_CENTER     = #0001,  
	DT_VCENTER    = #0004  
	 
 
 
constant WS_OVERLAPPED  = #00000000,  
	WS_CAPTION     = #00C00000,  
	WS_SYSMENU     = #00080000,  
	WS_THICKFRAME  = #00040000,  
	WS_MINIMIZEBOX = #00020000,  
	WS_MAXIMIZEBOX = #00010000   
 
constant  
	IDC_ARROW = 32512,  
	IDI_APPLICATION = 3, 
	CW_USEDEFAULT = #80000000,  
	WS_OVERLAPPEDWINDOW = or_all({WS_OVERLAPPED, WS_CAPTION, WS_SYSMENU,  
					WS_THICKFRAME, WS_MINIMIZEBOX,   
				       WS_MAXIMIZEBOX}), 
	WHITE_BRUSH = 0, 
	LTGRAY_BRUSH = 1, 
	GRAY_BRUSH = 2, 
	DKGRAY_BRUSH = 3, 
	BLACK_BRUSH = 4, 
	NULL_BRUSH = 5, 
-- 	HOLLOW_BRUSH = ?, 
	WHITE_PEN = 6, 
	BLACK_PEN = 7, 
	NULL_PEN = 8, 
	OEM_FIXED_FONT = 10, 
	ANSI_FIXED_FONT = 11, 
	ANSI_VAR_FONT = 12, 
	SYSTEM_FONT = 13, 
	DEVICE_DEFAULT_FONT = 14, 
	DEFAULT_PALETTE = 15, 
	SYSTEM_FIXED_FONT = 16, 
 
	STOCK_LAST = 16, 
 
	COLOR_SCROLLBAR = 0, 
	COLOR_BACKGROUND = 1, 
	COLOR_ACTIVECAPTION = 2, 
	COLOR_INACTIVECAPTION = 3, 
	COLOR_MENU = 4, 
	COLOR_WINDOW = 5, 
	COLOR_WINDOWFRAME = 6, 
	COLOR_MENUTEXT = 7, 
	COLOR_WINDOWTEXT = 8, 
	COLOR_CAPTIONTEXT = 9, 
	COLOR_ACTIVEBORDER = 10, 
	COLOR_INACTIVEBORDER = 11, 
	COLOR_APPWORKSPACE = 12, 
	COLOR_HIGHLIGHT = 13, 
	COLOR_HIGHLIGHTTEXT = 14, 
	COLOR_BTNFACE = 15, 
	COLOR_BTNSHADOW = 16, 
	COLOR_GRAYTEXT = 17, 
	COLOR_BTNTEXT = 18, 
	COLOR_INACTIVECAPTIONTEXT = 19, 
	COLOR_BTNHIGHLIGHT = 20, 
 
	LOGPIXELSX = 88, 
	LOGPIXELSY = 90, 
	OUT_DEFAULT_PRECIS = 0, 
	OUT_STRING_PRECIS = 1, 
	OUT_CHARACTER_PRECIS = 2, 
	OUT_STROKE_PRECIS = 3, 
	OUT_TT_PRECIS = 4, 
	OUT_DEVICE_PRECIS = 5, 
	OUT_RASTER_PRECIS = 6, 
	OUT_TT_ONLY_PRECIS = 7, 
	OUT_OUTLINE_PRECIS = 8, 
	OUT_SCREEN_OUTLINE_PRECIS = 9, 
	OUT_PS_ONLY_PRECIS = 10, 
 
	CLIP_DEFAULT_PRECIS = 0, 
	CLIP_CHARACTER_PRECIS = 1, 
	CLIP_STROKE_PRECIS = 2, 
	CLIP_MASK = #F, 
-- 	CLIP_LH_ANGLES = (1<<4), 
 
-- 	CLIP_TT_ALWAYS = (2<<4), 
 
-- 	CLIP_EMBEDDED = (8<<4), 
 
	DEFAULT_QUALITY = 0, 
	DRAFT_QUALITY = 1, 
	PROOF_QUALITY = 2, 
 
	DEFAULT_PITCH = 0, 
	FIXED_PITCH = 1, 
	VARIABLE_PITCH = 2, 
 
	ANSI_CHARSET = 0, 
	DEFAULT_CHARSET = 1, 
	SYMBOL_CHARSET = 2, 
	SHIFTJIS_CHARSET = 128, 
	HANGEUL_CHARSET = 129, 
	HANGUL_CHARSET = 129, 
	GB2312_CHARSET = 134, 
	CHINESEBIG5_CHARSET = 136, 
	OEM_CHARSET = 255, 
 
	FF_DONTCARE = shift_bits(0, -4), 
 
-- 	FF_ROMAN = (1<<4)  , 
 
-- 	FF_SWISS = (2<<4)  , 
 
-- 	FF_MODERN = (3<<4)  , 
 
-- 	FF_SCRIPT = (4<<4)  , 
 
-- 	FF_DECORATIVE = (5<<4)  , 
 
	FW_DONTCARE = 0, 
	FW_THIN = 100, 
	FW_EXTRALIGHT = 200, 
	FW_LIGHT = 300, 
	FW_NORMAL = 400, 
	FW_MEDIUM = 500, 
	FW_SEMIBOLD = 600, 
	FW_BOLD = 700, 
	FW_EXTRABOLD = 800, 
	FW_HEAVY = 900, 
 
-- 	FW_ULTRALIGHT = FW_EXTRALIGHT, 
 
-- 	FW_REGULAR = FW_NORMAL, 
 
-- 	FW_DEMIBOLD = FW_SEMIBOLD, 
 
-- 	FW_ULTRABOLD = FW_EXTRABOLD, 
 
-- 	FW_BLACK = FW_HEAVY, 
	$ 
 
integer LoadIcon, LoadCursor, GetStockObject, RegisterClassEx,  
	CreateWindow, ShowWindow, UpdateWindow, GetMessage,  
	TranslateMessage, DispatchMessage, PlaySound, BeginPaint,  
	GetClientRect, DrawText, EndPaint, PostQuitMessage, DefWindowProc, 
    GetSysColor, SelectObject, SetTextColor, SetBkColor, 
	xGetLastError, xSetLastError, xFormatMessage, 
    GetDeviceCaps, CreateFont 
 
procedure not_found(sequence name)  
	crash( "Couldn't find " & name ) 
end procedure  
 
-- dynamically link a C routine as a Euphoria function  
function link_c_func(atom dll, sequence name, sequence args, atom result)  
	integer handle  
 
	handle = define_c_func(dll, name, args, result)  
	if handle = -1 then  
		not_found(name)  
	else  
		return handle  
	end if  
end function  
 
-- dynamically link a C routine as a Euphoria function  
function link_c_proc(atom dll, sequence name, sequence args)  
	integer handle  
 
	handle = define_c_proc(dll, name, args)  
	if handle = -1 then  
		not_found(name)  
	else  
		return handle  
	end if  
end function  
 
-- get handles to all dll routines that we need  
procedure link_dll_routines()  
	atom user32, gdi32, winmm, kernel32 
	 
	user32 = open_dll("user32.dll")  
	if user32 = NULL then  
		not_found("user32.dll")  
	end if  
	gdi32 = open_dll("gdi32.dll")  
	if gdi32 = NULL then  
		not_found("gdi32.dll")  
	end if  
	winmm = open_dll("winmm.dll")  
	if winmm = NULL then  
	not_found("winmm.dll")  
	end if  
	 
	kernel32 = open_dll( "kernel32.dll") 
	if kernel32 = NULL then 
		not_found("kernel32.dll") 
	end if 
 
	--new code would use LoadImage 
	LoadIcon = link_c_func(user32, "LoadIconA", {C_HANDLE, C_LPSTR}, C_HANDLE)  
	LoadCursor = link_c_func(user32, "LoadCursorA", {C_HANDLE, C_LPSTR}, C_HANDLE)  
 
	GetStockObject = link_c_func(gdi32, "GetStockObject", {C_INT}, C_HANDLE)  
	RegisterClassEx = link_c_func(user32, "RegisterClassExA", {C_POINTER}, C_ATOM)  
	CreateWindow = link_c_func(user32, "CreateWindowExA",   
		{C_DWORD, C_LPSTR, C_LPSTR,C_DWORD,C_INT,C_INT,C_INT,C_INT,  
		C_HWND,C_HANDLE,C_HANDLE, C_POINTER},  
	C_HWND)  
	ShowWindow = link_c_proc(user32, "ShowWindow", {C_HWND, C_INT}) --BOOL  
	UpdateWindow = link_c_proc(user32, "UpdateWindow", {C_HWND}) --BOOL  
	GetMessage = link_c_func(user32, "GetMessageA",   
				{C_LPSTR, C_HWND, C_UINT, C_UINT}, C_BOOL)  
	TranslateMessage = link_c_proc(user32, "TranslateMessage", {C_LPSTR}) --BOOL  
	DispatchMessage = link_c_proc(user32, "DispatchMessageA", {C_LPSTR}) --LRESULT  
	PlaySound = link_c_proc(winmm, "PlaySound", {C_LPSTR, C_HANDLE, C_DWORD}) --BOOL  
	BeginPaint = link_c_func(user32, "BeginPaint", {C_HWND, C_POINTER}, C_HANDLE)  
	GetClientRect = link_c_proc(user32, "GetClientRect", {C_HWND, C_POINTER}) --BOOL  
	DrawText = link_c_proc(user32, "DrawTextA",   
			{C_HANDLE, C_LPSTR, C_INT, C_POINTER, C_UINT})  --INT  
	EndPaint = link_c_proc(user32, "EndPaint", {C_HWND, C_POINTER}) --BOOL  
	PostQuitMessage = link_c_proc(user32, "PostQuitMessage", {C_INT})  
	DefWindowProc = link_c_func(user32, "DefWindowProcA",   
				{C_HWND, C_UINT, C_WPARAM, C_LPARAM}, C_LRESULT)  
 
    GetSysColor = link_c_func(user32, "GetSysColor", {C_INT}, C_DWORD) 
 
    SelectObject = link_c_func(gdi32, "SelectObject", {C_HANDLE, C_HANDLE}, C_HANDLE) 
    SetTextColor = link_c_func(gdi32, "SetTextColor", {C_HANDLE, C_COLORREF}, C_COLORREF) 
    SetBkColor = link_c_func(gdi32, "SetBkColor", {C_HANDLE, C_COLORREF}, C_COLORREF) 
 
    GetDeviceCaps = link_c_func(gdi32, "GetDeviceCaps", {C_HANDLE, C_INT}, C_INT) 
    CreateFont = link_c_func(gdi32, "CreateFontA", { 
		C_INT, C_INT, C_INT, C_INT, C_INT, C_DWORD, C_DWORD, C_DWORD, 
		C_DWORD, C_DWORD, C_DWORD, C_DWORD, C_DWORD, C_LPSTR 
	}, 
	C_HANDLE) 
 
end procedure  
 
link_dll_routines()  
 
atom  
 --get_env(media?) 
 wav_file = allocate_string(getenv("Windir")&`\Media\tada.wav`), 
 Euphoria = allocate_string("A Plain Vanilla Window using Euphoria!"), 
 my_title = allocate_string("Euphoria for WINDOWS"), 
 $ 
 
 
 
-- callback routine to handle Window class  
public function WndProc(atom hwnd, atom iMsg, atom wParam, atom lParam)  
	 
	if iMsg = WM_CREATE then  
		c_proc(PlaySound, {wav_file,  
				NULL,  
				or_bits(SND_FILENAME, SND_ASYNC)})  
		return 0  
	 
	elsif iMsg = WM_PAINT then  
		atom 
			hdc, 
			oldFont, 
			hCtrlFont, 
			ps = allocate( sizeof(PAINTSTRUCT), 1), 
			rect = allocate( sizeof(RECT), 1) 
 
		hdc = c_func(BeginPaint, {hwnd, ps})  
		c_proc(GetClientRect, {hwnd, rect})  
		hCtrlFont = create_font(NULL,"Verdana",12,FW_BOLD,0,0,0,0) 
	 
		--oldFont = c_func(SelectObject, {hdc, c_func(GetStockObject, {ANSI_VAR_FONT}) }) 
		oldFont = c_func(SelectObject, {hdc, hCtrlFont }) 
		c_func(SetTextColor, {hdc, c_func(GetSysColor, {COLOR_BTNTEXT}) }) 
		c_func(SetBkColor, {hdc, c_func(GetSysColor, {COLOR_BTNFACE}) }) 
 
		c_proc(DrawText, {hdc, Euphoria, -1, rect,   
				or_all({DT_SINGLELINE, DT_CENTER, DT_VCENTER})})  
		c_proc(EndPaint, {hwnd, ps})  
	return 0  
	 
	elsif iMsg = WM_DESTROY then  
		c_proc(PostQuitMessage, {0})  
		return 0  
	end if  
	 
    return c_func(DefWindowProc, {hwnd, iMsg, wParam, lParam}) 
end function  
 
 
procedure WinMain()  
-- main routine   
	atom szAppName  
	atom hwnd  
	atom msg  
	atom wndclass  
	atom WndProcAddress  
	atom class  
	integer id  
	atom icon_handle  
 
	wndclass = allocate( sizeof(WNDCLASSEX), 1)  
	msg = allocate( sizeof(MSG), 1)  
	szAppName = allocate_string("winhello", 1)  
 
	id = routine_id("WndProc")  
	if id = -1 then  
		crash( "routine_id failed!")  
	end if  
	WndProcAddress = call_back(id) -- get address for callback  
	 
	wndclass.WNDCLASSEX.cbSize      = sizeof(WNDCLASSEX)  
	wndclass.WNDCLASSEX.style       = or_bits(CS_HREDRAW, CS_VREDRAW)  
	wndclass.WNDCLASSEX.lpfnWndProc = WndProcAddress  
	wndclass.WNDCLASSEX.cbClsExtra  = 0  
	wndclass.WNDCLASSEX.cbWndExtra  = 0  
	wndclass.WNDCLASSEX.hInstance   = 0  
 
	-- set icon in top-left of window  
	icon_handle = c_func(LoadIcon, {instance(), allocate_string( "eui", 1)})  
	if icon_handle = 0 then 
		c_proc( xSetLastError, {0} ) 
		icon_handle = c_func(LoadIcon, {NULL, IDI_APPLICATION})  
	end if 
	wndclass.WNDCLASSEX.hIcon   = icon_handle  
	wndclass.WNDCLASSEX.hIconSm = icon_handle  
	 
	-- Wolfgang Fritz observes that you can set an icon  
	-- dynamically using:  
	-- sendMessage(YourWindow, WM_SETICON, 1, icon_handle)   
	-- where WM_SETICON is 128 
	 
	wndclass.WNDCLASSEX.hCursor       = c_func(LoadCursor, {NULL, IDC_ARROW})  
	wndclass.WNDCLASSEX.hbrBackground = c_func(GetStockObject, {WHITE_BRUSH})  
	wndclass.WNDCLASSEX.lpszMenuName  = NULL  
	wndclass.WNDCLASSEX.lpszClassName = szAppName  
 
	class = c_func(RegisterClassEx, {wndclass})  
	if class = 0 then  
		crash("could not register class") 
	end if  
	hwnd = c_func(CreateWindow, {  
			0,                       -- extended style  
			szAppName,               -- window class name  
			my_title,                -- window caption  
			WS_OVERLAPPEDWINDOW,     -- window style  
			CW_USEDEFAULT,           -- initial x position  
			CW_USEDEFAULT,           -- initial y position  
			CW_USEDEFAULT,           -- initial x size  
			CW_USEDEFAULT,           -- initial y size  
			NULL,                    -- parent window handle  
			NULL,                    -- window menu handle  
			0 ,                 --hInstance // program instance handle  
			NULL})              -- creation parameters  
	if hwnd = 0 then  
		crash("Couldn't CreateWindow")  
	end if  
	c_proc(ShowWindow, {hwnd, SW_SHOWNORMAL})  
	c_proc(UpdateWindow, {hwnd})  
 
	while c_func(GetMessage, {msg, NULL, 0, 0}) do  
		c_proc(TranslateMessage, {msg})  
		c_proc(DispatchMessage, {msg})  
	end while  
end procedure  
 
WinMain()