-- Win32Lib -- "Bleeding Edge" 0.20d -- (c) 1999 David Cuny -- -- This library provides access to the Win32 API from a fairly high -- level, hiding most of the guts from the user. include machine.e include dll.e include msgbox.e -- NEW! need dir() for loadBitmapFromFile include file.e without warning -- with trace object ok ----------------------------------------------------------------------------- ----------------------------------------------------------------------------- -- Generic Tools -- These are routines that I use often enough to wish they were part of -- the standard Euphoria library ----------------------------------------------------------------------------- function equal( object o1, object o2 ) -- return true if objects are equal -- this is more clear than ... compare() = 0 ... -- ex: equal( 10, 10 ) -- --> 1 return not compare( o1, o2 ) end function ----------------------------------------------------------------------------- function findKey( object key, sequence list ) -- return index of sublist with matching key -- ex: findKey( "foo", {{"foo",23}, {"bar",12}, {"grill",24}} ) -- --> 1 for i = 1 to length( list ) do -- NEW! 0.14b changed list[i] to list[i][1] if compare( list[i][1], key ) = 0 then return i end if end for return 0 end function ----------------------------------------------------------------------------- function removeIndex( integer index, sequence list ) -- remove item from list at index postition -- ex: removeIndex( 2, "abcd" ) -- --> "acd" return list[1..index-1] & list[index+1..length(list)] end function ----------------------------------------------------------------------------- function Reverse( sequence s1 ) -- reverse a sequence -- Ex: Reverse( "12345" ) -- --> "54321" sequence s2 s2 = {} for i =length(s1) to 1 by -1 do s2 = append( s2, s1[i] ) end for return s2 end function ----------------------------------------------------------------------------- function iif( atom test, object ifTrue, object ifFalse ) -- returns ifTrue if flag is true, else returns ifFalse -- ex: ? iff( 1, "this", "that" ) -- --> "this" if test then return ifTrue else return ifFalse end if end function ----------------------------------------------------------------------------- ----------------------------------------------------------------------------- -- DLL Links ----------------------------------------------------------------------------- function linkDLL(sequence name) -- dynamically link a DLL atom handle -- open the dll handle = open_dll( name ) if handle = NULL then -- give error and abort ok = message_box( "Couldn't find DLL " & name, "Win32Lib Error", MB_ICONHAND+MB_TASKMODAL ) -- abort abort(1) end if return handle end function ----------------------------------------------------------------------------- global function linkFunc(atom dll, sequence name, sequence args, atom result) -- dynamically link a C routine as a Euphoria function integer handle handle = define_c_func(dll, name, args, result) if handle = -1 then -- give error and abort ok = message_box( "Couldn't link to C function " & name, "Win32Lib Error", MB_ICONHAND+MB_TASKMODAL ) -- abort abort(1) end if return handle end function ----------------------------------------------------------------------------- global function linkProc(atom dll, sequence name, sequence args) -- dynamically link a C routine as a Euphoria function integer handle handle = define_c_proc(dll, name, args) if handle = -1 then -- give error and abort ok = message_box( "Couldn't link to C procedure " & name, "Win32Lib Error", MB_ICONHAND+MB_TASKMODAL ) -- abort abort(1) end if return handle end function -- get handles to all dll routines that we need global atom user32, -- user interface gdi32, -- graphic device interface winmm, -- multi-media comdlg32, -- common dialogs kernel32, -- memory -- NEW! 0.20c added shell32 -- shell extentions -- NEW! 0.14c NT does not have winspool -- winspool -- windows spool file -- link to the dlls user32 = linkDLL("user32.dll") gdi32 = linkDLL("gdi32.dll") winmm = linkDLL("winmm.dll") comdlg32 = linkDLL("comdlg32.dll") kernel32 = linkDLL("kernel32.dll") -- NEW! 0.20c added shell32 = linkDLL("shell32.dll") -- NEW! 0.14c NT does not support winspool -- winspool = linkDLL("winspool.dll") -- NEW! 0.14b rewrite api parameters global constant -- creating windows xLoadIcon = linkFunc(user32, "LoadIconA", {C_POINTER, C_POINTER}, C_POINTER), xLoadCursor = linkFunc(user32, "LoadCursorA", {C_POINTER, C_POINTER}, C_POINTER), xGetStockObject = linkFunc(gdi32, "GetStockObject", {C_INT}, C_POINTER), xRegisterClassEx = linkFunc(user32, "RegisterClassExA", {C_POINTER}, C_POINTER), xUnregisterClass = linkFunc(user32, "UnregisterClassA", {C_POINTER, C_POINTER}, C_LONG), xExtractIcon = linkFunc(shell32, "ExtractIconA", {C_INT, C_POINTER, C_INT}, C_INT), -- xCreateWindow = linkFunc(user32, "CreateWindowExA", {C_LONG,C_POINTER,C_POINTER,C_LONG,C_INT,C_INT,C_INT,C_INT,C_POINTER,C_POINTER,C_POINTER,C_POINTER}, C_POINTER), xCreateWindow = linkFunc(user32, "CreateWindowExA", {C_LONG,C_POINTER,C_POINTER,C_LONG,C_INT,C_INT,C_INT,C_INT,C_POINTER,C_POINTER,C_POINTER,C_POINTER}, C_UINT), xShowWindow = linkFunc(user32, "ShowWindow", {C_POINTER, C_INT}, C_INT), xUpdateWindow = linkProc(user32, "UpdateWindow", {C_POINTER}), -- NEW! 0.14c xSetForegroundWindow = linkFunc(user32, "SetForegroundWindow", {C_POINTER}, C_POINTER ), -- class addresses xGetClassLong = linkFunc(user32, "GetClassLongA", {C_POINTER, C_INT}, C_POINTER), xSetClassLong = linkFunc(user32, "SetClassLongA", {C_POINTER, C_INT, C_LONG}, C_POINTER), -- message passing xGetMessage = linkFunc(user32, "GetMessageA", {C_POINTER,C_POINTER,C_UINT,C_UINT}, C_INT), xTranslateMessage = linkProc(user32, "TranslateMessage", {C_INT}), xDispatchMessage = linkProc(user32, "DispatchMessageA", {C_POINTER}), xSendMessage = linkFunc(user32, "SendMessageA", {C_POINTER, C_UINT, C_LONG, C_LONG}, C_LONG), -- sound support xPlaySound = linkProc(winmm, "PlaySound", {C_INT, C_INT, C_INT}), -- device context xSelectObject = linkFunc(gdi32, "SelectObject", {C_POINTER, C_POINTER}, C_POINTER), xGetClientRect = linkFunc(user32, "GetClientRect", {C_POINTER, C_POINTER}, C_INT), xDrawText = linkProc(user32, "DrawTextA", {C_POINTER,C_POINTER,C_INT,C_POINTER,C_UINT} ), xPostQuitMessage = linkProc(user32, "PostQuitMessage", {C_INT}), xDefWindowProc = linkFunc(user32, "DefWindowProcA", {C_POINTER,C_UINT,C_LONG,C_LONG}, C_POINTER ), xCreateDC = linkFunc(gdi32, "CreateDCA", repeat( C_POINTER, 4 ), C_LONG), -- xGetDC = linkFunc(user32, "GetDC", {C_POINTER}, C_POINTER), xGetDC = linkFunc(user32, "GetDC", {C_POINTER}, C_UINT), xReleaseDC = linkFunc(user32, "ReleaseDC", {C_POINTER, C_POINTER}, C_INT), xMoveToEx = linkFunc(gdi32, "MoveToEx", {C_POINTER, C_INT, C_INT, C_POINTER}, C_LONG), -- update window support xBeginPaint = linkFunc(user32, "BeginPaint", {C_POINTER, C_POINTER}, C_INT), xEndPaint = linkProc(user32, "EndPaint", {C_POINTER, C_POINTER}), xGetUpdateRect = linkFunc(user32, "GetUpdateRect", {C_POINTER, C_POINTER, C_LONG}, C_LONG), xGetUpdateRgn = linkFunc(user32, "GetUpdateRgn", {C_POINTER, C_POINTER, C_LONG}, C_LONG), xExcludeUpdateRgn = linkFunc(user32, "ExcludeUpdateRgn", {C_POINTER, C_POINTER}, C_LONG), xInvalidateRect = linkFunc(user32, "InvalidateRect", {C_POINTER, C_POINTER, C_LONG}, C_LONG), xValidateRect = linkFunc(user32, "ValidateRect", {C_POINTER, C_POINTER}, C_LONG), xInvalidateRgn = linkFunc(user32, "InvalidateRgn", {C_POINTER, C_POINTER, C_LONG}, C_LONG), xValidateRgn = linkFunc(user32, "ValidateRgn", {C_POINTER, C_POINTER}, C_LONG), xRedrawWindow = linkFunc(user32, "RedrawWindow", {C_POINTER, C_POINTER, C_POINTER, C_UINT}, C_LONG), -- graphics xCreatePen = linkFunc(gdi32, "CreatePen", {C_INT, C_INT, C_LONG}, C_LONG), xCreateSolidBrush = linkFunc(gdi32, "CreateSolidBrush", {C_POINTER}, C_LONG), xLineTo = linkFunc(gdi32, "LineTo", {C_POINTER, C_INT, C_INT}, C_LONG), xGetPixel = linkFunc(gdi32, "GetPixel", {C_POINTER, C_INT, C_INT}, C_LONG), xSetPixel = linkFunc(gdi32, "SetPixel", {C_POINTER, C_INT, C_INT, C_LONG}, C_LONG), xRectangle = linkFunc(gdi32, "Rectangle", {C_POINTER, C_INT, C_INT, C_INT, C_LONG}, C_LONG), xRoundRect = linkFunc(gdi32, "RoundRect", {C_POINTER, C_INT, C_INT, C_INT, C_INT, C_INT, C_INT}, C_LONG), xEllipse = linkFunc(gdi32, "Ellipse", {C_POINTER, C_INT, C_INT, C_INT, C_INT}, C_LONG), xArc = linkFunc(gdi32, "Arc", {C_POINTER, C_INT, C_INT, C_INT, C_INT, C_INT, C_INT, C_INT, C_INT}, C_LONG), xChord = linkFunc(gdi32, "Chord", {C_POINTER, C_INT, C_INT, C_INT, C_INT, C_INT, C_INT, C_INT, C_INT}, C_LONG), xPie = linkFunc(gdi32, "Pie", {C_POINTER, C_INT, C_INT, C_INT, C_INT, C_INT, C_INT, C_INT, C_INT}, C_LONG), xPolygon = linkFunc(gdi32, "Polygon", {C_POINTER, C_POINTER, C_INT}, C_LONG), -- timers xSetTimer = linkProc(user32, "SetTimer", {C_POINTER,C_UINT,C_UINT,C_POINTER} ), xKillTimer = linkProc(user32, "KillTimer", {C_POINTER, C_UINT}), -- text xTextOut = linkProc(gdi32, "TextOutA", {C_POINTER, C_INT, C_INT, C_POINTER, C_INT}), xSetWindowText = linkFunc(user32, "SetWindowTextA", {C_POINTER, C_POINTER}, C_INT), xGetWindowText = linkFunc(user32, "GetWindowTextA", {C_POINTER, C_POINTER, C_INT}, C_INT), xGetWindowTextLength= linkFunc(user32, "GetWindowTextLengthA", {C_POINTER}, C_INT), xEnableWindow = linkProc(user32, "EnableWindow", {C_POINTER, C_LONG}), xIsWindowVisible = linkFunc(user32, "IsWindowVisible", {C_POINTER}, C_INT), xIsWindowEnabled = linkFunc(user32, "IsWindowEnabled", {C_POINTER}, C_INT), xGetKeyState = linkFunc(user32, "GetKeyState", {C_INT}, C_INT), xSetFocus = linkProc(user32, "SetFocus", {C_POINTER} ), xGetWindowLong = linkFunc(user32, "GetWindowLongA", {C_POINTER, C_INT}, C_LONG ), xSetWindowLong = linkFunc(user32, "SetWindowLongA", {C_POINTER, C_INT, C_LONG}, C_INT), xCallWindowProc = linkFunc(user32, "CallWindowProcA", {C_POINTER, C_POINTER, C_UINT, C_LONG, C_LONG}, C_LONG), -- menus xLoadMenu = linkFunc(user32, "LoadMenuA", {C_POINTER, C_POINTER}, C_LONG), xLoadMenuIndirect = linkFunc(user32, "LoadMenuIndirectA", {C_POINTER}, C_POINTER), xGetMenu = linkFunc(user32, "GetMenu", {C_POINTER}, C_POINTER), xSetMenu = linkFunc(user32, "SetMenu", {C_POINTER, C_POINTER}, C_LONG), xHiliteMenuItem = linkFunc(user32, "HiliteMenuItem", {C_POINTER, C_POINTER, C_UINT, C_UINT}, C_LONG), xGetMenuString = linkFunc(user32, "GetMenuStringA", {C_POINTER, C_UINT, C_POINTER, C_INT, C_UINT}, C_LONG), xGetMenuState = linkFunc(user32, "GetMenuState", {C_POINTER, C_UINT, C_UINT}, C_LONG), xDrawMenuBar = linkFunc(user32, "DrawMenuBar", {C_POINTER}, C_LONG), xGetSystemMenu = linkFunc(user32, "GetSystemMenu", {C_POINTER, C_LONG}, C_POINTER), xCreateMenu = linkFunc(user32, "CreateMenu", {}, C_POINTER), xCreatePopupMenu = linkFunc(user32, "CreatePopupMenu", {}, C_POINTER), xDestroyMenu = linkFunc(user32, "DestroyMenu", {C_POINTER}, C_LONG), xCheckMenuItem = linkFunc(user32, "CheckMenuItem", {C_POINTER, C_UINT, C_UINT}, C_LONG), xEnableMenuItem = linkFunc(user32, "EnableMenuItem", {C_POINTER, C_UINT, C_UINT}, C_LONG), xGetSubMenu = linkFunc(user32, "GetSubMenu", {C_POINTER, C_INT}, C_POINTER), xGetMenuItemID = linkFunc(user32, "GetMenuItemID", {C_POINTER, C_INT}, C_UINT), xGetMenuItemCount = linkFunc(user32, "GetMenuItemCount", {C_POINTER}, C_INT), xInsertMenu = linkFunc(user32, "InsertMenuA", {C_POINTER, C_UINT, C_UINT, C_UINT, C_POINTER}, C_LONG), xAppendMenu = linkFunc(user32, "AppendMenuA", {C_POINTER, C_UINT, C_UINT, C_POINTER}, C_POINTER), xModifyMenu = linkFunc(user32, "ModifyMenuA", {C_POINTER, C_UINT, C_UINT, C_UINT, C_POINTER}, C_LONG), xRemoveMenu = linkFunc(user32, "RemoveMenu", {C_POINTER, C_UINT, C_UINT}, C_LONG), xDeleteMenu = linkFunc(user32, "DeleteMenu", {C_POINTER, C_UINT, C_UINT}, C_LONG), xSetMenuItemBitmaps = linkFunc(user32, "SetMenuItemBitmaps", {C_LONG, C_UINT, C_UINT, C_POINTER, C_POINTER}, C_LONG), xGetMenuCheckMarkDimensions = linkFunc(user32, "GetMenuCheckMarkDimensions", {}, C_LONG), xTrackPopupMenu = linkFunc(user32, "TrackPopupMenu", {C_POINTER, C_UINT, C_INT, C_INT, C_INT, C_POINTER, C_POINTER}, C_LONG), -- messages xPostMessage = linkFunc(user32, "PostMessageA", {C_POINTER, C_UINT, C_INT, C_LONG}, C_LONG), -- used by EZ_FONT xSaveDC = linkFunc(gdi32, "SaveDC", {C_POINTER}, C_INT), xSetGraphicsMode = linkFunc(gdi32, "SetGraphicsMode", {C_POINTER, C_INT}, C_INT), xModifyWorldTransform = linkFunc(gdi32, "ModifyWorldTransform", {C_POINTER, C_POINTER, C_LONG}, C_LONG), xSetViewportOrgEx = linkFunc(gdi32, "SetViewportOrgEx", {C_POINTER, C_INT, C_INT, C_POINTER}, C_LONG), xSetWindowOrgEx = linkFunc(gdi32, "SetWindowOrgEx", {C_POINTER, C_INT, C_INT, C_POINTER}, C_LONG), xGetDeviceCaps = linkFunc(gdi32, "GetDeviceCaps", {C_POINTER, C_INT}, C_INT), xDPtoLP = linkFunc(gdi32, "DPtoLP", {C_POINTER, C_POINTER, C_INT}, C_LONG), xCreateFontIndirect = linkFunc(gdi32, "CreateFontIndirectA", {C_POINTER}, C_POINTER), xGetTextMetrics = linkFunc(gdi32, "GetTextMetricsA", {C_POINTER, C_POINTER}, C_LONG), xDeleteObject = linkFunc(gdi32, "DeleteObject", {C_POINTER}, C_LONG), xRestoreDC = linkFunc(gdi32, "RestoreDC", {C_POINTER, C_INT}, C_LONG), -- NEW! 0.20a for string size xGetTextExtentPoint = linkFunc(gdi32, "GetTextExtentPoint32A", {C_POINTER, C_POINTER, C_INT, C_POINTER}, C_LONG), -- graphic modes xSetMapMode = linkFunc(gdi32, "SetMapMode", {C_POINTER, C_INT}, C_INT), xGetMapMode = linkFunc(gdi32, "GetMapMode", {C_POINTER}, C_INT), xGetObject = linkFunc(gdi32, "GetObjectA", {C_POINTER, C_INT, C_POINTER}, C_INT), xCreatePalette = linkFunc(gdi32, "CreatePalette", {C_POINTER}, C_POINTER), -- system colors xGetSysColor = linkFunc(user32, "GetSysColor", {C_INT}, C_LONG), xSetSysColors = linkFunc(user32, "SetSysColors", {C_INT, C_POINTER, C_LONG}, C_LONG), -- bitmap graphics xGetWindowExtEx = linkFunc(gdi32, "GetWindowExtEx", {C_POINTER, C_POINTER}, C_LONG), xCreateCompatibleBitmap = linkFunc(gdi32, "CreateCompatibleBitmap", {C_POINTER, C_INT, C_INT}, C_POINTER), xSetBitmapBits = linkFunc(gdi32, "SetBitmapBits", {C_POINTER, C_LONG, C_POINTER}, C_LONG), xSelectPalette = linkFunc(gdi32, "SelectPalette", {C_POINTER, C_POINTER, C_LONG}, C_POINTER), xRealizePalette = linkFunc(gdi32, "RealizePalette", {C_POINTER}, C_UINT), xSetDIBitsToDevice = linkFunc(gdi32, "SetDIBitsToDevice", {C_POINTER, C_INT, C_INT, C_LONG, C_LONG, C_INT, C_INT, C_UINT, C_UINT, C_POINTER, C_POINTER, C_UINT}, C_INT), xStretchDIBits = linkFunc(gdi32, "StretchDIBits", {C_POINTER,C_INT,C_INT,C_INT,C_INT,C_INT,C_INT,C_INT,C_INT,C_POINTER,C_POINTER,C_UINT,C_LONG},C_INT), xBitBlt = linkFunc(gdi32, "BitBlt", {C_POINTER,C_INT,C_INT,C_INT,C_INT,C_POINTER,C_INT,C_INT,C_LONG},C_LONG), -- NEW! 0.15 added SetROP2 xSetROP2 = linkFunc(gdi32, "SetROP2", {C_POINTER, C_LONG}, C_LONG ), xCreateCompatibleDC = linkFunc(gdi32, "CreateCompatibleDC", {C_POINTER}, C_POINTER), xDeleteDC = linkFunc(gdi32, "DeleteDC", {C_POINTER}, C_POINTER), xCreateBitmap = linkFunc(gdi32, "CreateBitmap", {C_INT, C_INT, C_UINT, C_UINT, C_POINTER}, C_POINTER), xCreateBitmapIndirect = linkFunc(gdi32, "CreateBitmapIndirect", {C_POINTER}, C_POINTER), -- NEW! 0.15b added CreateDIBitmap xCreateDIBitmap = linkFunc(gdi32, "CreateDIBitmap", {C_POINTER, C_POINTER, C_LONG, C_LONG, C_POINTER, C_LONG}, C_LONG ), xLoadImage = linkFunc(user32, "LoadImageA",{C_POINTER, C_POINTER, C_UINT, C_INT, C_INT, C_UINT}, C_POINTER ), -- scroll bars xSetScrollPos = linkFunc(user32, "SetScrollPos", {C_POINTER, C_INT, C_INT, C_LONG}, C_INT), xGetScrollPos = linkFunc(user32, "GetScrollPos", {C_POINTER, C_INT}, C_INT), xSetScrollRange = linkFunc(user32, "SetScrollRange", {C_POINTER, C_INT, C_INT, C_INT, C_LONG}, C_LONG), xGetScrollRange = linkFunc(user32, "GetScrollRange", {C_POINTER, C_INT, C_POINTER, C_POINTER}, C_LONG), xShowScrollBar = linkFunc(user32, "ShowScrollBar", {C_POINTER, C_INT, C_LONG}, C_LONG), xEnableScrollBar = linkFunc(user32, "EnableScrollBar", {C_POINTER, C_UINT, C_UINT}, C_LONG), xSetScrollInfo = linkFunc(user32, "SetScrollInfo", {C_POINTER, C_INT, C_POINTER, C_LONG}, C_INT), xGetScrollInfo = linkFunc(user32, "SetScrollInfo", {C_POINTER, C_INT, C_POINTER}, C_POINTER), -- extending the text attributes xSetTextColor = linkFunc(gdi32, "SetTextColor", {C_POINTER, C_LONG}, C_LONG), xSetTextAlign = linkFunc(gdi32, "SetTextAlign", {C_POINTER, C_UINT}, C_UINT), xSetTextJustification = linkFunc(gdi32, "SetTextJustification", {C_POINTER, C_INT, C_INT}, C_LONG), xSetBkColor = linkFunc(gdi32, "SetBkColor", {C_POINTER, C_LONG}, C_LONG), xSetBkMode = linkFunc(gdi32, "SetBkMode", {C_POINTER, C_INT}, C_INT), xGetBkColor = linkFunc(gdi32, "GetBkColor", {C_POINTER}, C_LONG), xGetWindowRect = linkFunc(user32, "GetWindowRect", {C_POINTER, C_POINTER}, C_LONG), -- DPtoLP = linkFunc(gdi32, "DPtoLP", {C_LONG, C_POINTER, C_LONG}, C_LONG), -- common dialogs xGetOpenFileName = linkFunc(comdlg32, "GetOpenFileNameA", {C_POINTER}, C_LONG), xGetSaveFileName = linkFunc(comdlg32, "GetSaveFileNameA", {C_POINTER}, C_LONG), xGetFileTitle = linkFunc(comdlg32, "GetFileTitleA", {C_POINTER, C_POINTER, C_INT}, C_INT), -- memory xGlobalAlloc = linkFunc(kernel32, "GlobalAlloc", {C_UINT, C_LONG}, C_POINTER), xGlobalFree = linkFunc(kernel32, "GlobalFree", {C_POINTER}, C_POINTER), -- position of windows xGetViewportOrgEx = linkFunc(gdi32, "GetViewportOrgEx", {C_POINTER, C_POINTER}, C_LONG), xClientToScreen = linkFunc(user32, "ClientToScreen", {C_POINTER, C_POINTER}, C_LONG), xScreenToClient = linkFunc(user32, "ScreenToClient", {C_POINTER, C_POINTER}, C_LONG), xCloseWindow = linkFunc(user32, "CloseWindow", {C_POINTER}, C_LONG), xMoveWindow = linkFunc(user32, "MoveWindow", {C_POINTER, C_INT, C_INT, C_INT, C_INT, C_LONG}, C_LONG), xSetWindowPos = linkFunc(user32, "SetWindowPos", {C_POINTER, C_POINTER, C_INT, C_INT, C_INT, C_INT, C_UINT}, C_LONG), xGetWindowPlacement = linkFunc(user32, "GetWindowPlacement", {C_POINTER, C_POINTER}, C_LONG), xSetWindowPlacement = linkFunc(user32, "SetWindowPlacement", {C_POINTER, C_POINTER}, C_LONG), xDestroyWindow = linkFunc(user32, "DestroyWindow", {C_POINTER}, C_LONG), -- rectangles xDrawFocusRect = linkFunc(user32, "DrawFocusRect", {C_POINTER, C_POINTER}, C_LONG), xDrawFrameControl = linkFunc(user32, "DrawFrameControl", {C_POINTER, C_POINTER, C_UINT, C_UINT}, C_LONG), -- NEW! 0.15c -- carets xCreateCaret = linkFunc(user32, "CreateCaret", {C_POINTER, C_POINTER, C_LONG, C_LONG}, C_LONG ), xGetCaretBlinkTime = linkFunc(user32, "GetCaretBlinkTime", {}, C_LONG ), xSetCaretBlinkTime = linkFunc(user32, "SetCaretBlinkTime", {C_LONG}, C_LONG ), xDestroyCaret = linkFunc(user32, "DestroyCaret", {}, C_LONG ), xHideCaret = linkFunc(user32, "HideCaret", {C_POINTER}, C_LONG ), xShowCaret = linkFunc(user32, "ShowCaret", {C_POINTER}, C_LONG ), xSetCaretPos = linkFunc(user32, "SetCaretPos", {C_LONG, C_LONG}, C_LONG ), xGetCaretPos = linkFunc(user32, "GetCaretPos", {C_POINTER}, C_LONG ), -- NEW! 0.20 mouse function xSetCapture = linkFunc(user32,"SetCapture",{C_UINT},C_INT), xReleaseCapture = linkProc(user32,"ReleaseCapture",{}) ----------------------------------------------------------------------------- ----------------------------------------------------------------------------- -- ERROR HANDLING -- NEW! 0.20 made this a forward reference, move releaseAllResources -- the "clean up" routine -- this is defined later, so I set up a forward reference integer xCleanUp xCleanUp = -1 ----------------------------------------------------------------------------- global procedure abortErr( sequence s ) -- show error message, but don't abort -- give message ok = message_box( s, "Win32Lib Error", MB_ICONHAND+MB_TASKMODAL ) -- clean up if xCleanUp > -1 then call_proc( xCleanUp, {} ) end if -- abort abort(0) end procedure ----------------------------------------------------------------------------- global procedure warnErr( sequence s ) -- show error message, give user option to abort -- give message if message_box( s, "Win32Lib Error", MB_ICONHAND+MB_TASKMODAL+MB_OKCANCEL ) = IDCANCEL then ? 1/0 if xCleanUp > -1 then call_proc( xCleanUp, {} ) end if -- abort abort(0) end if end procedure ----------------------------------------------------------------------------- ----------------------------------------------------------------------------- -- MATH ----------------------------------------------------------------------------- global function or_all(sequence s) -- or together all elements of a sequence atom result result = 0 for i = 1 to length(s) do result = or_bits(result, s[i]) end for return result end function ----------------------------------------------------------------------------- global function lo_word( atom a ) -- return low word return and_bits( a, #FFFF ) end function ----------------------------------------------------------------------------- global function hi_word( atom a ) -- return high word return floor(a/power( 2, 16)) end function ----------------------------------------------------------------------------- global function abs( atom a ) if a < 0 then return -a else return a end if end function ----------------------------------------------------------------------------- ----------------------------------------------------------------------------- -- FILE I/O ----------------------------------------------------------------------------- function readBytes( integer hFile, integer size ) -- read bytes from file sequence s s = repeat( 0, size ) for i = 1 to size do s[i] = getc( hFile ) end for return s end function ----------------------------------------------------------------------------- function readLong( integer hFile ) -- read a Long from the file return bytes_to_int( readBytes( hFile, 4 ) ) end function ----------------------------------------------------------------------------- ----------------------------------------------------------------------------- -- DATA STRUCTURES ----------------------------------------------------------------------------- sequence strings -- stores addresses of strings used in structures strings = {} ----------------------------------------------------------------------------- function allot_string( sequence s ) -- allocate a string for a structure atom at -- place string in memory at = allocate_string( s ) if at = 0 then -- out of string space abortErr( "Unable to allocate string space." ) end if -- save location for garbage collection strings = append( strings, at ) -- return the address return at end function ----------------------------------------------------------------------------- global procedure free_strings() -- free allocated strings -- for each allocated string... for i = 1 to length( strings ) do -- ...free string free( strings[i] ) end for -- clear the address list strings = {} end procedure ----------------------------------------------------------------------------- global constant Byte = -1, Word = -2, Integer = Word, Long = -3, Dword = Long, Lpsz = -4 integer allottedSize allottedSize = 0 ----------------------------------------------------------------------------- global function allot( integer i ) -- returns allotted size, and adds new field -- used to build a data structure integer soFar, diff, size -- save position soFar = allottedSize -- if not a pre-defined type, make sure it gets a word boundary if i > 0 then diff = remainder( soFar, 4 ) if diff then -- word align soFar = soFar + 4 - diff end if -- size is actual size size = i elsif i = Byte then size = 1 elsif i = Word then size = 2 elsif i = Long then size = 4 elsif i = Lpsz then size = 4 end if -- allot space allottedSize = allottedSize + size -- return size and data type return { soFar, i } end function ----------------------------------------------------------------------------- global function allotted_size() -- returns allotted size, and clears size integer soFar soFar = allottedSize allottedSize = 0 return soFar end function ----------------------------------------------------------------------------- global procedure store( atom struct, sequence s, object o ) -- fetch the data based on the type integer offset, size -- rest data type offset = s[1] size = s[2] -- read, based on size if size = Byte then -- poke a byte poke( struct+offset, o ) elsif size = Word then -- poke a word s = int_to_bytes( o ) poke( struct+offset, s[1..2] ) elsif size = Long then -- poke a long poke4( struct+offset, o ) elsif size = Lpsz then -- if atom, treat as long if atom( o ) then poke4( struct+offset, o ) else -- poke the address of the allotted string poke4( struct+offset, allot_string( o ) ) end if else -- poke a string poke( struct+offset, o ) end if end procedure ----------------------------------------------------------------------------- global function peek_string(atom a) -- read a lpsz string from address a -- Credit: Pete Eberlein integer i sequence s s = "" if a then i = peek(a) while i do s = append(s, i) a = a + 1 i = peek(a) end while end if return s end function ----------------------------------------------------------------------------- global function fetch( atom struct, sequence s ) -- fetch the data based on the type integer size, char atom at -- address is struct + offset at = struct + s[1] -- get data size size = s[2] -- read, based on size if size = Byte then -- return byte return peek( at ) elsif size = Word then -- return word return bytes_to_int( peek({at, 2}) & {0, 0} ) elsif size = Long then -- return long return peek4s( at ) elsif size = Lpsz then -- get the pointer at = peek4u(at) -- return the string return peek_string( at ) else -- return the string return( peek( {at, size} ) ) end if end function ----------------------------------------------------------------------------- global function allocate_struct( integer size ) -- allocate space for a structure -- and initialize to zero atom at at = allocate( size ) mem_set( at, 0, size ) return at end function ----------------------------------------------------------------------------- global function address( atom addr, object o ) -- return address in structure if atom( o ) then return addr + o else return addr + o[1] end if end function ----------------------------------------------------------------------------- function loadStructFromFile( integer hFile, atom into, integer bytes ) -- load structure on file directly into a memory structure sequence s -- the sequence will hold the data temporarily s = repeat( 0, bytes ) -- for each byte in the structure for i = 1 to bytes do -- get a byte from the file s[i] = getc( hFile ) end for -- look for a -1 if find( -1, s ) then -- end of file, return failure return 0 end if -- load structure poke( into, s ) -- return success return 1 end function ----------------------------------------------------------------------------- -- defining a window global constant -- NEW! 0.15 renamed to WNDCLASSEX winExSize = allot( Long ), winExStyle = allot( Long ), winExProc = allot( Long ), winExClsExtra = allot( Long ), winExExtra = allot( Long ), winExInstance = allot( Long ), winExIcon = allot( Long ), winExCursor = allot( Long ), winExBackground = allot( Long ), winExMenuName = allot( Lpsz ), winExClassName = allot( Lpsz ), winExIconSm = allot( Long ), SIZEOF_WNDCLASSEX = allotted_size(), SIZEOF_MESSAGE = 40, ----------------------------------------------------------------------------- -- Type RECT rectLeft = allot( Long ), rectTop = allot( Long ), rectRight = allot( Long ), rectBottom = allot( Long ), SIZEOF_RECT = allotted_size(), ----------------------------------------------------------------------------- -- Type PAINTSTRUCT -- NEW! 0.15 Robert Craig found psRgbReserved to be too small psHdc = allot( Long ), psErase = allot( Long ), psPaintRect = allot( SIZEOF_RECT ), psRestore = allot( Long ), psIncUpdate = allot( Long ), psRgbReserved = allot( 32 ), SIZEOF_PAINTSTRUCT = allotted_size(), ----------------------------------------------------------------------------- -- defining a font lfHeight = allot( Long ), lfWidth = allot( Long ), lfEscapement = allot( Long ), lfOrientation = allot( Long ), lfWeight = allot( Long ), lfItalic = allot( Byte ), lfUnderline = allot( Byte ), lfStrikeOut = allot( Byte ), lfCharSet = allot( Byte ), lfOutPrecision = allot( Byte ), lfClipPrecision = allot( Byte ), lfQuality = allot( Byte ), lfPitchAndFamily = allot( Byte ), lfFaceName = allot( 32 ), SIZEOF_LOGFONT = allotted_size(), ----------------------------------------------------------------------------- -- Type TEXTMETRIC tmHeight = allot( Long ), tmAscent = allot( Long ), tmDescent = allot( Long ), tmInternalLeading = allot( Long ), tmExternalLeading = allot( Long ), tmAveCharWidth = allot( Long ), tmMaxCharWidth = allot( Long ), tmWeight = allot( Long ), tmOverhang = allot( Long ), tmDigitizedAspectX = allot( Long ), tmDigitizedAspectY = allot( Long ), tmFirstChar = allot( Byte ), tmLastChar = allot( Byte ), tmDefaultChar = allot( Byte ), tmBreakChar = allot( Byte ), tmItalic = allot( Byte ), tmUnderlined = allot( Byte ), tmStruckOut = allot( Byte ), tmPitchAndFamily = allot( Byte ), tmCharSet = allot( Byte ), ntmFlags = allot( Long ), ntmSizeEM = allot( Long ), ntmCellHeight = allot( Long ), ntmAveWidth = allot( Long ), SIZEOF_TEXTMETRIC = allotted_size(), ----------------------------------------------------------------------------- -- Type POINT ptX = allot( Long ), ptY = allot( Long ), SIZEOF_POINT = allotted_size(), -- 8 ----------------------------------------------------------------------------- -- Type SIZE sizX = allot( Long ), sizY = allot( Long ), SIZEOF_SIZE = allotted_size(), ----------------------------------------------------------------------------- -- Type BITMAP bmType = allot( Long ), bmWidth = allot( Long ), bmHeight = allot( Long ), bmWidthBytes = allot( Long ), bmPlanes = allot( Word ), bmBitsPixel = allot( Word ), bmBits = allot( Long ), SIZEOF_BITMAP = allotted_size(), ----------------------------------------------------------------------------- -- Type BITMAPFILEHEADER bfType = allot( 2 ), bfSize = allot( Dword ), bfReserved1 = allot( Word ), bfReserved2 = allot( Word ), bfOffBits = allot( Dword ), SIZEOF_BITMAPFILEHEADER = allotted_size(), ----------------------------------------------------------------------------- -- Type BITMAPINFOHEADER biSize = allot( Dword ), biWidth = allot( Long ), biHeight = allot( Long ), biPlanes = allot( Word ), biBitCount = allot( Word ), biCompression = allot( Dword ), biSizeImage = allot( Dword ), biXPelsPerMeter = allot( Long ), biYPelsPerMeter = allot( Long ), biClrUsed = allot( Dword ), biClrImportant = allot( Dword ), SIZEOF_BITMAPINFOHEADER = allotted_size(), ----------------------------------------------------------------------------- -- Type BITMAPCOREHEADER bcSize = allot( Long ), bcWidth = allot( Word ), bcHeight = allot( Word ), bcPlanes = allot( Word ), bcBitCount = allot( Word ), SIZEOF_BITMAPCOREHEADER = allotted_size(), ----------------------------------------------------------------------------- -- Type RGBTRIPLE rgbtBlue = allot( Byte ), rgbtGreen = allot( Byte ), rgbtRed = allot( Byte ), SIZEOF_RGBTRIPLE = allotted_size(), ----------------------------------------------------------------------------- -- Type RGBQUAD rgbBlue = allot( Byte ), rgbGreen = allot( Byte ), rgbRed = allot( Byte ), rgbReserved = allot( Byte ), SIZEOF_RGBQUAD = allotted_size(), ----------------------------------------------------------------------------- -- Type BITMAPINFO -- NEW! 0.15b this is dependant on the number of colors! bmiHeader = allot( SIZEOF_BITMAPINFOHEADER ), bmiColors = allot( SIZEOF_RGBQUAD*2 ), SIZEOF_BITMAPINFO = allotted_size(), ----------------------------------------------------------------------------- -- Type PALLETTEENTRY peBlue = allot( Byte ), peGreen = allot( Byte ), peRed = allot( Byte ), peFlags = allot( Byte ), SIZEOF_PALETTEENTRY = allotted_size(), ----------------------------------------------------------------------------- -- Type LOGPALETTE -- NEW! 0.15 doubles the size of the palPalEntr palVersion = allot( Word ), palNumEntries = allot( Word ), palPalEntr = allot( SIZEOF_PALETTEENTRY*2 ), SIZEOF_LOGPALETTE = allotted_size(), ----------------------------------------------------------------------------- -- Type OPENFILENAME ofnStructSize = allot( Long ), ofnOwner = allot( Long ), ofnInstance = allot( Long ), ofnFilter = allot( Lpsz ), ofnCustomFilter = allot( Lpsz ), ofnMaxCustFilter = allot( Dword ), ofnFilterIndex = allot( Dword ), ofnFile = allot( Lpsz ), ofnMaxFile = allot( Dword ), ofnFileTitle = allot( Lpsz ), ofnMaxFileTitle = allot( Dword ), ofnInitialDir = allot( Lpsz ), ofnTitle = allot( Lpsz ), ofnFlags = allot( Dword ), ofnFileOffset = allot( Word ), ofnFileExtension = allot( Word ), ofnDefExt = allot( Lpsz ), ofnCustData = allot( Dword ), ofnHook = allot( Long ), ofnTemplateName = allot( Long ), SIZEOF_OPENFILENAME = allotted_size(), -- 76 ----------------------------------------------------------------------------- -- Type SCROLLINFO sifSize = allot( Long ), sifMask = allot( Long ), sifMin = allot( Long ), sifMax = allot( Long ), sifPage = allot( Long ), sifPos = allot( Long ), sifTrackPos = allot( Long ), SIZEOF_SCROLLINFO = allotted_size(), ----------------------------------------------------------------------------- ----------------------------------------------------------------------------- -- Device Parameters for GetDeviceCaps() DRIVERVERSION = 0, -- Device driver version TECHNOLOGY = 2, -- Device classification HORZSIZE = 4, -- Horizontal size in millimeters VERTSIZE = 6, -- Vertical size in millimeters HORZRES = 8, -- Horizontal width in pixels VERTRES = 10, -- Vertical width in pixels BITSPIXEL = 12, -- Number of bits per pixel PLANES = 14, -- Number of planes NUMBRUSHES = 16, -- Number of brushes the device has NUMPENS = 18, -- Number of pens the device has NUMMARKERS = 20, -- Number of markers the device has NUMFONTS = 22, -- Number of fonts the device has NUMCOLORS = 24, -- Number of colors the device supports PDEVICESIZE = 26, -- Size required for device descriptor CURVECAPS = 28, -- Curve capabilities LINECAPS = 30, -- Line capabilities POLYGONALCAPS = 32, -- Polygonal capabilities TEXTCAPS = 34, -- Text capabilities CLIPCAPS = 36, -- Clipping capabilities RASTERCAPS = 38, -- Bitblt capabilities ASPECTX = 40, -- Length of the X leg ASPECTY = 42, -- Length of the Y leg ASPECTXY = 44, -- Length of the hypotenuse LOGPIXELSX = 88, -- Logical pixels/inch in X LOGPIXELSY = 90, -- Logical pixels/inch in Y SIZEPALETTE = 104, -- Number of entries in physical palette NUMRESERVED = 106, -- Number of reserved entries in palette COLORRES = 108, -- Actual color resolution -- Printing related DeviceCaps. These replace the appropriate Escapes PHYSICALWIDTH = 110, -- Physical Width in device units PHYSICALHEIGHT = 111, -- Physical Height in device units PHYSICALOFFSETX = 112, -- Physical Printable Area x margin PHYSICALOFFSETY = 113, -- Physical Printable Area y margin SCALINGFACTORX = 114, -- Scaling factor x SCALINGFACTORY = 115 -- Scaling factor y ----------------------------------------------------------------------------- global constant -- Class styles CS_VREDRAW = #1, CS_HREDRAW = #2, CS_KEYCVTWINDOW = #4, CS_DBLCLKS = #8, CS_OWNDC = #20, CS_CLASSDC = #40, CS_PARENTDC = #80, CS_NOKEYCVT = #100, CS_NOCLOSE = #200, CS_SAVEBITS = #800, CS_BYTEALIGNCLIENT = #1000, CS_BYTEALIGNWINDOW = #2000, CS_PUBLICCLASS = #4000, -- ShowWindow() Commands SW_HIDE = 0, SW_SHOWNORMAL = 1, SW_NORMAL = 1, SW_SHOWMINIMIZED = 2, SW_SHOWMAXIMIZED = 3, SW_MAXIMIZE = 3, SW_SHOWNOACTIVATE = 4, SW_SHOW = 5, SW_MINIMIZE = 6, SW_SHOWMINNOACTIVE = 7, SW_SHOWNA = 8, SW_RESTORE = 9, SW_SHOWDEFAULT = 10, SW_MAX = 10, -- Window Messages WM_NULL = #0, WM_CREATE = #1, WM_DESTROY = #2, WM_MOVE = #3, WM_SIZE = #5, WM_ACTIVATE = #6, -- -- WM_ACTIVATE state values WA_INACTIVE = 0, WA_ACTIVE = 1, WA_CLICKACTIVE = 2, WM_SETFOCUS = #7, WM_KILLFOCUS = #8, WM_ENABLE = #A, WM_SETREDRAW = #B, WM_SETTEXT = #C, WM_GETTEXT = #D, WM_GETTEXTLENGTH = #E, WM_PAINT = #F, WM_CLOSE = #10, WM_QUERYENDSESSION = #11, WM_QUIT = #12, WM_QUERYOPEN = #13, WM_ERASEBKGND = #14, WM_SYSCOLORCHANGE = #15, WM_ENDSESSION = #16, WM_SHOWWINDOW = #18, WM_WININICHANGE = #1A, WM_DEVMODECHANGE = #1B, WM_ACTIVATEAPP = #1C, WM_FONTCHANGE = #1D, WM_TIMECHANGE = #1E, WM_CANCELMODE = #1F, WM_SETCURSOR = #20, WM_MOUSEACTIVATE = #21, WM_CHILDACTIVATE = #22, WM_QUEUESYNC = #23, WM_GETMINMAXINFO = #24, WM_SETICON = #80, SND_FILENAME = #00020000, SND_ASYNC = #00000001, DT_SINGLELINE = #0020, DT_CENTER = #0001, DT_VCENTER = #0004, -- Window Styles WS_OVERLAPPED = #0, WS_POPUP = #80000000, WS_CHILD = #40000000, WS_MINIMIZE = #20000000, WS_VISIBLE = #10000000, WS_DISABLED = #8000000, WS_CLIPSIBLINGS = #4000000, WS_CLIPCHILDREN = #2000000, WS_MAXIMIZE = #1000000, WS_CAPTION = #C00000, -- WS_BORDER Or WS_DLGFRAME WS_BORDER = #00800000, -- creates border on window WS_DLGFRAME = #400000, WS_HSCROLL = #00100000, -- horizontal scroll bar WS_VSCROLL = #00200000, -- vertical scroll bar WS_SYSMENU = #80000, WS_THICKFRAME = #40000, WS_GROUP = #20000, WS_TABSTOP = #10000, -- use tab stop WS_MINIMIZEBOX = #20000, WS_MAXIMIZEBOX = #10000, WS_TILED = WS_OVERLAPPED, WS_ICONIC = WS_MINIMIZE, WS_SIZEBOX = WS_THICKFRAME, WS_OVERLAPPEDWINDOW = or_all({ WS_OVERLAPPED, WS_CAPTION, WS_SYSMENU, WS_THICKFRAME, WS_MINIMIZEBOX, WS_MAXIMIZEBOX}), WS_TILEDWINDOW = WS_OVERLAPPEDWINDOW, -- -- Common Window Styles -- / WS_POPUPWINDOW = or_all({WS_POPUP, WS_BORDER, WS_SYSMENU}), WS_CHILDWINDOW = (WS_CHILD), BS_PUSHBUTTON = #0000, -- pushbutton BS_DEFPUSHBUTTON = #0001, -- default pushbutton (heavy border) BS_CHECKBOX = #0002, -- checkbox BS_AUTOCHECKBOX = #0003, -- checkbox, windows toggles BS_RADIOBUTTON = #0004, -- radio button BS_3STATE = #0005, -- tri-state button BS_AUTO3STATE = #0006, -- tri-state button, window toggles BS_GROUPBOX = #0007, -- group box BS_AUTORADIOBUTTON = #0009, -- rado button, windows toggles BS_OWNERDRAW = #000B, -- owner drawn ES_LEFT = #0000, -- left justified text ES_CENTER = #0001, -- centered text ES_RIGHT = #0002, -- right justified text ES_MULTILINE = #0004, -- multiline edit ES_AUTOHSCROLL = #0080, -- automatic horizontal scroll ES_AUTOVSCROLL = #0040, -- automatic vertical scroll LBS_NOTIFY = #0001, -- notify parent on click or double click LBS_SORT = #0002, -- sort strings in box alphabetically LBS_STANDARD = or_all( { LBS_NOTIFY, LBS_SORT, WS_VSCROLL, WS_BORDER} ), LB_ADDSTRING = #180, -- list box: add string LB_INSERTSTRING = #181, -- list box: insert string LB_DELETESTRING = #182, -- list box: delete string LB_RESETCONTENT = #184, -- list box: reset list LB_GETTEXT = #189, -- list box: get text LB_GETTEXTLEN = #18A, -- list box: get length of text LB_GETCOUNT = #18B, -- list box: get length of list LB_GETCURSEL = #188, -- list box: get index of selected item LB_SETCURSEL = #186, -- list box: set index of selected item CB_ADDSTRING = #143, -- combo box: add string CB_DELETESTRING = #144, -- combo box: delete string CB_GETCOUNT = #146, -- combo box: get list count CB_GETLBTEXT = #148, -- combo box: get text CB_GETLBTEXTLEN = #149, -- combo box: get text length CB_INSERTSTRING = #14A, -- combo box: insert string CB_RESETCONTENT = #14B, -- combo box: erase list CB_GETCURSEL = #147, -- combo box: return index of current item CB_SETCURSEL = #14E, -- combo box: set index -- Button Control Messages BM_GETCHECK = #F0, -- button message: get check state BM_SETCHECK = #F1, -- set check state BM_GETSTATE = #F2, -- button message: get state BM_SETSTATE = #F3, -- button message: set state BM_SETSTYLE = #F4, -- button message: set style -- key commands WM_KEYDOWN = #100, -- key pressed WM_KEYUP = #101, WM_CHAR = #102, -- NEW! 0.15c added all the standard VK keys -- Virtual Keys, Standard Set VK_LBUTTON = #1, VK_RBUTTON = #2, VK_CANCEL = #3, VK_MBUTTON = #4, -- NOT contiguous with L RBUTTON VK_BACK = #8, VK_TAB = #9, VK_CLEAR = #C, VK_RETURN = #D, VK_SHIFT = #10, VK_CONTROL = #11, VK_MENU = #12, VK_PAUSE = #13, VK_CAPITAL = #14, VK_ESCAPE = #1B, VK_SPACE = #20, VK_PRIOR = #21, VK_NEXT = #22, VK_END = #23, VK_HOME = #24, VK_LEFT = #25, VK_UP = #26, VK_RIGHT = #27, VK_DOWN = #28, VK_SELECT = #29, VK_PRINT = #2A, VK_EXECUTE = #2B, VK_SNAPSHOT = #2C, VK_INSERT = #2D, VK_DELETE = #2E, VK_HELP = #2F, -- VK_A thru VK_Z are the same as their ASCII equivalents: 'A' thru 'Z' -- VK_0 thru VK_9 are the same as their ASCII equivalents: '0' thru '9' VK_NUMPAD0 = #60, VK_NUMPAD1 = #61, VK_NUMPAD2 = #62, VK_NUMPAD3 = #63, VK_NUMPAD4 = #64, VK_NUMPAD5 = #65, VK_NUMPAD6 = #66, VK_NUMPAD7 = #67, VK_NUMPAD8 = #68, VK_NUMPAD9 = #69, VK_MULTIPLY = #6A, VK_ADD = #6B, VK_SEPARATOR = #6C, VK_SUBTRACT = #6D, VK_DECIMAL = #6E, VK_DIVIDE = #6F, VK_F1 = #70, VK_F2 = #71, VK_F3 = #72, VK_F4 = #73, VK_F5 = #74, VK_F6 = #75, VK_F7 = #76, VK_F8 = #77, VK_F9 = #78, VK_F10 = #79, VK_F11 = #7A, VK_F12 = #7B, VK_F13 = #7C, VK_F14 = #7D, VK_F15 = #7E, VK_F16 = #7F, VK_F17 = #80, VK_F18 = #81, VK_F19 = #82, VK_F20 = #83, VK_F21 = #84, VK_F22 = #85, VK_F23 = #86, VK_F24 = #87, VK_NUMLOCK = #90, VK_SCROLL = #91, -- VK_L VK_R - left and right Alt, Ctrl and Shift virtual keys. -- Used only as parameters to GetAsyncKeyState() and GetKeyState(). -- No other API or message will distinguish left and right keys in this way. VK_LSHIFT = #A0, VK_RSHIFT = #A1, VK_LCONTROL = #A2, VK_RCONTROL = #A3, VK_LMENU = #A4, VK_RMENU = #A5, VK_ATTN = #F6, VK_CRSEL = #F7, VK_EXSEL = #F8, VK_EREOF = #F9, VK_PLAY = #FA, VK_ZOOM = #FB, VK_NONAME = #FC, VK_PA1 = #FD, VK_OEM_CLEAR = #FE, -- my additions VK_PAGEUP = VK_PRIOR, VK_PAGEDOWN = VK_NEXT, GWL_WndProc = -4, -- GetWindowLong: ptr to function -- Menu flags for Add/Check/EnableMenuItem() MF_INSERT = #0, MF_CHANGE = #80, MF_APPEND = #100, MF_DELETE = #200, MF_REMOVE = #1000, MF_BYCOMMAND = #0, -- specifies parameter type MF_BYPOSITION = #400, -- specifies parameter type MF_SEPARATOR = #800, -- menu format: seperator MF_ENABLED = #0, -- menu format: enabled MF_GRAYED = #1, -- menu format: grayed MF_DISABLED = #2, -- menu format: disabled MF_UNCHECKED = #0, -- menu format: unchecked MF_CHECKED = #8, -- menu format: checked MF_USECHECKBITMAPS = #200, -- menu format: use check bitmaps MF_STRING = #0, -- menu format: display string MF_BITMAP = #4, -- menu format: display bitmap MF_OWNERDRAW = #100, -- menu format: owner drawn MF_POPUP = #10, -- menu format: popup style MF_MENUBARBREAK = #20, -- menu format: menu bar break style MF_MENUBREAK = #40, -- menu format: menu break style MF_UNHILITE = #0, MF_HILITE = #80, MF_SYSMENU = #2000, MF_HELP = #4000, MF_MOUSESELECT = #8000, -- NOTIFICATIONS (events) -- Button Control Notification Codes BN_CLICKED = #0000, -- button notification: clicked -- Edit Control Notification Codes EN_SETFOCUS = #100, -- get focus EN_KILLFOCUS = #200, -- lose focus EN_CHANGE = #300, -- change EN_UPDATE = #400, -- update EN_ERRSPACE = #500, -- out of memory EN_MAXTEXT = #501, -- more than allotted text EN_HSCROLL = #601, -- horizontal scroll EN_VSCROLL = #602, -- vertical scroll -- List Box Control Notification Codes LBN_ERRSPACE = (-2), -- out of space LBN_SELCHANGE = 1, -- change selection LBN_DBLCLK = 2, -- double click LBN_SELCANCEL = 3, -- cancel selection LBN_SETFOCUS = 4, -- focus LBN_KILLFOCUS = 5, -- lose focus -- Combo Box Control Notification Codes CBN_ERRSPACE = (-1), -- out of space CBN_SELCHANGE = 1, -- change selection CBN_DBLCLK = 2, -- double click CBN_SETFOCUS = 3, -- set focus CBN_KILLFOCUS = 4, -- lose focus CBN_EDITCHANGE = 5, -- change data CBN_EDITUPDATE = 6, -- update data CBN_DROPDOWN = 7, -- dropdown CBN_CLOSEUP = 8, -- close dropdown CBN_SELENDOK = 9, CBN_SELENDCANCEL = 10, CBS_AUTOHSCROLL = 64, CBS_DISABLENOSCROLL = #800, CBS_DROPDOWN = 2, CBS_DROPDOWNLIST = 3, CBS_HASSTRINGS = 512, CBS_LOWERCASE = #4000, CBS_NOINTEGRALHEIGHT = #400, CBS_OEMCONVERT = 128, CBS_OWNERDRAWFIXED = 16, CBS_OWNERDRAWVARIABLE = 32, CBS_SIMPLE = 1, CBS_SORT = 256, CBS_UPPERCASE = #2000, WM_COMMAND = #0111, -- window message command WM_MENUSELECT = #011F, -- menu item selected -- edit commands WM_CUT = #300, WM_COPY = #301, WM_PASTE = #302, WM_CLEAR = #303, WM_UNDO = #304, -- Edit Control Messages EM_GETSEL = #B0, -- 2 long pointers EM_SETSEL = #B1, -- pass start and end -- EM_GETRECT = #B2, -- EM_SETRECT = #B3, -- EM_SETRECTNP = #B4, EM_SCROLL = #B5, EM_LINESCROLL = #B6, EM_SCROLLCARET = #B7, EM_GETMODIFY = #B8, EM_SETMODIFY = #B9, EM_GETLINECOUNT = #BA, EM_LINEINDEX = #BB, EM_SETHANDLE = #BC, EM_GETHANDLE = #BD, EM_GETTHUMB = #BE, EM_LINELENGTH = #C1, EM_REPLACESEL = #C2, EM_GETLINE = #C4, EM_LIMITTEXT = #C5, EM_CANUNDO = #C6, EM_UNDO = #C7, EM_FMTLINES = #C8, EM_LINEFROMCHAR = #C9, EM_SETTABSTOPS = #CB, EM_SETPASSWORDCHAR = #CC, EM_EMPTYUNDOBUFFER = #CD, EM_GETFIRSTVISIBLELINE = #CE, EM_SETREADONLY = #CF, EM_SETWORDBREAKPROC = #D0, EM_GETWORDBREAKPROC = #D1, EM_GETPASSWORDCHAR = #D2, -- mouse events WM_LBUTTONDBLCLK = 515, -- mouse button double clicked WM_RBUTTONDBLCLK = #206, -- mouse right button double clicked WM_LBUTTONDOWN = 513, -- mouse button down WM_RBUTTONDOWN = #204, -- right button down WM_MBUTTONDOWN = #207, -- middle button down -- NEW! 0.15 added mouse move and left button up WM_MOUSEMOVE = #200, -- mouse moved WM_LBUTTONUP = #202, -- left button released WM_RBUTTONUP = #205, -- right button released WM_MBUTTONUP = #208, -- middle button released -- setting fonts in controls WM_SETFONT = #30, WM_GETFONT = #31, -- Graphics Modes (used by EZ_FONT) GM_ADVANCED = 2, -- NEW! 0.15b -- Background Modes TRANSPARENT = 1, -- background is not touched OPAQUE = 2, -- background filled before drawing -- xform stuff MWT_IDENTITY = 1, IDI_APPLICATION = 32512, IDC_ARROW = 32512, CW_USEDEFAULT = #80000000, -- Stock Logical Objects WHITE_BRUSH = 0, LTGRAY_BRUSH = 1, GRAY_BRUSH = 2, DKGRAY_BRUSH = 3, BLACK_BRUSH = 4, NULL_BRUSH = 5, HOLLOW_BRUSH = NULL_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, -- Scroll bar messages SBM_SETPOS = #E0, -- not in win3.1 SBM_GETPOS = #E1, -- not in win3.1 SBM_SETRANGE = #E2, -- not in win3.1 SBM_SETRANGEREDRAW = #E6, -- not in win3.1 SBM_GETRANGE = #E3, -- not in win3.1 SBM_ENABLE_ARROWS = #E4, -- not in win3.1 -- Scroll Bar Styles SBS_HORZ = #0, SBS_VERT = #1, SBS_TOPALIGN = #2, SBS_LEFTALIGN = #2, SBS_BOTTOMALIGN = #4, SBS_RIGHTALIGN = #4, SBS_SIZEBOXTOPLEFTALIGN = #2, SBS_SIZEBOXBOTTOMRIGHTALIGN = #4, SBS_SIZEBOX = #8, -- scroll bar events WM_HSCROLL = #114, WM_VSCROLL = #115, -- Scroll Bar Constants SB_HORZ = 0, SB_VERT = 1, SB_CTL = 2, SB_BOTH = 3, -- Scroll Bar Commands SB_LINEUP = 0, SB_LINELEFT = 0, SB_LINEDOWN = 1, SB_LINERIGHT = 1, SB_PAGEUP = 2, SB_PAGELEFT = 2, SB_PAGEDOWN = 3, SB_PAGERIGHT = 3, SB_THUMBPOSITION = 4, SB_THUMBTRACK = 5, SB_TOP = 6, SB_LEFT = 6, SB_BOTTOM = 7, SB_RIGHT = 7, SB_ENDSCROLL = 8, -- scroll bar information flags SIF_DISABLENOSCROLL = #8, SIF_PAGE = #2, SIF_POS = #4, SIF_RANGE = #1, SIF_TRACKPOS = #10, SIF_ALL = or_all({SIF_RANGE,SIF_PAGE,SIF_POS,SIF_TRACKPOS}), -- Color hooks - control about to be drawn WM_CTLCOLORMSGBOX = #132, WM_CTLCOLOREDIT = #133, WM_CTLCOLORLISTBOX = #134, WM_CTLCOLORBTN = #135, WM_CTLCOLORDLG = #136, WM_CTLCOLORSCROLLBAR = #137, WM_CTLCOLORSTATIC = #138, -- MessageBox() Flags -- MB_OK = #0, -- MB_OKCANCEL = #1, -- MB_ABORTRETRYIGNORE = #2, -- MB_YESNOCANCEL = #3, -- MB_YESNO = #4, -- MB_RETRYCANCEL = #5, -- MB_ICONHAND = #10, -- MB_ICONQUESTION = #20, -- MB_ICONEXCLAMATION = #30, -- MB_ICONASTERISK = #40, -- MB_ICONINFORMATION = MB_ICONASTERISK, -- MB_ICONSTOP = MB_ICONHAND, -- MB_DEFBUTTON1 = #0, -- MB_DEFBUTTON2 = #100, -- MB_DEFBUTTON3 = #200, -- MB_APPLMODAL = #0, -- MB_SYSTEMMODAL = #1000, -- MB_TASKMODAL = #2000, -- timer WM_TIMER = #113, -- Ternary raster operations SRCCOPY = #CC0020, -- (DWORD) dest = source SRCPAINT = #EE0086, -- (DWORD) dest = source OR dest SRCAND = #8800C6, -- (DWORD) dest = source AND dest SRCINVERT = #660046, -- (DWORD) dest = source XOR dest SRCERASE = #440328, -- (DWORD) dest = source AND (NOT dest ) NOTSRCCOPY = #330008, -- (DWORD) dest = (NOT source) NOTSRCERASE = #1100A6, -- (DWORD) dest = (NOT src) AND (NOT dest) MERGECOPY = #C000CA, -- (DWORD) dest = (source AND pattern) MERGEPAINT = #BB0226, -- (DWORD) dest = (NOT source) OR dest PATCOPY = #F00021, -- (DWORD) dest = pattern PATPAINT = #FB0A09, -- (DWORD) dest = DPSnoo PATINVERT = #5A0049, -- (DWORD) dest = pattern XOR dest DSTINVERT = #550009, -- (DWORD) dest = (NOT dest) BLACKNESS = #42, -- (DWORD) dest = BLACK WHITENESS = #FF0062, -- (DWORD) dest = WHITE -- NEW! 0.20 Win32Lib names -- Ternary raster operations SrcCopy = SRCCOPY, SrcPaint = SRCPAINT, SrcAnd = SRCAND, SrcInvert = SRCINVERT, SrcErase = SRCERASE, NotSrcCopy = NOTSRCCOPY, NotSrcErase = NOTSRCERASE, MergeCopy = MERGECOPY, MergePaint = MERGEPAINT, PatCopy = PATCOPY, PatPaint = PATPAINT, PatInvert = PATINVERT, DstInvert = DSTINVERT, Blackness = BLACKNESS, Whiteness = WHITENESS, -- Binary raster ops R2_BLACK = 1, -- Pixel is always 0. R2_NOTMERGEPEN = 2, -- Pixel is the inverse of the R2_MERGEPEN color. R2_MASKNOTPEN = 3, -- combination common screen and inverse of pen. R2_NOTCOPYPEN = 4, -- Pixel is the inverse of the pen color. R2_MASKPENNOT = 5, -- combination common to pen and inverse of screen. R2_NOT = 6, -- Pixel is the inverse of the screen color. R2_XORPEN = 7, -- Pixel is the inverse of the R2_XORPEN color. R2_NOTMASKPEN = 8, -- Pixel is the inverse of the R2_MASKPEN color. R2_MASKPEN = 9, -- combination common to pen and the screen. R2_NOTXORPEN = 10, -- combination of colors in pen and screen, but not in both. R2_NOP = 11, -- Pixel remains unchanged. R2_MERGENOTPEN = 12, -- combination of screen and inverse of pen. R2_COPYPEN = 13, -- Pixel is the pen color. R2_MERGEPENNOT = 14, -- combination of pen color and inverse of screen color. R2_MERGEPEN = 15, -- combination of pen color and the screen color. R2_WHITE = 16, -- Pixel is always 1. R2_LAST = 16, GDI_ERROR = #FFFF, HGDI_ERROR = #FFFF, -- error with color CLR_INVALID = #FFFF, -- open file name common dialog OFN_READONLY = #1, OFN_OVERWRITEPROMPT = #2, OFN_HIDEREADONLY = #4, OFN_NOCHANGEDIR = #8, OFN_SHOWHELP = #10, OFN_ENABLEHOOK = #20, OFN_ENABLETEMPLATE = #40, OFN_ENABLETEMPLATEHANDLE = #80, OFN_NOVALIDATE = #100, OFN_ALLOWMULTISELECT = #200, OFN_EXTENSIONDIFFERENT = #400, OFN_PATHMUSTEXIST = #800, OFN_FILEMUSTEXIST = #1000, OFN_CREATEPROMPT = #2000, OFN_SHAREAWARE = #4000, OFN_NOREADONLYRETURN = #8000, OFN_NOTESTFILECREATE = #10000, OFN_NONETWORKBUTTON = #20000, OFN_NOLONGNAMES = #40000, -- force no long names for 4.x modules OFN_EXPLORER = #80000, -- new look commdlg OFN_NODEREFERENCELINKS = #100000, OFN_LONGNAMES = #200000, -- force long names for 3.x modules OFN_SHAREFALLTHROUGH = 2, OFN_SHARENOWARN = 1, OFN_SHAREWARN = 0, -- Global Memory Flags GMEM_FIXED = #0, GMEM_MOVEABLE = #2, GMEM_NOCOMPACT = #10, GMEM_NODISCARD = #20, GMEM_ZEROINIT = #40, GMEM_MODIFY = #80, GMEM_DISCARDABLE = #100, GMEM_NOT_BANKED = #1000, GMEM_SHARE = #2000, GMEM_DDESHARE = #2000, GMEM_NOTIFY = #4000, GMEM_LOWER = GMEM_NOT_BANKED, GMEM_VALID_FLAGS = #7F72, GMEM_INVALID_HANDLE = #8000, GHND = or_all({GMEM_MOVEABLE, GMEM_ZEROINIT}), GPTR = or_all({GMEM_FIXED, GMEM_ZEROINIT}), -- DIB color table identifiers DIB_RGB_COLORS = 0, -- color table in RGBs DIB_PAL_COLORS = 1, -- color table in palette indices DIB_PAL_INDICES = 2, -- No color table indices into surf palette DIB_PAL_PHYSINDICES = 2, -- No color table indices into surf palette DIB_PAL_LOGINDICES = 4, -- No color table indices into DC palette -- Loading Bitmaps STM_SETICON = #170, STM_SETIMAGE = 370, LR_LOADFROMFILE = 16, IMAGE_BITMAP = 0, IMAGE_ICON = 1, SS_ICON = #3, -- static style icon SS_BITMAP = #E, -- static style bitmap -- Class field offsets for GetClassLong() and GetClassWord() GCL_MENUNAME = (-8), GCL_HBRBACKGROUND = (-10), -- background brush GCL_HCURSOR = (-12), GCL_HICON = (-14), GCL_HMODULE = (-16), GCL_CBWNDEXTRA = (-18), GCL_CBCLSEXTRA = (-20), GCL_WNDPROC = (-24), GCL_STYLE = (-26), GCW_ATOM = (-32), -- System Colors 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, -- NEW! 0.15 -- Key State Masks for Mouse Messages MK_LBUTTON = #1, -- left button is pressed MK_RBUTTON = #2, -- right button is pressed MK_SHIFT = #4, -- shift key is held down MK_CONTROL = #8, -- control key is held down MK_MBUTTON = #10, -- middle button is pressed -- NEW! 0.15b -- constants for CreateDIBitmap CBM_CREATEDIB = #2, -- create DIB bitmap CBM_INIT = #4, -- initialize bitmap -- NEW! 0.15c -- constants for onResize -- WM_SIZE message wParam values SIZE_RESTORED = 0, SIZE_MINIMIZED = 1, SIZE_MAXIMIZED = 2, SIZE_MAXSHOW = 3, SIZE_MAXHIDE = 4, -- Obsolete constant names SIZENORMAL = SIZE_RESTORED, SIZEICONIC = SIZE_MINIMIZED, SIZEFULLSCREEN = SIZE_MAXIMIZED, SIZEZOOMSHOW = SIZE_MAXSHOW, SIZEZOOMHIDE = SIZE_MAXHIDE ----------------------------------------------------------------------------- -- Win32 Wrappers for mouse flags global constant -- Visual Basics Names for the buttons: LEFT_BUTTON = MK_LBUTTON, RIGHT_BUTTON = MK_RBUTTON, MIDDLE_BUTTON = MK_MBUTTON, SHIFT_MASK = MK_SHIFT, CTRL_MASK = MK_CONTROL, -- Win32Lib names for mouse events MOUSE_MOVE = WM_MOUSEMOVE, LEFT_DOWN = WM_LBUTTONDOWN, RIGHT_DOWN = WM_RBUTTONDOWN, LEFT_UP = WM_LBUTTONUP, RIGHT_UP = WM_RBUTTONUP, LEFT_DOUBLECLICK = WM_LBUTTONDBLCLK, RIGHT_DOUBLECLICK = WM_RBUTTONDBLCLK, ----------------------------------------------------------------------------- -- Window field offsets for GetWindowLong() and GetWindowWord() -- NEW! 0.20d Added for getId and setId GWL_WNDPROC = (-4), GWL_HINSTANCE = (-6), GWL_HWNDPARENT = (-8), GWL_STYLE = (-16), GWL_EXSTYLE = (-20), GWL_USERDATA = (-21), GWL_ID = (-12), ----------------------------------------------------------------------------- -- attributes for EZ_FONTS -- NEW! 0.20d Added Normal attribute Normal = 0, Bold = 1, Italic = 2, Underline = 4, Strikeout = 8 ----------------------------------------------------------------------------- -- Classes of Windows: Base Classes ----------------------------------------------------------------------------- constant WINDOW = 0, -- window BUTTON = 1, -- button COMBO = 2, -- combo box EDIT = 3, -- edit LISTBOX = 4, -- list box SCROLLBAR = 5, -- scroll bar STATIC = 6, -- static MENU = 7, -- menu MENUITEM = 8, -- menu item PIXMAP = 9 -- pixmap ----------------------------------------------------------------------------- -- Classes of Windows: Used for internal identification of window type ----------------------------------------------------------------------------- -- NEW! Bug identified. This will NOT work unless WINDOW = 0! -- I haven't figured out the logic here, there's probably an -- if class[..] construct somewhere global constant Window = 0, PushButton = 2, DefPushButton = 3, CheckBox = 4, TriCheckBox = 5, Radio = 6, Group = 7, List = 8, SortedList = 9, Combo = 10, SortedCombo = 11, SimpleCombo = 12, DropDownList = 13, EditText = 14, MleText = 15, LText = 16, RText = 17, CText = 18, HScroll = 19, VScroll = 20, Icon = 21, Bitmap = 22, Menu = 23, MenuItem = 24, Pixmap = 25 -- NEW! 0.20 constant NumClasses = Pixmap ----------------------------------------------------------------------------- -- "special" attribute indexes -- There are 8 "special" attributes per window. Currently, it is only used -- for the scroll bars. ----------------------------------------------------------------------------- constant MY_SMALLCHANGE = 1, -- scroll bar line up/down amount MY_LARGECHANGE = 2 -- scroll bar page up/down amount ----------------------------------------------------------------------------- sequence className, -- class name classType, -- message class classStyle -- attributes className = repeat( 0, NumClasses ) classType = repeat( 0, NumClasses ) classStyle = repeat( 0, NumClasses ) -- #2: push button className[ PushButton ] = "button" classType[ PushButton ] = BUTTON classStyle[ PushButton ] = or_all( { WS_CHILD, WS_VISIBLE, BS_PUSHBUTTON, WS_TABSTOP} ) -- #3: default push button className[ DefPushButton ] = "button" classType[ DefPushButton ] = BUTTON classStyle[ DefPushButton ] = or_all( { WS_CHILD, WS_VISIBLE, BS_DEFPUSHBUTTON, WS_TABSTOP} ) -- #4: check box className[ CheckBox ] = "button" classType[ CheckBox ] = BUTTON classStyle[ CheckBox ] = or_all( { WS_CHILD, WS_VISIBLE, BS_AUTOCHECKBOX, WS_TABSTOP} ) -- #5: tri state className[ TriCheckBox ] = "button" classType[ TriCheckBox ] = BUTTON classStyle[ TriCheckBox ] = or_all( { WS_CHILD, WS_VISIBLE, BS_AUTO3STATE, WS_TABSTOP} ) -- #6: radio className[ Radio ] = "button" classType[ Radio ] = BUTTON classStyle[ Radio ] = or_all( { WS_CHILD, WS_VISIBLE, BS_AUTORADIOBUTTON, WS_TABSTOP} ) -- #7: group className[ Group ] = "button" classType[ Group ] = BUTTON classStyle[ Group ] = or_all( { WS_CHILD, WS_VISIBLE, BS_GROUPBOX} ) -- #8: unsorted list box className[ SortedList ] = "listbox" classType[ SortedList ] = LISTBOX classStyle[ SortedList ] = or_all( { WS_CHILD, WS_VISIBLE, LBS_NOTIFY, LBS_SORT, WS_VSCROLL, WS_BORDER, WS_TABSTOP} ) -- #9: sorted list box className[ List ] = "listbox" classType[ List ] = LISTBOX classStyle[ List ] = or_all( { WS_CHILD, WS_VISIBLE, LBS_NOTIFY, WS_VSCROLL, WS_BORDER, WS_TABSTOP} ) -- #10: combo box: dropdown, edit className[ Combo ] = "combobox" classType[ Combo ] = COMBO classStyle[ Combo ] = or_all( { WS_CHILD, WS_VISIBLE, --CBS_AUTOHSCROLL, --CBS_DISABLENOSCROLL, CBS_DROPDOWN, --CBS_DROPDOWNLIST, CBS_HASSTRINGS, --CBS_LOWERCASE, --CBS_NOINTEGRALHEIGHT, --CBS_OEMCONVERT, --CBS_OWNERDRAWFIXED, --CBS_OWNERDRAWVARIABLE, --CBS_SIMPLE, --CBS_SORT, --CBS_UPPERCASE, WS_TABSTOP} ) -- #11: combo box: sorted, dropdown, edit className[ SortedCombo ] = "combobox" classType[ SortedCombo ] = COMBO classStyle[ SortedCombo ] = or_all( { WS_CHILD, WS_VISIBLE, --CBS_AUTOHSCROLL, --CBS_DISABLENOSCROLL, CBS_DROPDOWN, --CBS_DROPDOWNLIST, CBS_HASSTRINGS, --CBS_LOWERCASE, --CBS_NOINTEGRALHEIGHT, --CBS_OEMCONVERT, --CBS_OWNERDRAWFIXED, --CBS_OWNERDRAWVARIABLE, CBS_SIMPLE, CBS_SORT, --CBS_UPPERCASE, WS_TABSTOP} ) -- #12: combo box, no dropdown className[ SimpleCombo ] = "combobox" classType[ SimpleCombo ] = COMBO classStyle[ SimpleCombo ] = or_all( { WS_CHILD, WS_VISIBLE, --CBS_AUTOHSCROLL, --CBS_DISABLENOSCROLL, --CBS_DROPDOWN, --CBS_DROPDOWNLIST, CBS_HASSTRINGS, --CBS_LOWERCASE, --CBS_NOINTEGRALHEIGHT, --CBS_OEMCONVERT, --CBS_OWNERDRAWFIXED, --CBS_OWNERDRAWVARIABLE, CBS_SIMPLE, --CBS_SORT, --CBS_UPPERCASE, WS_TABSTOP} ) -- #13: list box: drop down, no edit className[ DropDownList ] = "combobox" classType[ DropDownList ] = COMBO classStyle[ DropDownList ] = or_all( { WS_CHILD, WS_VISIBLE, --CBS_AUTOHSCROLL, --CBS_DISABLENOSCROLL, --CBS_DROPDOWN, CBS_DROPDOWNLIST, CBS_HASSTRINGS, --CBS_LOWERCASE, --CBS_NOINTEGRALHEIGHT, --CBS_OEMCONVERT, --CBS_OWNERDRAWFIXED, --CBS_OWNERDRAWVARIABLE, --CBS_SIMPLE, --CBS_SORT, --CBS_UPPERCASE, WS_TABSTOP} ) -- #14: single line edit, left justified className[ EditText ] = "edit" classType[ EditText ] = EDIT classStyle[ EditText ] = or_all( { WS_CHILD, WS_VISIBLE, WS_TABSTOP, WS_BORDER, --ES_MULTILINE = #0004, -- multiline edit ES_AUTOHSCROLL, --ES_AUTOVSCROLL = #0040, -- automatic vertical scroll ES_LEFT} ) -- #15: multi line edit className[ MleText ] = "edit" classType[ MleText ] = EDIT classStyle[ MleText ] = or_all( { WS_CHILD, WS_VISIBLE, WS_TABSTOP, WS_HSCROLL, WS_VSCROLL, WS_BORDER, ES_LEFT, ES_MULTILINE} ) -- ES_AUTOHSCROLL, -- ES_AUTOVSCROLL} ) -- #16: static text, left justified className[ LText ] = "static" classType[ LText ] = STATIC classStyle[ LText ] = or_all( { WS_CHILD, WS_VISIBLE, ES_LEFT} ) -- #17: static text, right justified className[ RText ] = "static" classType[ RText ] = STATIC classStyle[ RText ] = or_all( { WS_CHILD, WS_VISIBLE, ES_RIGHT} ) -- #18: single line edit, center justified className[ CText ] = "static" classType[ CText ] = STATIC classStyle[ CText ] = or_all( { WS_CHILD, WS_VISIBLE, ES_CENTER} ) -- #19: horizontal scroll bar className[ HScroll ] = "scrollbar" classType[ HScroll ] = SCROLLBAR classStyle[ HScroll ] = or_all( { WS_CHILD, WS_VISIBLE, SBS_HORZ, WS_TABSTOP} ) -- #20: vertical scroll bar className[ VScroll ] = "scrollbar" classType[ VScroll ] = SCROLLBAR classStyle[ VScroll ] = or_all( { WS_CHILD, WS_VISIBLE, SBS_VERT, WS_TABSTOP} ) -- #21: static icon className[ Icon ] = "static" classType[ Icon ] = STATIC classStyle[ Icon ] = or_all( { WS_CHILD, WS_VISIBLE, SS_ICON} ) -- #22: static bitmap className[ Bitmap ] = "static" classType[ Bitmap ] = STATIC classStyle[ Bitmap ] = or_all( { WS_CHILD, WS_VISIBLE, SS_BITMAP} ) -- #23: menu bar item className[ Menu ] = "" classType[ Menu ] = MENU -- #24: menu item className[ MenuItem ] = "" classType[ MenuItem ] = MENUITEM -- #25: pixmap className[ Pixmap ] = "" classType[ Pixmap ] = PIXMAP atom WndProcAddress -- 32 bit address of main callback ----------------------------------------------------------------------------- atom buffer1, buffer2 buffer1 = allocate_string( repeat( ' ', 256 ) ) buffer2 = allocate_string( repeat( ' ', 256 ) ) ----------------------------------------------------------------------------- -- vectors global sequence -- NEW! 0.15 added onMouse; removed onRightClick -- NEW! 0.15b added onKeyUp, onKeyDown onMouse, onClick, onKeyPress, onKeyUp, onKeyDown, onResize, onChange, onGotFocus, onLostFocus, onScroll, -- NEW! 0.15b renamed onOpen, onDestroy; added onClose onOpen, onClose, onDestroy, onTimer, onPaint, onEvent -- NEW! 0.15 added onMouse; removed onRightClick onMouse = {} onClick = {} onKeyPress = {} onKeyUp = {} onKeyDown = {} onResize = {} onChange = {} onGotFocus = {} onLostFocus = {} onScroll = {} onOpen = {} onClose = {} onDestroy = {} onTimer = {} onPaint = {} onEvent = {} -- new! 0.15b removed global integer defaultWindow, hasDC, -- new! 0.14c modalWindow sequence modalStack hasDC = 0 -- set to none modalStack = {} -- modals under modal window modalWindow = 0 -- no modal windows -- attributes of current window atom myHdc, myId, myRect, myPs, myControl -- NEW! 0.15b changed allocate to allocate_struct myPs = allocate_struct(SIZEOF_PAINTSTRUCT) -- holds paint structure myRect = allocate_struct(SIZEOF_RECT) -- repaint rectangle -- controls sequence window, -- control setup information window_handle, -- hwnd of controls window_func, -- Long pointer to function window_class, -- control class window_tab, -- tab order if control, tab count if window window_focus, -- current focus window_owner, -- owner window_menu, -- menu in window window_font, -- font resource window_fcolor, -- foreground color window_bcolor, -- background color window_pen, -- pen: { id, color, style } window_x, -- x position window_y, -- y position window_scroll -- scroll: { small change, large change } -- initialize window = {} window_handle = {} window_func = {} window_class = {} window_tab = {} window_focus = {} window_owner = {} window_menu = {} window_font = {} window_fcolor = {} window_bcolor = {} window_pen = {} window_x = {} window_y = {} window_scroll = {} ----------------------------------------------------------------------------- global function rgb( integer r, integer g, integer b ) -- return RGB value of triad return r + ( g * 256 ) + ( b * 256 * 256 ) end function ----------------------------------------------------------------------------- -- Pen Colors global constant -- NEW! 0.15b colors now reflect the DOS palette Black = rgb( 0, 0, 0 ), Blue = rgb( 0, 0, 127 ), Green = rgb( 0, 127, 0 ), Cyan = rgb( 0, 127, 127 ), Red = rgb( 127, 0, 0 ), Magenta = rgb( 127, 0, 127 ), Brown = rgb( 127, 0, 127 ), White = rgb( 127, 127, 127 ), Gray = rgb( 127, 127, 127 ), BrightBlue = rgb( 0, 0, 255 ), BrightGreen = rgb( 0, 255, 0 ), BrightCyan = rgb( 0, 255, 255 ), BrightRed = rgb( 255, 0, 0 ), BrightMagenta = rgb( 255, 0, 255 ), Yellow = rgb( 255, 0, 255 ), BrightWhite = rgb( 255, 255, 255 ) -- NEW! 0.15e removed upper case color constants, conflicted with -- IMAGE.E constants -- Pen Styles global constant Solid = 0, Dash = 1, -- ------- Dot = 2, -- ....... DashDot = 3, -- _._._._ DashDotDot = 4 -- _.._.._ constant -- default font DefaultFontID = c_func( xGetStockObject, { SYSTEM_FONT } ), -- default pen DefaultPenID = c_func( xGetStockObject, {BLACK_PEN}), -- pen attributes -- NEW! 0.20 renamed from PenID to PenValid. If true, pen was created. PenValid = 1, PenColor = 2, PenStyle = 3, -- NEW! 0.15c changed from into an index PenROP2 = 4, -- NEW! 0.15c new value PenBkMode = 5, PenDefault = { 0, Black, Solid, R2_COPYPEN, TRANSPARENT }, -- font attributes -- NEW! 0.15 removed FontID FontName = 1, FontSize = 2, FontAttrib = 3, FontColor = 4, FontDefault = { "", 0, 0, Black } global constant Default = CW_USEDEFAULT ----------------------------------------------------------------------------- ----------------------------------------------------------------------------- -- RESOURCE TRACKING -- -- This is used to track GDI resources held by the application. -- This module is defined early on so that on an abortErr, the -- code can still run the cleanup. global constant ForPaint = 0, -- resource lives until end of onPaint ForProgram = 1 -- resource lived until end of program -- NEW! 0.20 track id along with handle constant ResHandle = 1, -- Win32 handle (primary key) ResOwner = 2, -- the resource WinLib id ResLife = 3, -- how long the resource lives NewRes = repeat( 0, 3 ) sequence heldResource, -- list of held resources, and their scope stockResource -- holds stock resources, don't need to release -- initialize heldResource = {} stockResource = {} ----------------------------------------------------------------------------- global procedure deleteObject( atom handle ) -- deletes an object if not a stock resource -- removes it from the tracking list integer at -- stock resource? if find( handle, stockResource ) then -- do nothing return end if -- try to release it if c_func( xDeleteObject, {handle} ) then -- is this a known resource? at = findKey( handle, heldResource ) if at then -- remove from list heldResource = removeIndex( at, heldResource ) end if end if end procedure -- NEW! 0.20 track owner ----------------------------------------------------------------------------- global procedure trackObject( integer owner, atom hResource, integer lifetime ) -- tracks object as held resource sequence res -- don't add to list if it's a stock resource, or already there if not find( hResource, stockResource ) and not findKey( hResource, heldResource ) then -- create a resource res = NewRes -- assign values res[ResHandle] = hResource res[ResOwner] = owner res[ResLife] = lifetime -- add the resource to the resource list heldResource = append( heldResource, res ) end if end procedure -- NEW! 0.20 added owner id ----------------------------------------------------------------------------- global procedure replaceObject( integer owner, atom hdc, atom hResource, integer lifetime ) -- adds resource tracking to selectObject -- track the object trackObject( owner, hResource, lifetime ) -- select current, replace prior deleteObject( c_func( xSelectObject, {hdc, hResource} ) ) end procedure ----------------------------------------------------------------------------- procedure releasePaintResources() -- free resources created during onPaint event integer id sequence held -- copy, because list shrinks held = heldResource -- for each resource for i = 1 to length( held ) do -- if only lives for paint event if held[i][ResLife] = ForPaint then -- NEW! 0.20 flag that resource has been deleted -- get the id id = held[i][ResOwner] -- flag that the pen needs to be recreated window_pen[id][PenValid] = 0 -- release the object deleteObject( held[i][ResHandle] ) end if end for end procedure -- NEW! 0.20 ----------------------------------------------------------------------------- procedure releaseResourcesForID( integer id ) -- free resources associated with a particular resource sequence held -- copy, because list shrinks held = heldResource -- for each resource for i = 1 to length( held ) do -- if only lives for paint event if held[i][ResLife] = ForPaint and held[i][ResOwner] = id then -- release the object deleteObject( held[i][ResHandle] ) end if end for -- flag that the pen needs to be recreated window_pen[id][PenValid] = 0 end procedure ----------------------------------------------------------------------------- procedure releaseAllResources() -- frees all resources sequence held -- copy, because list shrinks held = heldResource -- for each resource for i = 1 to length( held ) do -- release the object deleteObject( held[i][ResHandle] ) end for end procedure -- set the 'clean up' behavior xCleanUp = routine_id("releaseAllResources") -- track stock resources stockResource = { DefaultFontID, DefaultPenID } ----------------------------------------------------------------------------- function to_flag( atom a ) -- return value based on truth of first arg if a then return 1 else return 0 end if end function ----------------------------------------------------------------------------- -- -- GLOBAL PROCEDURES -- ----------------------------------------------------------------------------- global function sendMessage( integer id, atom cmd, atom wParm, atom lParm ) -- send a command to a control return c_func( xSendMessage, { window_handle[id], cmd, wParm, lParm } ) end function ----------------------------------------------------------------------------- -- NEW! 0.20d Added to resolve duplicate id's procedure setId( atom hWnd, integer id ) atom ok ok = c_func( xSetWindowLong, { hWnd, GWL_USERDATA, id } ) end procedure ----------------------------------------------------------------------------- -- NEW! 0.20d Added to resolve duplicate id's function getId( atom hWnd ) return c_func( xGetWindowLong, { hWnd, GWL_USERDATA } ) end function ----------------------------------------------------------------------------- function validId( atom id ) -- returns true if a is a valid win32lib id return ( id > 0 and id <= length( window ) ) end function sequence grabbedHDC grabbedHDC = {} -- NEW! 0.20a changed id type to atom for bitmaps ----------------------------------------------------------------------------- global function getDC( atom id ) -- get device context. -- this supports the following: atom hdc -- NEW! 0.15b handles screen -- get the device context if id = 0 then hdc = c_func( xGetDC, {0} ) if hdc = NULL then abortErr( "getDC:GetDC failed." ) end if -- NEW! 0.20 supports getting DCs of bitmaps elsif not validId( id ) then -- the id isn't a valid handle, so it must be a bitmap. -- create a memory device context compatible with the screen hdc = c_func( xCreateCompatibleDC, {NULL} ) if hdc = NULL then warnErr( "getDC:CreateCompatibleDC failed." ) end if -- select the bitmap into it if not c_func( xSelectObject, {hdc, id} ) then warnErr( "getDC:SelectObject failed." ) end if elsif hasDC = id then -- already grabbed hdc = myHdc -- NEW! 0.20 supports getting DCs of pixmap class elsif window_class[ id ] = PIXMAP then -- pixmap class -- create a memory device context compatible with the screen hdc = c_func( xCreateCompatibleDC, {NULL} ) if hdc = NULL then warnErr( "getDC:CreateCompatibleDC failed." ) end if -- select the bitmap into it if not c_func( xSelectObject, {hdc, window_handle[id]} ) then warnErr( "getDC:SelectObject failed." ) end if else hdc = c_func( xGetDC, {window_handle[ id ]} ) if hdc = NULL then abortErr( "getDC:GetDC failed." ) end if end if -- add to list grabbedHDC = prepend( grabbedHDC, hdc ) return hdc end function -- NEW! 0.20a changed id type to atom for bitmaps ----------------------------------------------------------------------------- global procedure releaseDC( atom id ) -- release the device context -- If this is called from within a paint event and the device is -- supposed to have the DC, there is no need to release it. -- was one grabbed? if length( grabbedHDC ) = 0 then warnErr( "ReleaseDC without matching GetDC." ) return -- NEW! 0.15b handles screen (0) -- release? elsif id = 0 then -- release screen if c_func( xReleaseDC, {0, grabbedHDC[1]} ) = 0 then warnErr( "releaseDC:ReleaseDC (screen) failed." ) end if -- NEW! 0.20a test uses validId -- NEW! 0.20 handles bitmaps elsif not validId( id ) then -- release the device context if not c_func( xDeleteDC, {grabbedHDC[1]} ) then warnErr( "releaseDC:DeleteDC (bitmap) failed." ) end if -- NEW! 0.20 handles pixmap elsif window_class[id] = PIXMAP then -- release the device context if not c_func( xDeleteDC, {grabbedHDC[1]} ) then warnErr( "releaseDC:DeleteDC (Pixmap) failed." ) end if -- release the resources. the next getDC will create a new -- DC for the pixmap, invalidating the resources anyway. releaseResourcesForID( id ) elsif hasDC != id then -- release, not held by paint if c_func( xReleaseDC, {window_handle[ id ], grabbedHDC[1]} ) = 0 then warnErr( "releaseDC:ReleaseDC failed." ) end if -- release resources releaseResourcesForID( id ) end if -- remove from grabbed list list grabbedHDC = grabbedHDC[2..length(grabbedHDC)] end procedure -- NEW! 0.2a changed parm to atom, check with validId ----------------------------------------------------------------------------- global function getHandle( atom id ) -- return the handle for the window -- returns 0 if not a valid id -- in range? if validId( id ) then -- return handle return window_handle[ id ] else -- error. return false return 0 end if end function -- NEW! 0.16c ----------------------------------------------------------------------------- global function getSelf() -- return id of current active control return myId end function -- NEW! 0.20 moved position in file ----------------------------------------------------------------------------- -- CREATING CONTROLS -- ----------------------------------------------------------------------------- procedure createMenu( integer id, sequence mText, integer owner ) -- used to assign a menu to a window -- the structure is already created by create() -- set the class to menu object attachTo window_class[ id ] = MENU -- NEW! 0.15c Michael Sabal's patch -- if there is no menu for this window, create one if window_menu[ owner ] = 0 and window_class[owner] = WINDOW then -- create a menu window_menu[ owner ] = c_func( xCreateMenu, {} ) if window_handle[ id ] = NULL then -- couldn't create it warnErr( "CreateMenu in createMenu failed." ) end if -- attach the menu to the window if not c_func( xSetMenu, { window_handle[ owner ], window_menu[ owner ] } ) then warnErr( "SetMenu in createMenu failed." ) end if end if -- where does this attach to? if window_class[owner] = MENU or window_class[owner] = MENUITEM then attachTo = window_handle[owner] elsif window_class[owner] = WINDOW then attachTo = window_menu[owner] end if -- create popup menu for this item window_handle[ id ] = c_func( xCreatePopupMenu, {} ) if window_handle[ id ] = NULL then warnErr( "CreatePopupMenu in CreateMenu failed." ) end if -- attach a menu item if not c_func( xAppendMenu, { attachTo, MF_POPUP, window_handle[ id ], allot_string( mText )} ) then -- error warnErr( "AppendMenu in createMenu failed." ) end if -- free the string free_strings() end procedure ----------------------------------------------------------------------------- procedure createMenuItem( integer id, sequence mText, integer owner ) integer flag -- set the class to menu item window_class[ id ] = MENUITEM -- store owner's handle window_handle[ id ] = window_handle[ owner ] -- string, or seperator? flag = iif( equal( mText, "-" ), MF_SEPARATOR, MF_STRING ) -- create a menu item if not c_func( xAppendMenu, { window_handle[ owner ], -- menu to attach to flag, -- string or seperator id, -- id allot_string( mText )} ) -- text then -- error warnErr( "AppendMenu in createMenuItem failed." ) end if -- free the string free_strings() end procedure ----------------------------------------------------------------------------- global procedure createWindow( integer id ) -- create a window -- main routine atom szAppName atom hWnd atom msg atom wndClassEx atom class atom flags atom hMenu atom hMenuPopup sequence title atom x, y, xSize, ySize -- give the control a unique name szAppName = allot_string( sprintf( "Win32Lib%d", {id} ) ) -- NEW! 0.15b changed allocate to allocate_struct wndClassEx = allocate_struct(SIZEOF_WNDCLASSEX) -- get values of window title = window[id][3] x = window[id][4] y = window[id][5] xSize = window[id][6] ySize = window[id][7] flags = window[id][8] -- build the structure store( wndClassEx, winExSize, SIZEOF_WNDCLASSEX) store( wndClassEx, winExStyle, or_all({CS_HREDRAW, CS_VREDRAW })) store( wndClassEx, winExProc, WndProcAddress) store( wndClassEx, winExClsExtra, 0) store( wndClassEx, winExExtra, 0) store( wndClassEx, winExInstance, 0) store( wndClassEx, winExIcon, c_func( xLoadIcon, { NULL, IDI_APPLICATION } ) ) store( wndClassEx, winExCursor, c_func( xLoadCursor, { NULL, IDC_ARROW } ) ) store( wndClassEx, winExBackground, COLOR_WINDOWFRAME ) store( wndClassEx, winExMenuName, NULL) store( wndClassEx, winExClassName, szAppName ) store( wndClassEx, winExIconSm, c_func( xLoadIcon, { NULL, IDI_APPLICATION } ) ) class = c_func( xRegisterClassEx, { wndClassEx } ) if class = 0 then abortErr( "RegisterClassEx in createWindow failed." ) end if -- use default is flags are not set if flags = 0 then flags = or_bits( flags, WS_OVERLAPPEDWINDOW ) end if hWnd = c_func( xCreateWindow, { 0, -- extended style szAppName, -- window class name allot_string(title), -- window caption flags, -- window style x, -- initial x position y, -- initial y position xSize, -- initial x size ySize, -- initial y size NULL, -- parent window handle NULL, -- window menu handle 0, -- program instance handle NULL } ) -- creation parameters if hWnd = 0 then abortErr( "CreateWindow in createWindow failed." ) end if -- save attributes -- NEW! 0.20d Added to resolve duplicate id's setId( hWnd, id ) window_handle[ id ] = hWnd window_class[ id ] = WINDOW window_owner[ id ] = 0 -- free the strings used in the structure free_strings() end procedure -- NEW! 0.20 ----------------------------------------------------------------------------- procedure createPixmap( integer id, integer x, integer y ) atom hdc, handle -- store class window_class[ id ] = PIXMAP -- need to initialize pixmap? if x != 0 and y != 0 then -- get the dc of the screen hdc = getDC( 0 ) -- create a window sized bitmap compatible with the screen handle = c_func( xCreateCompatibleBitmap, { hdc, x, y } ) if handle = NULL then warnErr( "createPixmap:CreateCompatibleBitmap failed" ) end if -- release the dc releaseDC( 0 ) -- store the handle window_handle[ id ] = handle -- track the bitmap as a resource trackObject( id, handle, ForProgram ) else -- store zero window_handle[ id ] = 0 end if end procedure ----------------------------------------------------------------------------- global function create( integer typeOf, sequence title, atom owner, atom x, atom y, atom xSize, atom ySize, atom styleFlags ) integer id atom style, response, hWnd sequence class -- add to windows window = append( window, { owner, typeOf, title, x, y, xSize, ySize, styleFlags } ) -- get index id = length( window ) -- allocate control space -- the window_fcolor should probably be set based on the -- syscolor. window_handle = append( window_handle, -1 ) window_func = append( window_func, -1 ) window_class = append( window_class, -1 ) window_tab = append( window_tab, 0 ) window_focus = append( window_focus, 0 ) window_owner = append( window_owner, owner ) window_x = append( window_x, 0 ) window_y = append( window_y, 0 ) window_font = append( window_font, FontDefault ) window_pen = append( window_pen, PenDefault ) window_fcolor = append( window_fcolor, Black ) window_bcolor = append( window_bcolor, White ) window_scroll = append( window_scroll, {1,10} ) window_menu = append( window_menu, 0 ) -- allocate event handlers -- NEW! 0.15 added onMouse, removed onRightClick onMouse = append( onMouse, -1 ) onClick = append( onClick, -1 ) onKeyPress = append( onKeyPress, -1 ) -- NEW! 0.15b added onKeyUp and onKeyDown onKeyUp = append( onKeyUp, -1 ) onKeyDown = append( onKeyDown, -1 ) onResize = append( onResize, -1 ) onChange = append( onChange, -1 ) onGotFocus = append( onGotFocus, -1 ) onLostFocus = append( onLostFocus, -1 ) -- NEW! 0.15b added onClose; renamed onOpen, onDestroy onOpen = append( onOpen, -1 ) onClose = append( onClose, -1 ) onDestroy = append( onDestroy, -1 ) onScroll = append( onScroll, -1 ) onTimer = append( onTimer, -1 ) onPaint = append( onPaint, -1 ) onEvent = append( onEvent, -1 ) -- actual creation if typeOf = Window then -- create a window createWindow( id ) elsif typeOf = Menu then -- create a menu bar createMenu( id, title, owner ) elsif typeOf = MenuItem then -- create a menu bar item createMenuItem( id, title, owner ) -- NEW! 0.20 elsif typeOf = Pixmap then -- create a pixmap item createPixmap( id, xSize, ySize ) else -- move class name to buffer poke( buffer1, className[ typeOf ] & 0 ) -- move title to buffer poke( buffer2, title & 0 ) -- include the user flags styleFlags = or_bits( classStyle[ typeOf ], styleFlags ) -- create control hWnd = c_func( xCreateWindow, { 0, -- extended style buffer1, -- window class name buffer2, -- window caption styleFlags, -- window style x, -- initial x position y, -- initial y position xSize, -- initial x size ySize, -- initial y size getHandle( owner ), -- parent window handle NULL, -- window menu handle 0, -- program instance handle NULL} ) -- creation parameters -- NEW! 0.20d Added to resolve duplicate id's -- save the handle with the control setId( hWnd, id ) -- save the handle in the sequence window_handle[id] = hWnd -- save address of original class routine; -- replace it with a handle to the original window_func[id] = c_func( xSetWindowLong, { hWnd, GWL_WndProc, WndProcAddress } ) -- save class message type window_class[id] = classType[ typeOf ] -- save tab order with owner if the attribute is tab stop if and_bits( WS_TABSTOP, styleFlags ) then -- increment tab count window_tab[owner] = window_tab[owner] + 1 -- set tab number window_tab[id] = window_tab[owner] end if -- scroll bar? if window_class[id] = SCROLLBAR then -- set scroll range -- setScrollRange( id, 1, 100 ) end if end if return id end function ----------------------------------------------------------------------------- -- FONTS -- ----------------------------------------------------------------------------- global function EzCreateFont( integer id, atom hdc, sequence faceName, integer iDeciPtHeight, integer iDeciPtWidth, integer iAttributes, integer fLogRes ) -- faceName : font name -- iDeciPtHeight: font size, * 10 (i.e.: 125 = 12.5 points -- iDeciPtWidth : typically zero, but allows altering width -- iAttributes : flags for attributes, see Bold, etc. -- fLogRes : if true, uses logical resolution instead of screen res. atom cxDpi, cyDpi atom hFont atom lf atom pt atom tm integer boldFlag, italicFlag, underlineFlag, strikeOutFlag -- allot structures -- logical font -- NEW! 0.15b changed allocate to allocate_struct lf = allocate_struct( SIZEOF_LOGFONT ) -- point pt = allocate_struct( SIZEOF_POINT ) -- text metric tm = allocate_struct( SIZEOF_TEXTMETRIC ) -- save the current device context if not c_func( xSaveDC, {hdc} ) then abortErr( "ezCreateFont:SaveDC failed." ) end if -- these are NT specific. they should have no effect in Win95 ok = c_func( xSetGraphicsMode, {hdc, GM_ADVANCED} ) ok = c_func( xModifyWorldTransform, {hdc, NULL, MWT_IDENTITY} ) if not c_func( xSetViewportOrgEx, {hdc, 0, 0, NULL} ) then abortErr( "ezCreateFont:SetViewportOrgEx failed." ) end if if not c_func( xSetWindowOrgEx, {hdc, 0, 0, NULL} ) then abortErr( "ezCreateFont:SetWindowOrgEx failed." ) end if if ( fLogRes ) then cxDpi = c_func( xGetDeviceCaps, {hdc, LOGPIXELSX} ) cyDpi = c_func( xGetDeviceCaps, {hdc, LOGPIXELSY} ) else cxDpi = (25.4 * c_func( xGetDeviceCaps, {hdc, HORZRES} ) / c_func( xGetDeviceCaps, {hdc, HORZSIZE} ) ) cyDpi = (25.4 * c_func( xGetDeviceCaps, {hdc, VERTRES} ) / c_func( xGetDeviceCaps, {hdc, VERTSIZE} ) ) end if store( pt,ptX, iDeciPtWidth * cxDpi / 72 ) store( pt,ptY, iDeciPtHeight * cyDpi / 72 ) if not c_func( xDPtoLP, {hdc, pt, 1} ) then abortErr( "ezCreateFont:DPtoLP failed." ) end if -- check flags boldFlag = to_flag( and_bits( iAttributes, Bold) ) * 700 italicFlag = to_flag( and_bits( iAttributes, Italic) ) underlineFlag = to_flag( and_bits( iAttributes, Underline) ) strikeOutFlag = to_flag( and_bits( iAttributes, Strikeout) ) -- populate the structure store( lf, lfHeight, -floor(abs( fetch( pt,ptY ) / 10.0 + 0.5 ))) store( lf, lfWidth, 0 ) store( lf, lfEscapement, 0 ) store( lf, lfOrientation, 0 ) store( lf, lfWeight, boldFlag ) store( lf, lfItalic, italicFlag ) store( lf, lfUnderline, underlineFlag ) store( lf, lfStrikeOut, strikeOutFlag ) store( lf, lfCharSet, 0 ) store( lf, lfOutPrecision, 0 ) store( lf, lfClipPrecision, 0 ) store( lf, lfQuality, 0 ) store( lf, lfPitchAndFamily, 0 ) store( lf, lfFaceName, faceName & 0 ) -- create the font hFont = c_func( xCreateFontIndirect, {lf} ) if (iDeciPtWidth != 0 ) then -- replace the current font replaceObject( id, hdc, hFont, ForProgram ) -- get the text metrics on the font if not c_func( xGetTextMetrics, {hdc, tm} ) then abortErr( "ezCreateFont:SetTextMetrics failed." ) end if -- calculate the new size store( lf, lfWidth, floor( fetch(tm,tmAveCharWidth) * abs( fetch(pt,ptX) ) / abs( fetch(pt,ptY) ) + 0.5 ) ) -- build the font hFont = c_func( xCreateFontIndirect, {lf} ) end if -- restore the device context if not c_func( xRestoreDC, {hdc, -1} ) then abortErr( "ezCreateFont:RestoreDC failed." ) end if -- release structures free( lf ) free( pt ) free( tm ) -- return handle to font return hFont end function ----------------------------------------------------------------------------- procedure putFontIntoHDC( atom hdc, integer id ) -- set font into the hdc, using the attributes of the font -- interfaces to EzCreateFont -- this is shared by wPuts, getFontSize and getTextExtent atom fontID object result -- need to create a font based on the attributes? if length( window_font[id][FontName] ) then -- NEW! 0.20a pass hdc to EzCreateFont instead of id -- call EzCreateFont to build the font fontID = EzCreateFont( id, hdc, -- create font window_font[id][FontName], -- font name window_font[id][FontSize]*10, -- points 0, window_font[id][FontAttrib], -- attributes 0 ) else -- get the stock system font object fontID = DefaultFontID end if -- replace the font replaceObject( id, hdc, fontID, ForProgram ) -- use the pen color? if c_func(xSetTextColor, {hdc, window_font[id][FontColor]} ) = CLR_INVALID then -- unable to set color warnErr( "SetTextColor in putFontIntoHDC failed." ) end if -- NEW! 0.15c user can alter mode -- set transparent or opaque if not c_func(xSetBkMode, {hdc, window_pen[id][PenBkMode]} ) then -- unable to set mode warnErr( "SetBkMode in putFontIntoHDC failed." ) end if end procedure ----------------------------------------------------------------------------- global procedure wPuts( integer id, object s ) -- this is the text display routine. -- all other text routines must call it, since it does the actual -- creation of the font for the context. atom hdc, result -- if the parameter is a byte, convert it to a sequence if integer( s ) then -- convert it to a string s = {s} end if -- get the device context hdc = getDC( id ) -- set the font putFontIntoHDC( hdc, id ) if length( s ) then -- display the text in the buffer c_proc( xTextOut, { hdc, window_x[id], window_y[id], allot_string( s ), length( s ) } ) -- free the string free_strings() end if -- replace the font replaceObject( id, hdc, DefaultFontID, ForProgram ) -- release the device context releaseDC( id ) end procedure ----------------------------------------------------------------------------- global procedure wPrintf( integer id, sequence s1, sequence s2 ) -- use wPuts to display message wPuts( id, sprintf( s1, s2 ) ) end procedure ----------------------------------------------------------------------------- function print_format( object o ) -- returns object formatted for wPrint sequence s if atom( o ) then -- number return sprintf( "%d", o ) else -- list s = "{" for i = 1 to length( o ) do s = s & print_format( o[i] ) -- NEW! 0.14 -- changed length(s) to length(o) if i < length( o ) then s = s & "," end if end for s = s & "}" return s end if end function ----------------------------------------------------------------------------- global procedure wPrint( integer id, object o ) -- win32 version of Euphoria's print statement -- use wPuts to display message wPuts( id, print_format( o ) ) end procedure ----------------------------------------------------------------------------- global procedure setFont( integer id, sequence faceName, integer points, integer attrib ) -- set the current font attributes -- Window fonts are set as attributes for later assignment -- Control fonts assign fonts with WM_SETFONT atom hFont, hdc -- NEW! 0.20a pixmap support if window_class[id] = WINDOW or window_class[id] = PIXMAP then -- defer creation until print event window_font[id][FontName] = faceName window_font[id][FontSize] = points window_font[id][FontAttrib] = attrib else -- NEW! 0.20a moved getDC out of EzCreateFont -- get the DC hdc = getDC( id ) -- create now hFont = EzCreateFont( id, hdc, faceName, points * 10, 0, attrib, 0 ) -- release the dc releaseDC( id ) -- update immediately ok = sendMessage( id, WM_SETFONT, hFont, -1 ) -- track it trackObject( id, hFont, ForProgram ) end if end procedure ----------------------------------------------------------------------------- global procedure setDefaultFont( integer id ) -- set font to default system font -- Window fonts are set as attributes for later assignment -- Control fonts assign fonts with WM_SETFONT -- NEW! 0.20a pixmap support if window_class[id] = WINDOW or window_class[id] = PIXMAP then -- defer creation until print event window_font[id][FontName] = "" else -- replace the current font with the default replaceObject( id, getHandle( id ), DefaultFontID, ForProgram ) -- update immediately ok = sendMessage( id, WM_SETFONT, DefaultFontID, -1 ) end if end procedure ----------------------------------------------------------------------------- global function getFontSize( integer id ) -- get metrics for current font integer width, height atom tm, hdc, hFont, saved sequence fnt -- text metric structure tm = allocate_struct( SIZEOF_TEXTMETRIC ) -- get the window's dc hdc = c_func( xGetDC, {window_handle[ id ]} ) if hdc = NULL then abortErr( "GetDC in getFontSize failed." ) end if -- NEW! 0.20 removed save/restore calls; not needed -- save the current device context -- if not c_func( xSaveDC, {hdc} ) then -- abortErr( "SaveDC in getFontSize failed." ) -- end if -- realize the font putFontIntoHDC( hdc, id ) -- get the metrics of the font if not c_func( xGetTextMetrics, {hdc, tm} ) then abortErr( "GetTextMetrics in getFontSize failed." ) end if -- assign values width = fetch(tm,tmAveCharWidth) height = fetch(tm,tmHeight) -- restore the device context -- if not c_func( xRestoreDC, {hdc, -1} ) then -- abortErr( "RestoreDC in getFontSize failed." ) -- end if -- release structures free( tm ) -- return results return { width, height } end function -- NEW! 0.20a replaces getFontSize ----------------------------------------------------------------------------- global function getTextExtent( integer id, sequence text ) -- get metrics for current font integer width, height atom size, hdc, string -- allocate structures size = allocate_struct( SIZEOF_SIZE ) string = allocate_string( text ) -- get the window's dc hdc = getDC( id ) -- realize the font putFontIntoHDC( hdc, id ) -- get the metrics of the font if not c_func( xGetTextExtentPoint, {hdc, string, length(text), size} ) then abortErr( "getTextExtent:GetTextExtentPoint failed." ) end if -- assign values width = fetch(size,sizX ) height = fetch(size,sizY) -- release the dc releaseDC( id ) -- release structures free( size ) free( string ) -- return results return { width, height } end function ----------------------------------------------------------------------------- -- SCREEN DISPLAY -- ----------------------------------------------------------------------------- global procedure setPosition( integer id, integer x, integer y ) -- set the window cursor position window_x[id] = x window_y[id] = y end procedure ----------------------------------------------------------------------------- procedure flush_paint_event( atom hWnd ) -- force redraw without clearing window -- this needs to handle multiple windows! -- NEW! 0.20d replaced myHwnd with hWnd if not c_func( xInvalidateRect, {hWnd, NULL, 0} ) then abortErr( "InvalidateRect in flushPaintEvent failed." ) end if end procedure ----------------------------------------------------------------------------- global procedure repaintWindow( integer id ) -- redraws *everything* atom hwnd -- get handle hwnd = window_handle[id] -- invalidate all of the current window, and clear it if not c_func( xInvalidateRect, {hwnd, NULL, 1} ) then abortErr( "InvalidateRect in repaintWindow failed." ) end if -- trigger an immediate paint message ok = sendMessage( id, WM_PAINT, 0, 0 ) end procedure ----------------------------------------------------------------------------- global procedure repaintRect( integer id, integer x1, integer y1, integer x2, integer y2 ) -- invalidates only a portion of the window atom hWnd atom rect -- allocate rectangle -- NEW! 0.15b changed allocate to allocate_struct rect = allocate_struct( SIZEOF_RECT ) store( rect, rectLeft, x1 ) store( rect, rectTop, y1 ) store( rect, rectRight, x2 ) store( rect, rectBottom, y2 ) -- get handle hWnd = window_handle[id] -- invalidate all of the current window, and clear it if not c_func( xInvalidateRect, {hWnd, rect, 1} ) then warnErr( "InvalidateRect in repaintRect failed." ) end if -- free the rectangle structure free( rect ) -- trigger an immediate paint message ok = sendMessage( id, WM_PAINT, 0, 0 ) end procedure -- NEW! 0.20a changed parameter to atom ----------------------------------------------------------------------------- global function getSize( atom id ) -- get metrics for current window -- returns { left, top, bottom, right } integer top, bottom, left, right, viewTop, viewLeft atom struct, pt, hdc -- NEW! 0.20 supports screen if id = 0 then -- get dc of screen hdc = getDC( 0 ) -- screen top = 0 left = 0 right = c_func( xGetDeviceCaps, {hdc, HORZRES} ) bottom = c_func( xGetDeviceCaps, {hdc, VERTRES} ) -- release dc releaseDC( 0 ) -- NEW! 0.20a supports bitmaps elsif not validId( id ) then -- probably passed a bitmap -- allocate a buffer to hold bitmap information struct = allocate( SIZEOF_BITMAP ) -- load bitmap data into structure if not c_func( xGetObject, { id, SIZEOF_BITMAP, struct} ) then warnErr( "getSize:GetObject failed." ) end if -- get the values from the bitmap top = 0 left = 0 right = fetch( struct, bmWidth ) bottom = fetch( struct, bmHeight ) -- free structure free( struct ) -- NEW! 0.20 Supports pixmap class elsif window_class[ id ] = PIXMAP then -- not allocated? if window_handle[ id ] = 0 then -- empty return {0,0} end if -- allocate a buffer to hold bitmap information struct = allocate( SIZEOF_BITMAP ) -- load bitmap data into structure if not c_func( xGetObject, { getHandle(id), SIZEOF_BITMAP, struct} ) then warnErr( "getSize:GetObject failed." ) end if -- get the values from the bitmap top = 0 left = 0 right = fetch( struct, bmWidth ) bottom = fetch( struct, bmHeight ) -- free structure free( struct ) else -- allocate a buffer to hold the rectangle information struct = allocate_struct( SIZEOF_RECT ) -- load rectangle information into the buffer if not c_func( xGetWindowRect, { getHandle( id ), struct } ) then abortErr( "getSize:GetWindowRect failed." ) end if -- get points left = fetch( struct, rectLeft ) top = fetch( struct, rectTop ) right = fetch( struct, rectRight ) bottom = fetch( struct, rectBottom ) -- is it owned by a window? if window_owner[ id ] then -- allocate a point structure pt = allocate_struct( SIZEOF_POINT ) -- set to owner window id = window_owner[ id ] -- set to client (0, 0) store( pt, ptX, 0 ) store( pt, ptY, 0 ) -- convert to screen space if not c_func( xClientToScreen, { window_handle[ id ], pt } ) then abortErr( "getSize:ClientToScreen failed." ) end if -- get position viewLeft = fetch( pt, ptX ) viewTop = fetch( pt, ptY ) -- adjust points left = left - viewLeft right = right - viewLeft top = top - viewTop bottom = bottom - viewTop -- free point free( pt ) end if -- free structure free( struct ) end if -- return values return { left, top, right, bottom } end function -- NEW! 0.20a type changed to atom (Greg Harris) ----------------------------------------------------------------------------- global function getExtent( atom id ) -- get { deep, wide } for the requested item sequence s -- get size s = getSize( id ) -- subtract difference return { s[3]-s[1], s[4]-s[2] } end function ----------------------------------------------------------------------------- -- GENERIC CONTROLS -- ----------------------------------------------------------------------------- function getMenuState( integer id ) -- get menu state return c_func( xGetMenuState, { window_handle[ id ], id, 0 } ) end function ----------------------------------------------------------------------------- global procedure setText( integer id, sequence s ) -- set the text in a window atom ptr ptr = allocate_string( s ) if not c_func( xSetWindowText, { window_handle[ id ], ptr } ) then warnErr( "SetWindowText in setText failed." ) end if free( ptr ) end procedure ----------------------------------------------------------------------------- global function getText( integer id ) -- get the text in a window integer at, iLength atom buffer, hWnd sequence text -- get the handle hWnd = window_handle[ id ] -- edit controls -- NEW! 0.15a -- get the text size; add 1 for /0 iLength = c_func( xGetWindowTextLength, { hWnd } ) + 1 -- NEW! 0.15a -- no item? if iLength = 0 then return "" end if -- allocate a buffer -- NEW! 0.15b changed allocate to allocate_struct buffer = allocate_struct( iLength ) -- move the text to a buffer iLength = c_func( xGetWindowText, { hWnd, buffer, iLength } ) -- get the text text = peek( {buffer, iLength} ) -- release the buffer free( buffer ) -- return the string return text end function ----------------------------------------------------------------------------- global procedure setVisible( integer id, integer flag ) if flag then -- show a window ok = c_func( xShowWindow, { window_handle[ id ], SW_SHOWNORMAL } ) else -- hide a window ok = c_func( xShowWindow, { window_handle[ id ], SW_HIDE } ) end if end procedure ----------------------------------------------------------------------------- global function isVisible( integer id ) -- return hidden state of control return c_func( xIsWindowVisible, { window_handle[ id ] } ) end function ----------------------------------------------------------------------------- global procedure setEnable( integer id, integer flag ) -- enable/disable an item if window_class[ id ] = MENU or window_class[ id ] = MENUITEM then -- convert the flag flag = iif( flag, MF_ENABLED, or_all( {MF_DISABLED, MF_GRAYED} ) ) -- enable/disable the menu if c_func( xEnableMenuItem, { window_handle[ id ], -- menu handle id, -- id flag} )= #FFFFFFFF -- enable/disble then -- item does not exist warnErr( "EnableMenuItem in enableMenuItem failed." ) end if -- if menubar, need to redraw if window_class[ id ] = MENU then ok = c_func( xDrawMenuBar, { window_owner[ id ] } ) end if else -- enable/disable the window c_proc( xEnableWindow, { window_handle[ id ], flag } ) end if end procedure ----------------------------------------------------------------------------- global function isEnabled( integer id ) -- return enabled state of control atom result if window_class[ id ] = MENU or window_class[ id ] = MENUITEM then -- true if not disabled return not and_bits( getMenuState(id), MF_DISABLED ) else -- control return c_func( xIsWindowEnabled, { window_handle[ id ] } ) end if end function ----------------------------------------------------------------------------- global procedure setCheck( integer id, integer flag ) if window_class[ id ] = MENU or window_class[ id ] = MENUITEM then -- convert the flag flag = iif( flag, MF_CHECKED, MF_UNCHECKED ) -- set the check in the menu if c_func( xCheckMenuItem, { window_handle[id], -- owner's menu handle id, -- use the id flag} )= #FFFFFFFF -- check/uncheck then -- item does not exist warnErr( "CheckMenuItem in checkMenuItem failed." ) end if -- if menubar, need to redraw if window_class[ id ] = MENU then ok = c_func( xDrawMenuBar, { window_owner[ id ] } ) end if else -- toggle the control ok = sendMessage( id, BM_SETCHECK, flag, 0 ) end if end procedure ----------------------------------------------------------------------------- global function isChecked( integer id ) -- return checked state of control if window_class[ id ] = MENU or window_class[ id ] = MENUITEM then -- true if not disabled return and_bits( getMenuState(id), MF_CHECKED ) else -- controls return sendMessage( id, BM_GETCHECK, 0, 0 ) end if end function ----------------------------------------------------------------------------- global procedure cut( integer id ) -- send a cut request to a window ok = sendMessage( id, WM_CUT, 0, 0 ) end procedure ----------------------------------------------------------------------------- global procedure copy( integer id ) -- send a copy request to a window ok = sendMessage( id, WM_COPY, 0, 0 ) end procedure ----------------------------------------------------------------------------- global procedure paste( integer id ) -- send a paste request to a window ok = sendMessage( id, WM_PASTE, 0, 0 ) end procedure ----------------------------------------------------------------------------- global procedure clear( integer id ) -- send a clear request to a window ok = sendMessage( id, WM_CUT, 0, 0 ) end procedure ----------------------------------------------------------------------------- global procedure undo( integer id ) -- send a undo request to a window ok = sendMessage( id, WM_UNDO, 0, 0 ) end procedure ----------------------------------------------------------------------------- -- LISTS -- ----------------------------------------------------------------------------- global procedure addItem( integer id, sequence text ) -- add an item to a list integer msg -- what control is it? if window_class[ id ] = LISTBOX then msg = LB_ADDSTRING elsif window_class[ id ] = COMBO then msg = CB_ADDSTRING else return end if -- send a message ok = sendMessage( id, msg, 0, allot_string( text ) ) -- free the string free_strings() end procedure ----------------------------------------------------------------------------- global function insertItem( atom id, sequence text, integer pos ) -- inserts string to list integer msg -- get the message, based on control type if window_class[ id ] = LISTBOX then msg = LB_INSERTSTRING elsif window_class[ id ] = COMBO then msg = CB_INSERTSTRING end if -- NEW! 0.15a added the (1 based) position to the argument -- send a message ok = sendMessage( id, msg, pos+1, allot_string( text ) ) -- free the string free_strings() -- NEW! 0.15a indexes start at 1 -- return position return ok+1 end function ----------------------------------------------------------------------------- global function deleteItem( atom id, integer pos ) -- deletes an item at position integer msg -- get the message, based on control type if window_class[ id ] = LISTBOX then msg = LB_DELETESTRING elsif window_class[ id ] = COMBO then msg = CB_DELETESTRING end if -- NEW! 0.15a indexes start at 1 return sendMessage( id, msg, pos-1, 0 ) end function ----------------------------------------------------------------------------- global function getCount( atom id ) -- get count of items in list integer msg -- get the message, based on control type if window_class[ id ] = LISTBOX then msg = LB_GETCOUNT elsif window_class[ id ] = COMBO then msg = CB_GETCOUNT end if return sendMessage( id, msg, 0, 0 ) end function ----------------------------------------------------------------------------- global function getIndex( atom id ) -- get index of selected list item integer msg -- get the message, based on control type if window_class[ id ] = LISTBOX then msg = LB_GETCURSEL elsif window_class[ id ] = COMBO then msg = CB_GETCURSEL end if -- NEW! 0.15a Index starts at 1 return sendMessage( id, msg, 0, 0 )+1 end function ----------------------------------------------------------------------------- global procedure setIndex( atom id, integer index ) -- set index of list, returns -1 on error integer msg atom result -- get the message, based on control type if window_class[ id ] = LISTBOX then msg = LB_SETCURSEL elsif window_class[ id ] = COMBO then msg = CB_SETCURSEL end if -- NEW! 0.15a index starts at 1 if sendMessage( id, msg, index-1, 0 ) = -1 then warnErr( "sendMessage(" & msg & ") in setIndex failed." ) end if end procedure ----------------------------------------------------------------------------- global function getItem( atom id, integer item ) -- get text of requested item integer msg, iLength atom buffer sequence text -- NEW! 0.14c -- correct class? if window_class[ id ] != LISTBOX and window_class[ id ] != COMBO then warnErr( "getItem requested and class not LISTBOX or COMBO" ) return "" end if -- get the message, based on control type if window_class[ id ] = LISTBOX then msg = LB_GETTEXTLEN elsif window_class[ id ] = COMBO then msg = CB_GETLBTEXTLEN end if -- NEW! 0.15a correction to size -- NEW! 0.15a index starts at 1 -- get the text size; add 1 for /0 iLength = sendMessage( id, msg, item-1, 0 ) + 1 -- NEW! 0.15a -- no item? if iLength = 0 then return "" end if -- allocate a buffer -- NEW! 0.15b changed allocate to allocate_struct buffer = allocate_struct( iLength ) -- get the message, based on control type if window_class[ id ] = LISTBOX then msg = LB_GETTEXT elsif window_class[ id ] = COMBO then msg = CB_GETLBTEXT end if -- NEW! 0.15a index starts at 1 -- move the text to a buffer ok = sendMessage( id, msg, item-1, buffer ) -- get the text text = peek( {buffer, iLength} ) -- release the buffer free( buffer ) return text end function ----------------------------------------------------------------------------- global procedure eraseItems( atom id ) -- clear a list integer msg -- get the message, based on control type if window_class[ id ] = LISTBOX then msg = LB_RESETCONTENT elsif window_class[ id ] = COMBO then msg = CB_RESETCONTENT end if ok = sendMessage( id, msg, 0, 0 ) end procedure ----------------------------------------------------------------------------- -- SCROLL BARS -- ----------------------------------------------------------------------------- global procedure setScrollChange( integer id, atom low, atom high ) -- set the "line" and "page" change amount for scroll bar window_scroll[id] = { low, high } end procedure ----------------------------------------------------------------------------- global function getScrollChange( integer id ) -- return the "line change" amount for scroll bar return window_scroll[ id ][ MY_SMALLCHANGE..MY_LARGECHANGE ] end function ----------------------------------------------------------------------------- global procedure setScrollRange( integer id, integer min, integer max ) -- set the allowable range for a scroll bar atom sif -- what type of control? if window_class[ id ] = SCROLLBAR then -- scroll bar -- allocate structure -- NEW! 0.15b changed allocate to allocate_struct sif = allocate_struct( SIZEOF_SCROLLINFO ) -- store values store( sif, sifSize, SIZEOF_SCROLLINFO ) store( sif, sifMask, SIF_RANGE ) store( sif, sifMin, min ) store( sif, sifMax, max ) -- function call ok = c_func( xSetScrollInfo, { window_handle[ id ], -- handle SB_CTL, -- scroll bar control sif, -- pointer to structure 0 } ) -- redraw flag -- free structure free( sif ) end if end procedure ----------------------------------------------------------------------------- global function getScrollRange( integer id ) -- set the allowable range for a scroll bar if window_class[ id ] = SCROLLBAR then -- scroll bar -- function call if not c_func( xGetScrollRange, { window_handle[ id ], -- handle SB_CTL, -- scroll bar control buffer1, -- min buffer2 } ) -- max then warnErr( "GetScrollRange in getScrollRange failed." ) end if -- return the values return { peek4s( buffer1 ), peek4s( buffer2 ) } else -- not implemented yet return { 0, 0 } end if end function ----------------------------------------------------------------------------- global procedure setScrollPos( integer id, atom pos ) -- return the value of the scroll bar if window_class[ id ] = SCROLLBAR then -- scroll bar -- position must be greater than zero if pos > 0 then -- call the function if not c_func( xSetScrollPos, { window_handle[ id ], -- handle SB_CTL, -- scroll bar specific pos, -- new scroll bar position 1 } ) -- redraw flag then -- warnErr( "SetScrollPos in setScrollPos failed." ) end if -- run the event code, if any if onScroll[ id ] != -1 then call_proc( onScroll[id], {pos} ) end if end if else -- not implemented yet end if end procedure ----------------------------------------------------------------------------- global function getScrollPos( integer id ) -- return the value of the scroll bar if window_class[ id ] = SCROLLBAR then -- scroll bar -- call the function return c_func( xGetScrollPos, { window_handle[ id ], -- handle SB_CTL } ) -- scroll bar specific else -- not implemented yet return 0 end if end function ----------------------------------------------------------------------------- -- GRAPHICS -- ----------------------------------------------------------------------------- global procedure setTextColor( integer id, atom color ) -- set the text color for the window window_font[id][FontColor] = color end procedure ----------------------------------------------------------------------------- global procedure setBackColor( integer id, atom color ) -- set the background color for the window if c_func(xSetBkColor, {window_handle[id], color} ) = CLR_INVALID then warnErr( "SetBkColor in setBackColor failed." ) end if end procedure ----------------------------------------------------------------------------- -- NEW! 0.15 requires hDC to call procedure createPen( integer id, atom hdc ) -- make sure the pen is set atom result, rop2, hPen -- need to create a pen? if window_pen[id][PenValid] = 0 then -- NEW! 0.20 PenValid is just a flag, no longer the PenID -- create a pen hPen = c_func(xCreatePen, { window_pen[id][PenStyle], -- pen style 1, -- thickness window_pen[id][PenColor] }) -- color -- select into the current device replaceObject( id, hdc, hPen, ForPaint ) -- flag that the pen was created window_pen[id][PenValid] = 1 -- NEW! 0.15c added back in -- set the ROP2 style rop2 = window_pen[id][PenROP2] if rop2 then if not c_func( xSetROP2, { hdc, rop2 } ) then warnErr( "SetROP2 in createPen failed." ) end if end if end if end procedure ----------------------------------------------------------------------------- global procedure setPenColor( integer id, atom color ) -- set a new pen color for the window -- save the color window_pen[id][PenColor] = color window_pen[id][PenValid] = 0 end procedure ----------------------------------------------------------------------------- global procedure setPenStyle( integer id, atom style ) -- set a new pen style for the window -- save the style window_pen[id][PenStyle] = style window_pen[id][PenValid] = 0 end procedure ----------------------------------------------------------------------------- global procedure setPenROP2( integer id, atom rop2 ) -- sets the ROP2 mode for the window -- perhaps better called setPenMixMode() window_pen[id][PenROP2] = rop2 end procedure ----------------------------------------------------------------------------- -- NEW! 0.15c global procedure setPenBkMode( integer id, atom bkMode ) -- sets the pen background mode -- default is transparent window_pen[id][PenBkMode] = bkMode end procedure ----------------------------------------------------------------------------- global function getPixel( integer id, integer x, integer y ) -- returns RGB value from point integer rgb atom hdc -- get the device context hdc = getDC( id ) -- get pixel rgb = c_func( xGetPixel, {hdc, x, y} ) -- release the device context releaseDC( id ) return rgb end function ----------------------------------------------------------------------------- global procedure setPixel( integer id, integer x, integer y, atom rgbColor ) -- returns RGB value from point atom hdc -- get the device context hdc = getDC( id ) -- get pixel ok = c_func( xSetPixel, {hdc, x, y, rgbColor } ) -- release the device context releaseDC( id ) end procedure ----------------------------------------------------------------------------- global procedure drawLine( integer id, integer x1, integer y1, integer x2, integer y2 ) -- this needs to be optimized so that if it's in the middle of -- an onPaint action, it used the DC associated with that, and -- doesn't try to open the DC. object hdc, result -- get the device context hdc = getDC( id ) -- create a pen createPen( id, hdc ) -- move to the first point if not c_func(xMoveToEx, {hdc, x1, y1, NULL}) then warnErr( "MoveToEx in PLine of drawLine failed." ) end if -- draw the line if not c_func(xLineTo, {hdc, x2, y2}) then warnErr( "LineTo in PLine of drawLine failed." ) end if -- release the device context releaseDC( id ) end procedure -- NEW! 0.15b ----------------------------------------------------------------------------- procedure createBrush( integer id, integer filled, atom hdc ) -- create the appropriate brush for the filled shape -- 'filled' is the brush flag atom rgbColor, hBrush if filled then -- create a solid brush rgbColor = window_pen[id][PenColor] hBrush = c_func( xCreateSolidBrush, { rgbColor } ) replaceObject( id, hdc, hBrush, ForPaint ) else -- use null brush hBrush = c_func( xGetStockObject, { NULL_PEN } ) end if end procedure ----------------------------------------------------------------------------- global procedure drawRectangle( integer id, integer filled, integer x1, integer y1, integer x2, integer y2 ) -- draw a rectangle atom hdc -- get the device context hdc = getDC( id ) -- create a pen createPen( id, hdc ) -- NEW! 0.15b -- create the brush createBrush( id, filled, hdc ) -- call Rectangle if not c_func( xRectangle, {hdc, x1, y1, x2, y2 } ) then warnErr( "drawRectangle:Rectangle failed." ) end if -- release the device context releaseDC( id ) end procedure ----------------------------------------------------------------------------- global procedure drawRoundRect( integer id, integer filled, integer x1, integer y1, integer x2, integer y2, integer xc, integer yc ) -- draw a rounded rectangle -- xc = ellipse corner width -- yc = ellipse corner height atom hdc -- get the device context hdc = getDC( id ) -- create a pen createPen( id, hdc ) -- NEW! 0.15b -- create the brush createBrush( id, filled, hdc ) -- call RoundRect if not c_func( xRoundRect, {hdc, x1, y1, x2, y2, xc, yc } ) then warnErr( "RoundRect in drawRoundRect failed." ) end if -- release the device context releaseDC( id ) end procedure ----------------------------------------------------------------------------- global procedure drawEllipse( integer id, integer filled, integer x1, integer y1, integer x2, integer y2 ) -- draw an ellipse atom hdc -- get the device context hdc = getDC( id ) -- create a pen createPen( id, hdc ) -- NEW! 0.15b -- create the brush createBrush( id, filled, hdc ) -- call Ellipse if not c_func( xEllipse, {hdc, x1, y1, x2, y2 } ) then warnErr( "Ellipse in drawEllipse failed." ) end if -- release the device context releaseDC( id ) end procedure ----------------------------------------------------------------------------- global procedure drawArc( integer id, integer filled, integer x1, integer y1, integer x2, integer y2, integer xStart, integer yStart, integer xEnd, integer yEnd ) -- draw an arc -- xStart, yStart: start of arc; on imaginary line from center of arc -- xEnd, yEnd : end of arc; on imaginary line from center of arc atom hdc -- get the device context hdc = getDC( id ) -- create a pen createPen( id, hdc ) -- NEW! 0.15b -- create the brush createBrush( id, filled, hdc ) -- call Arc if not c_func( xArc, {hdc, x1, y1, x2, y2, xStart, yStart, xEnd, yEnd } ) then warnErr( "Arc in drawArc failed." ) end if -- release the device context releaseDC( id ) end procedure ----------------------------------------------------------------------------- global procedure drawChord( integer id, integer filled, integer x1, integer y1, integer x2, integer y2, integer xStart, integer yStart, integer xEnd, integer yEnd ) -- draw an chord -- xStart, yStart: start of arc; on imaginary line from center of arc -- xEnd, yEnd : end of arc; on imaginary line from center of arc atom hdc -- get the device context hdc = getDC( id ) -- create a pen createPen( id, hdc ) -- NEW! 0.15b -- create the brush createBrush( id, filled, hdc ) -- call Chord if not c_func( xChord, {hdc, x1, y1, x2, y2, xStart, yStart, xEnd, yEnd } ) then warnErr( "Chord in drawChord failed." ) end if -- release the device context releaseDC( id ) end procedure ----------------------------------------------------------------------------- global procedure drawPie( integer id, integer filled, integer x1, integer y1, integer x2, integer y2, integer xStart, integer yStart, integer xEnd, integer yEnd ) -- draw a pie slice -- xStart, yStart: start of arc; on line from center of arc -- xEnd, yEnd : end of arc; on line from center of arc atom hdc -- get the device context hdc = getDC( id ) -- create a pen createPen( id, hdc ) -- NEW! 0.15b -- create the brush createBrush( id, filled, hdc ) -- call DrawPie if not c_func( xPie, {hdc, x1, y1, x2, y2, xStart, yStart, xEnd, yEnd } ) then warnErr( "Pie in drawPie failed." ) end if -- release the device context releaseDC( id ) end procedure ----------------------------------------------------------------------------- global procedure drawPolygon( integer id, integer filled, sequence points ) -- draw a polygon integer count, offset atom hdc, address -- count of points count = length( points ) -- allocate room for points -- NEW! 0.15b changed allocate to allocate_struct address = allocate_struct( count * 4 * 2 ) -- poke the points offset = 0 for i = 1 to count do -- x point poke( address+offset, int_to_bytes( points[i][1] ) ) -- y point poke( address+offset+4, int_to_bytes( points[i][2] ) ) -- increment offset -- NEW! 0.20c changed from +4 to +8 offset += 8 end for -- get the device context hdc = getDC( id ) -- create a pen createPen( id, hdc ) -- NEW! 0.15b -- create the brush createBrush( id, filled, hdc ) -- call Polygon -- NEW! 0.20c changed from count*2 to count if not c_func( xPolygon, {hdc, address, count } ) then warnErr( "Polygon in drawPolygon failed." ) end if -- release the device context releaseDC( id ) -- release the memory free( address ) end procedure -- NEW! 0.15b added for NT compatibility ------------------------------------------------------------------------------ function loadBitmapFromFile2( sequence fileName ) -- alternate version of loadBitmapFromFile -- this should work for NT and other versions not -- supporting LoadImage's load from file option. -- -- this version is called if the default version fails atom bmFile, bmInfoHeader, bmBits, bmColors, hdc, hDib integer hFile, fSize, byte sequence info hFile = open( fileName, "rb" ) if hFile = -1 then -- warning warnErr( sprintf( "Unable to open '%s', in ReadDIB", {fileName} ) ) return NULL end if -- get the size of the file info = dir( fileName ) if length( info ) != 1 then warnErr( sprintf( "Error reading '%s', in ReadDIB", {fileName} ) ) return 0 else fSize = info[1][D_SIZE] end if -- read the whole file bmFile = allocate( fSize ) for i = 0 to fSize-1 do -- get a byte from the file byte = getc( hFile ) -- eof? if byte = -1 then -- free memory free( bmFile ) -- warning warnErr( sprintf( "Early EOF in '%s', in ReadDIB", {fileName} ) ) -- return failure return NULL else -- poke into structure poke( bmFile+i, byte ) end if end for -- check header if compare( fetch( bmFile, bfType ), "BM" ) != 0 then close( hFile ) free( bmFile ) -- warning warnErr( sprintf( "'%s' not a bitmap file, in ReadDIB", {fileName} ) ) return NULL end if -- check header size against file size if fetch( bmFile, bfSize ) != fSize then -- warning warnErr( sprintf( "Bitmap '%s' is corrupt, in ReadDIB", {fileName} ) ) -- correct header in memory store( bmFile, bfSize, fSize ) end if -- address of BitmapInfoHeader bmInfoHeader = bmFile + SIZEOF_BITMAPFILEHEADER -- offset to bitmap data bmBits = bmFile + fetch( bmFile, bfOffBits ) -- address of color information bmColors = bmInfoHeader + SIZEOF_BITMAPINFOHEADER -- Get the screen's device context. hdc = getDC( 0 ) -- Create the DIB. hDib = c_func( xCreateDIBitmap, { hdc, -- handle to device context address( bmInfoHeader, bmiHeader ), -- pointer to BITMAPINFOHEADER CBM_INIT, -- initialization flag bmBits, -- address of initialization data bmInfoHeader, -- pointer to color data DIB_RGB_COLORS} ) -- colors are RGB tuples -- release the screen dc releaseDC( 0 ) -- free memory free( bmFile ) return hDib end function ----------------------------------------------------------------------------- global function loadBitmapFromFile( sequence fName ) -- loads a bitmap, returns the handle atom file, hBitmap -- make it a lpz string file = allocate_string(fName) -- load it hBitmap = c_func(xLoadImage, {NULL, file, IMAGE_BITMAP, 0, 0, LR_LOADFROMFILE}) -- free the string free( file ) -- success? if hBitmap = NULL then -- NEW! 0.15b added for NT compatibility -- try using alternate version hBitmap = loadBitmapFromFile2( fName ) -- failed again? if hBitmap = NULL then warnErr( "LoadImage in loadBitmapFrom File failed." ) end if end if return hBitmap end function ----------------------------------------------------------------------------- global procedure drawBitmap( integer id, object bitmap, integer xStart, integer yStart ) -- Draw a bitmap onto the requested device -- The bitmap is (currently) expected to be passed as a handle atom hdc, hdcMem, hBitmap, bm, fName, ptSize, ptOrg -- NEW! 0.15b changed allocate to allocate_struct bm = allocate_struct( SIZEOF_BITMAP ) ptSize = allocate_struct( SIZEOF_POINT ) ptOrg = allocate_struct( SIZEOF_POINT ) -- need to load the bitmap? if sequence( bitmap ) then -- passed a file name hBitmap = loadBitmapFromFile( bitmap ) else -- passed handle hBitmap = bitmap end if -- get the DC of the destination hdc = getDC( id ) -- create a memory device context hdcMem = c_func( xCreateCompatibleDC, {hdc} ) if hdcMem = NULL then warnErr( "drawBitmap:CreateCompatibleDC failed." ) end if -- select the bitmap into it if not c_func( xSelectObject, {hdcMem, hBitmap} ) then warnErr( "drawBitmap:SelectObject failed." ) end if -- set mapping mode to same as window if not c_func( xSetMapMode, {hdcMem, c_func( xGetMapMode, {hdc} ) } ) then warnErr( "drawBitmap:SetMapMode failed." ) end if -- get the dimensions of the bitmap if not c_func( xGetObject, {hBitmap, SIZEOF_BITMAP, bm} ) then warnErr( "drawBitmap:GetObject failed." ) end if -- move the size into the point structure ptSize store( ptSize, ptX, fetch( bm, bmWidth ) ) store( ptSize, ptY, fetch( bm, bmHeight ) ) -- convert the point to logical coordinates if not c_func( xDPtoLP, {hdc, ptSize, 1} ) then warnErr( "drawBitmap:DPtoLP failed." ) end if -- get the origin of the bitmap store( ptOrg, ptX, 0 ) store( ptOrg, ptY, 0 ) -- convert to logical coordinates if not c_func( xDPtoLP, {hdc, ptOrg, 1} ) then warnErr( "drawBitmap:DPtoLP failed." ) end if -- copy bitmap to device context if not c_func( xBitBlt, { hdc, xStart, yStart, fetch( ptSize, ptX ), fetch( ptSize, ptY ), hdcMem, fetch( ptOrg, ptX ), fetch( ptOrg, ptY ), SRCCOPY} ) then warnErr( "drawBitmap:BitBlt failed." ) end if -- release the device context if not c_func( xDeleteDC, {hdcMem} ) then warnErr( "drawBitmap:DeleteDC failed." ) end if -- release the DC of the destination releaseDC( id ) -- release structures free( bm ) free( ptSize ) free( ptOrg ) end procedure ----------------------------------------------------------------------------- function codeToBytes( sequence bits ) -- Convert a sequence of text into bytes -- This is a support routine for createMonochromeBitmap -- Ex: "1,1,1,1,1,1,1,1,0,0" -- --> { #FF, #00 } integer byte, extra sequence slice, bytes -- add extra bits: must be multiple of 16 extra = remainder( length(bits), 16 ) if extra then bits = bits & repeat( 1, 16-extra ) end if -- convert bits to bytes bytes = {} -- NEW! 0.14c changed wide+7 to length( bits ) for i = 1 to length( bits ) by 8 do -- get an 8 bit slice slice = bits[i..i+7] -- reverse it for conversion slice = Reverse( slice ) -- convert bits to a byte byte = bits_to_int( slice ) -- add to list bytes = append( bytes, byte ) end for return bytes end function -- NEW! 0.14b optimized by Greg Harris -- NEW! 0.15b Removed text conversion, now expects list of booleans ----------------------------------------------------------------------------- global function createBitmap( sequence s ) -- build a monochrome bitmap from text integer wide, high atom bitmapData, hBitmap sequence data -- get the size wide = length( s[1] ) high = length( s ) -- build the data data = {} for i = 1 to length( s ) do data = data & codeToBytes( s[i] ) end for -- poke the bitmap into memory -- NEW! 0.15b changed allocate to allocate_struct bitmapData = allocate_struct( length( data ) ) poke( bitmapData, data ) -- create a bitmap hBitmap = c_func( xCreateBitmap, {wide, high, 1, 1, bitmapData} ) if hBitmap = 0 then warnErr( "CreateBitmap failed." ) end if -- NEW! 0.20 added resource tracking trackObject( -1, hBitmap, ForProgram ) -- release memory free( bitmapData) return hBitmap end function -- NEW! 0.15b New name, used to be createBitmap ----------------------------------------------------------------------------- global function textToBitmap( sequence s ) -- build a monochrome bitmap from text -- all spaces become lit s = ( s = ' ' ) -- create the bitmap return createBitmap( s ) end function -- NEW! 0.15c created support function ----------------------------------------------------------------------------- function packScanLine( sequence pixels, integer bitsPer ) -- convert a scanline of data into a packed scanline integer fill, bytes, byte, at, perByte sequence packed if bitsPer = 8 then -- 1:1 packed = pixels elsif bitsPer = 4 then -- 4:1 -- pad to even length pixels = pixels & repeat( 0, 1 ) ---- 3 -- bytes in packed array bytes = floor( length( pixels ) / 2 ) ---- 4 -- packed pixels packed = repeat( 0, bytes ) -- 4 bits per; 2 numbers per byte at = 1 for i = 1 to bytes*2 by 2 do ---- 4 -- build a byte packed[at] = (pixels[i] * 16) + (pixels[i+1] * 1 ) ---- 4 -- + (pixels[i+2] * 2 ) -- + pixels[i+3] -- move to start of next byte at = at + 1 end for elsif bitsPer = 1 then -- 8:1 -- pad to even length pixels = pixels & repeat( 0, 7 ) -- bytes in packed array bytes = floor( length( pixels ) / 8 ) -- packed pixels packed = repeat( 0, bytes ) -- 1 bits per; 8 numbers per byte at = 1 for i = 1 to bytes*8 by 8 do -- build a byte packed[at] = (pixels[i] * 128) + (pixels[i+1] * 64) + (pixels[i+2] * 32) + (pixels[i+3] * 16) + (pixels[i+4] * 8 ) + (pixels[i+5] * 4 ) + (pixels[i+6] * 2 ) + pixels[i+7] -- move to next byte at = at + 1 end for end if -- scanline needs to fall on an long boundary (4 bytes) fill = remainder( length( packed ), 4 ) if fill then packed = packed & repeat( 0, 4-fill ) end if return packed end function -- NEW! 0.15c Corrected function ----------------------------------------------------------------------------- global function createDIB( sequence pixels, sequence pal ) -- create a DIB (bitmap) from pixels and palette -- note that the sequence of pixels is *zero* based. integer colors, palSize, headerSize, bitsPer, h, w, fill atom memBitmapInfo, memBits, at, hdc, hDIB -- number of colors colors = length( pal ) -- NEW! 0.15e removed code that tried to make bits base zero, -- since in load_bitmap() they already were. -- palette and packing size if colors <= 2 then palSize = 2 bitsPer = 1 elsif colors <= 16 then palSize = 16 bitsPer = 4 elsif colors <= 256 then palSize = 256 bitsPer = 8 end if -- size of bitmap w = length( pixels[1] ) h = length( pixels ) -- calculate the size of the BITMAPINFO header headerSize = SIZEOF_BITMAPINFOHEADER + (SIZEOF_RGBQUAD * palSize ) -- allocate memory for DIB memBitmapInfo = allocate_struct( headerSize ) -- build the bitmap info header store( memBitmapInfo, biSize, SIZEOF_BITMAPINFOHEADER ) store( memBitmapInfo, biWidth, w ) -- Width in pixels. store( memBitmapInfo, biHeight, -h ) -- Height in pixels. store( memBitmapInfo, biPlanes, 1 ) -- 1 color plane. store( memBitmapInfo, biBitCount, bitsPer ) -- bits per pixel. store( memBitmapInfo, biCompression, 0 ) -- No compression. store( memBitmapInfo, biSizeImage, 0 ) -- Unneeded with no compression. store( memBitmapInfo, biXPelsPerMeter, 0 ) -- Unneeded. store( memBitmapInfo, biYPelsPerMeter, 0 ) -- Unneeded. store( memBitmapInfo, biClrUsed, palSize ) -- # colors in color table that are used by the image. 0 means all. store( memBitmapInfo, biClrImportant, colors ) -- # important colors. 0 = all. -- pack the pixels for i = 1 to h do pixels[i] = packScanLine( pixels[i], bitsPer ) end for -- get bytes per scanline w = length( pixels[1] ) -- allocate storage memBits = allocate( h * w ) -- copy pixels to memory at = memBits for i = 1 to h do poke( at, pixels[i] ) at = at + w end for -- get the address of the first rgb tuple at = address( memBitmapInfo, bmiColors ) -- copy the pal to memory for i = 1 to colors do -- store values store( at, rgbRed, pal[i][1] ) store( at, rgbGreen, pal[i][2] ) store( at, rgbBlue, pal[i][3] ) store( at, rgbReserved, 0 ) -- move to next quad at = at + SIZEOF_RGBQUAD end for -- Get the screen's device context. hdc = getDC( 0 ) -- Create the DIB. hDIB = c_func( xCreateDIBitmap, { hdc, address( memBitmapInfo, bmiHeader ), CBM_INIT, memBits, memBitmapInfo, DIB_RGB_COLORS} ) -- release the screen dc releaseDC( 0 ) -- free memory free( memBits ) free( memBitmapInfo ) -- NEW! 0.20 added resource tracking trackObject( -1, hDIB, ForProgram ) return hDIB end function ----------------------------------------------------------------------------- global procedure setIcon( integer id, object icon ) -- assign an icon to an window -- Credit: Pete Eberlein atom szFile, handle -- is the icon a string (pathname) or a constant? if sequence( icon ) then -- get the handle, and attach icon -- NEW! 0.20c changed to accomodate WinNT handle = c_func(xExtractIcon, {getHandle(id), allot_string(icon), 0}) ok = sendMessage(id, WM_SETICON, 0, handle) -- free the string free_strings() else -- use LoadIcon to load handle = c_func(xLoadIcon, {NULL, icon}) -- STM_SETICON associates an icon with a control ok = sendMessage( id, STM_SETICON, handle, 0 ) end if end procedure ----------------------------------------------------------------------------- global procedure setBitmap( integer id, object bitmap ) -- assign an icon to an window -- Credit: Pete Eberlein -- is it a constant, or a file path? if sequence( bitmap ) then -- it's a pathname. use LOADFROMFILE. bitmap = c_func(xLoadImage, {NULL, allot_string(bitmap), IMAGE_BITMAP, 0, 0, LR_LOADFROMFILE}) -- free the string free_strings() end if ok = sendMessage( id, STM_SETIMAGE, IMAGE_BITMAP, bitmap ) end procedure ----------------------------------------------------------------------------- global procedure setPixmap( integer id, atom bitmap ) -- assign a new value to a pixmap -- is there an old bitmap? if window_handle[ id ] != 0 then deleteObject( window_handle[ id ] ) end if -- file name or handle? if sequence( bitmap ) then -- try to load bitmap file window_handle[ id ] = loadBitmapFromFile( bitmap ) else -- just assign to handle window_handle[ id ] = bitmap end if end procedure ----------------------------------------------------------------------------- global procedure setWindowBackColor( integer id, atom rgbColor ) -- set the background color of a window -- use rgb() to calculate a color atom result -- save color window_bcolor[ id ] = rgbColor -- create a new brush result = c_func( xCreateSolidBrush, {rgbColor} ) -- set that as the background color result = c_func( xSetClassLong, {window_handle[id], GCL_HBRBACKGROUND, result} ) -- delete the prior brush deleteObject( result ) -- redraw the screen repaintWindow( id ) end procedure ----------------------------------------------------------------------------- global function getSysColor( integer winPart ) -- returns the color associated with a graphical element -- use the COLOR_xxxx constants return c_func( xGetSysColor, {winPart} ) end function ----------------------------------------------------------------------------- ----------------------------------------------------------------------------- -- New! 0.20 BitBlt support -- BitBlt Support Routines ----------------------------------------------------------------------------- global procedure bitBlt( atom dst, integer dstX, integer dstY, atom src, integer srcX, integer srcY, integer wide, integer high, integer rop ) -- wrapper to bitblt -- copy portion of window into bitmap integer srcIsWin, dstIsWin atom srcDC, dstDC -- get the DCs srcDC = getDC( src ) dstDC = getDC( dst ) -- copy area if not c_func( xBitBlt, { dstDC, dstX, dstY, wide, high, srcDC, srcX, srcY, rop} ) then warnErr( "bitBlt:BitBlt failed." ) end if -- release the DCs releaseDC( dst ) releaseDC( src ) end procedure ----------------------------------------------------------------------------- global procedure copyBlt( atom dst, integer x, integer y, atom src ) -- copy entire destination to source sequence size -- get the size of the pixmap size = getSize( src ) -- bitblt with scrCopy bitBlt( dst, x, y, src, 0, 0, size[3], size[4], SRCCOPY ) end procedure ----------------------------------------------------------------------------- global procedure transBlt( atom dest, integer destX, integer destY, atom src, sequence transRGB ) integer wide, -- width of the source bitmap high -- height of the source bitmap atom srcBmp, -- source bitmap transColor, -- transparent color value destDC, -- device context of destination srcDC, -- source bitmap (color) saveDC, -- backup copy of source bitmap maskDC, -- mask bitmap (monochrome) invDC, -- inverse of mask bitmap (monochrome) resultDC, -- combination of source bitmap & background hResultBmp, -- Bitmap combination of source & background hSaveBmp, -- Bitmap stores backup copy of source bitmap hMaskBmp, -- Bitmap stores mask (monochrome) hInvBmp, -- Bitmap holds inverse of mask (monochrome) hPrevBmp, -- Bitmap holds previous bitmap selected in DC hSrcPrevBmp, -- Holds previous bitmap in source DC hSavePrevBmp, -- Holds previous bitmap in saved DC hDestPrevBmp, -- Holds previous bitmap in destination DC hMaskPrevBmp, -- Holds previous bitmap in the mask DC hInvPrevBmp, -- Holds previous bitmap in inverted mask DC OrigColor, -- Holds original background color from source DC Success -- Stores result of call to Windows API sequence size -- holder for size of source -- NEW! 0.2a use validId instead of length( window ) -- is the source a bitmap, or a pixmap? if not validId( src ) then -- it's a bitmap srcBmp = src elsif window_class[ src ] = PIXMAP then -- get the handle srcBmp = window_handle[ src ] -- release resources for it releaseResourcesForID( src ) else -- no good warnErr( "Source to transBlt must be bitmap or Pixmap" ) return end if -- get the size of the bitmap size = getSize( srcBmp ) -- get the values from the bitmap wide = size[3] high = size[4] -- get the DC of the destintation destDC = getDC( dest ) -- convert the transparent color tuple transColor = rgb( transRGB[1], transRGB[2], transRGB[3] ) -- create DCs to hold temporary information srcDC = c_func( xCreateCompatibleDC, {destDC} ) saveDC = c_func( xCreateCompatibleDC, {destDC} ) maskDC = c_func( xCreateCompatibleDC, {destDC} ) invDC = c_func( xCreateCompatibleDC, {destDC} ) resultDC = c_func( xCreateCompatibleDC, {destDC} ) -- Create monochrome bitmaps for the mask-related bitmaps: hMaskBmp = c_func( xCreateBitmap, {wide, high, 1, 1, 0} ) hInvBmp = c_func( xCreateBitmap, {wide, high, 1, 1, 0} ) -- Create color bitmaps for final result & stored copy of source hResultBmp = c_func( xCreateCompatibleBitmap, {destDC, wide, high} ) hSaveBmp = c_func( xCreateCompatibleBitmap, {destDC, wide, high} ) -- select the bitmaps into the DCs hSrcPrevBmp = c_func( xSelectObject, {srcDC, srcBmp} ) hSavePrevBmp = c_func( xSelectObject, {saveDC, hSaveBmp} ) hMaskPrevBmp = c_func( xSelectObject, {maskDC, hMaskBmp} ) hInvPrevBmp = c_func( xSelectObject, {invDC, hInvBmp} ) hDestPrevBmp = c_func( xSelectObject, {resultDC, hResultBmp} ) -- Make backup of source bitmap to restore later Success = c_func( xBitBlt, {saveDC, 0, 0, wide, high, srcDC, 0, 0, SRCCOPY} ) -- Create mask: set background color of source to transparent color. OrigColor = c_func( xSetBkColor, {srcDC, transColor} ) Success = c_func( xBitBlt, {maskDC, 0, 0, wide, high, srcDC, 0, 0, SRCCOPY} ) -- restore the original color transColor = c_func( xSetBkColor, {srcDC, OrigColor} ) -- Create inverse of mask to AND w/ source & combine w/ background. Success = c_func( xBitBlt, {invDC, 0, 0, wide, high, maskDC, 0, 0, NOTSRCCOPY} ) -- Copy background bitmap to result & create final transparent bitmap Success = c_func( xBitBlt, {resultDC, 0, 0, wide, high, destDC, destX, destY, SRCCOPY} ) -- AND mask bitmap w/ result DC to punch hole in the background by -- painting black area for non-transparent portion of source bitmap. Success = c_func( xBitBlt, {resultDC, 0, 0, wide, high, maskDC, 0, 0, SRCAND} ) -- AND inverse mask w/ source bitmap to turn off bits associated -- with transparent area of source bitmap by making it black. Success = c_func( xBitBlt, {srcDC, 0, 0, wide, high, invDC, 0, 0, SRCAND} ) -- XOR result w/ source bitmap to make background show through. Success = c_func( xBitBlt, {resultDC, 0, 0, wide, high, srcDC, 0, 0, SRCPAINT} ) -- Display transparent bitmap on backgrnd Success = c_func( xBitBlt, {destDC, destX, destY, wide, high, resultDC, 0, 0, SRCCOPY} ) -- Restore backup of bitmap. Success = c_func( xBitBlt, {srcDC, 0, 0, wide, high, saveDC, 0, 0, SRCCOPY} ) -- select the original objects hPrevBmp = c_func( xSelectObject, {srcDC, hSrcPrevBmp} ) hPrevBmp = c_func( xSelectObject, {saveDC, hSavePrevBmp} ) hPrevBmp = c_func( xSelectObject, {resultDC, hDestPrevBmp} ) hPrevBmp = c_func( xSelectObject, {maskDC, hMaskPrevBmp} ) hPrevBmp = c_func( xSelectObject, {invDC, hInvPrevBmp} ) -- deallocate system resources Success = c_func( xDeleteObject, {hSaveBmp} ) Success = c_func( xDeleteObject, {hMaskBmp} ) Success = c_func( xDeleteObject, {hInvBmp} ) Success = c_func( xDeleteObject, {hResultBmp} ) Success = c_func( xDeleteDC, {srcDC} ) Success = c_func( xDeleteDC, {saveDC} ) Success = c_func( xDeleteDC, {invDC} ) Success = c_func( xDeleteDC, {maskDC} ) Success = c_func( xDeleteDC, {resultDC} ) -- release the DC of the destintation releaseDC( dest ) end procedure ----------------------------------------------------------------------------- -- WINDOWS -- -- NEW! 0.15b renamed from closeWindow ----------------------------------------------------------------------------- global procedure minimizeWindow( integer id ) -- close the given window if not c_func( xCloseWindow, {window_handle[ id ]} ) then abortErr( "CloseWindow in closeWindow failed." ) end if end procedure -- NEW! 0.15b used to be unloadWindow ----------------------------------------------------------------------------- global procedure closeWindow( integer id ) -- close the window -- NEW! 0.14c now sends close instead of postCloseApp ok = sendMessage( id, WM_CLOSE, 0, 0 ) end procedure ----------------------------------------------------------------------------- global procedure moveWindow( integer id, integer x, integer y, integer cx, integer cy, integer repaint ) -- move the given window if not c_func( xMoveWindow, {window_handle[ id ], x, y, cx, cy, repaint} ) then warnErr( "moveWindow:MoveWindow failed." ) end if end procedure ----------------------------------------------------------------------------- global procedure setSize( integer id, integer cx, integer cy ) -- resize the given item integer x, y atom oldBmp, srcDC, dstDC sequence result if window_class[ id ] = PIXMAP then -- get the bitmap, replace it with null oldBmp = window_handle[ id ] window_handle[ id ] = 0 -- create a pixmap of the new size createPixmap( id, cx, cy ) -- was there a prior bitmap? if oldBmp != 0 then -- is there a current bitmap to draw into? if window_handle[ id ] != 0 then -- get size of old bitmap result = getExtent( oldBmp ) cx = result[1] cy = result[2] -- copy the old bitmap onto the new one bitBlt( window_handle[ id ], 0, 0, oldBmp, 0, 0, cx, cy, SRCCOPY ) end if -- release the old bitmap deleteObject( oldBmp ) end if else -- get the current location of the window result = getSize( id ) x = result[1] y = result[2] -- normal window class, send MoveWindow to resize if not c_func( xMoveWindow, {window_handle[ id ], x, y, cx, cy, 1} ) then warnErr( "setSize:MoveWindow failed." ) end if end if end procedure -- NEW! 0.15b ----------------------------------------------------------------------------- procedure pushModal( integer id ) -- set window as modal -- if there was a prior modal window, stack it -- need to stack? if modalWindow then modalStack = append( modalStack, modalWindow ) end if -- set modal window modalWindow = id end procedure -- NEW! 0.15b ----------------------------------------------------------------------------- procedure popModal() -- remove modal flag -- if there was a prior modal window, unstack it integer pending pending = length( modalStack ) -- need to unstack? if pending then -- set new modal modalWindow = modalStack[pending] -- unstack modalStack = modalStack[1..pending-1] else -- no pending modal window modalWindow = 0 end if end procedure -- NEW! 0.20 ----------------------------------------------------------------------------- -- MOUSE -- ----------------------------------------------------------------------------- global procedure captureMouse( integer id ) -- captures the mouse so all events are sent to that window -- capture the mouse if c_func( xSetCapture, { getHandle( id ) } ) then warnErr( "getMouse:SetCapture failed." ) end if end procedure ----------------------------------------------------------------------------- global procedure releaseMouse() -- release the mouse from a getMouse c_proc( xReleaseCapture, {} ) end procedure ----------------------------------------------------------------------------- -- TIMERS -- ----------------------------------------------------------------------------- global procedure setTimer( integer id, integer timerId, atom ticks ) -- set a timer to go off every ticks milliseconds c_proc( xSetTimer, { window_handle[ id ], timerId, ticks, 0 } ) end procedure ----------------------------------------------------------------------------- global procedure killTimer( integer id, integer timerId ) -- remove timer from window c_proc( xKillTimer, { window_handle[ id ], timerId } ) end procedure ----------------------------------------------------------------------------- -- NEW! 0.15c -- CARETS -- ----------------------------------------------------------------------------- global procedure showCaret( integer id ) -- shows the caret in the current window if not c_func( xShowCaret, { window_handle[ id ] } ) then warnErr( "ShowCaret in showCaret failed." ) end if end procedure ----------------------------------------------------------------------------- global procedure hideCaret( integer id ) -- hide the caret in the current window if not c_func( xHideCaret, { window_handle[ id ] } ) then warnErr( "HideCaret in hideCaret failed." ) end if end procedure ----------------------------------------------------------------------------- global procedure setCaretPos( integer x, integer y ) -- set the caret position in the current window if not c_func( xSetCaretPos, { x, y } ) then warnErr( "SetCaretPos in setCaretPos failed." ) end if end procedure ----------------------------------------------------------------------------- global procedure createCaret( integer id, atom hBmp, integer w, integer h ) -- set the caret position in the current window if not c_func( xCreateCaret, { window_handle[id], hBmp, w, h } ) then warnErr( "CreateCaret in createCaret failed." ) end if end procedure ----------------------------------------------------------------------------- global procedure destroyCaret() -- destroy the caret in the current window if not c_func( xDestroyCaret, {} ) then warnErr( "destroyCaret in DestroyCaret failed." ) end if end procedure ----------------------------------------------------------------------------- -- COMMON DIALOGS: SAVE FILE NAME -- ----------------------------------------------------------------------------- function buildDefaultOfn( integer id, sequence fName, sequence filters, atom flags ) -- builds the ofn structure shared by open and save file -- filters is in the form: -- { "Text Files", "*.TXT,*.DOC", ... } atom ofn sequence filterList -- allocate the structure -- NEW! 0.15b changed allocate to allocate_struct ofn = allocate_struct( SIZEOF_OPENFILENAME ) -- build the filter list by concatonating the elements -- and ending them with zeros filterList = {} for i = 1 to length( filters ) do filterList = filterList & filters[i] & 0 end for -- ends with nulls filterList = filterList & NULL & NULL -- size of structure, in bytes store( ofn, ofnStructSize, SIZEOF_OPENFILENAME ) -- window that owns the dialog box store( ofn, ofnOwner, window_handle[ id ] ) -- identifies the data block containing a dialog box template -- specified in ofnTemplateName. not used store( ofn, ofnInstance, NULL ) -- filters store( ofn, ofnFilter, filterList ) store( ofn, ofnCustomFilter, NULL ) store( ofn, ofnMaxCustFilter, NULL ) -- index of which filter to default to store( ofn, ofnFilterIndex, 1 ) -- NEW! 0.15 added comment. This looked suspicious. -- default file name: allot an (at minimum) 256 byte buffer fName = fName & 0 & repeat( ' ', 256 ) store( ofn, ofnFile, fName ) -- max size of buffer pointed to by ofnFile. store( ofn, ofnMaxFile, 256 ) store( ofn, ofnFileTitle, NULL ) store( ofn, ofnMaxFileTitle, NULL ) store( ofn, ofnInitialDir, NULL ) store( ofn, ofnTitle, NULL ) store( ofn, ofnFlags, or_all( { OFN_EXPLORER, -- looks like windows explorer OFN_HIDEREADONLY, -- hide the read-only checkbox OFN_LONGNAMES, -- use long filenames OFN_PATHMUSTEXIST} ) ) -- path must exist store( ofn, ofnFileOffset, NULL ) store( ofn, ofnFileExtension, NULL ) -- default extension store( ofn, ofnDefExt, NULL ) -- custom data store( ofn, ofnCustData, NULL ) store( ofn, ofnHook, NULL ) store( ofn, ofnTemplateName, NULL ) return ofn end function ----------------------------------------------------------------------------- global function getOpenFileName( integer id, sequence fName, sequence filters ) atom ofn -- build the structure ofn = buildDefaultOfn( id, fName, filters, or_all( { OFN_FILEMUSTEXIST } ) ) -- file must exist -- call the routine if c_func(xGetOpenFileName, {ofn}) then -- get the name fName = fetch( ofn, ofnFile ) else -- return blank fName = "" end if -- release the structure and strings free( ofn ) free_strings() return fName end function ----------------------------------------------------------------------------- global function getSaveFileName( integer id, sequence fName, sequence filters ) atom ofn -- build the structure ofn = buildDefaultOfn( id, fName, filters, or_all( { OFN_OVERWRITEPROMPT } ) ) -- warn if exists -- call the routine if c_func(xGetSaveFileName, {ofn}) then -- get the name fName = fetch( ofn, ofnFile ) else -- cancelled fName = "" end if -- release the structure and strings free( ofn ) free_strings() -- return result return fName end function ----------------------------------------------------------------------------- procedure tab_to( integer id, integer tabstop ) -- tabs to nth control in window -- on error, does nothing -- check for wrapping if window_tab[ id ] = 0 then -- nothing to focus on! -- 0.15b changed from return 0 return elsif tabstop > window_tab[ id ] then -- wrap to front tabstop = 1 elsif tabstop < 1 then -- wrap to end tabstop = window_tab[ id ] end if -- find the tab for i = 1 to length( window_tab ) do -- same owner and index? if window_owner[ i ] = id and window_tab[ i ] = tabstop then -- change focus c_proc( xSetFocus, { window_handle[ i ] } ) -- leave return end if end for if message_box( "nothing to tab to!", sprintf("tab_to( %d, %d )", {id, tabstop} ), 0 ) then end if end procedure -- NEW! 0.20 added for mouse values ----------------------------------------------------------------------------- function shortInt( integer i ) -- converts numbers to short ints if i < 32000 then return i else return i - 65534 end if end function ----------------------------------------------------------------------------- global function subclassed(integer id, atom hWnd, atom iMsg, atom wParam, atom lParam) -- handle subclassed behaviors for child controls integer pointer object result -- trap tab keys if (iMsg = WM_KEYDOWN or iMsg = WM_KEYUP or iMsg = WM_CHAR ) and wParam = VK_TAB then -- only move on the keydown. if iMsg = WM_KEYDOWN then -- is the shift key pressed? result = c_func( xGetKeyState, {VK_SHIFT} ) -- check the high bit. the low order key indicates toggle -- state, so it's dropped. if floor( result / 2 ) then -- set focus back tab_to( window_owner[id], window_tab[ id ]-1 ) else -- set focus ahead tab_to( window_owner[id], window_tab[ id ]+1 ) end if end if return 0 end if if iMsg = WM_KEYDOWN then if onKeyDown[ id ] != - 1 then call_proc( onKeyDown[ id ], {wParam} ) end if elsif iMsg = WM_CHAR then if onKeyPress[ id ] != - 1 then call_proc( onKeyPress[ id ], {wParam} ) end if elsif iMsg = WM_KEYUP then if onKeyUp[ id ] != - 1 then call_proc( onKeyUp[ id ], {wParam} ) end if elsif iMsg = WM_SETFOCUS then -- store new focus window_focus[ window_owner[ id ] ] = id -- call proc? if onGotFocus[ id ] != -1 then call_proc( onGotFocus[ id ], {} ) end if elsif iMsg = WM_KILLFOCUS then if onLostFocus[ id ] != -1 then call_proc( onLostFocus[ id ], {} ) end if -- NEW! 0.14c elsif iMsg = WM_RBUTTONDOWN then -- action? if onMouse[ id ] != -1 then -- NEW! 0.20 mouse now returns negative values -- send the mouse position call_proc( onMouse[ id ], { iMsg, shortInt( lo_word( lParam ) ), shortInt( hi_word( lParam ) ) } ) -- overrides default behavior! return 0 end if end if -- run behavior return c_func( xCallWindowProc, { window_func[id], hWnd, iMsg, wParam, lParam } ) end function ----------------------------------------------------------------------------- -- NEW! 0.20d added hWnd to parameter procedure wm_scroll( atom hWnd, atom wParam, atom lParam ) -- scroll event handler integer id, request, pos sequence range -- determine if this is from the parent window's scroll -- bar, or a child scroll bar if lParam = 0 then -- scroll bar of parent -- NEW! 0.20d replaced find( myHwnd, window_handle ) with getId() id = getId( hWnd ) else -- find the control -- NEW! 0.20d replaced find( lParam, window_handle ) with getId() id = getId( lParam ) end if -- get the request request = lo_word( wParam ) -- get the value of the scroll bar pos = getScrollPos( id ) -- get the range range = getScrollRange( id ) if request = SB_LINEUP then -- move up by 1 line pos = pos - window_scroll[ id ][ MY_SMALLCHANGE ] elsif request = SB_LINEDOWN then -- move down by 1 line pos = pos + window_scroll[ id ][ MY_SMALLCHANGE ] elsif request = SB_PAGEUP then -- move up by 1 page pos = pos - window_scroll[ id ][ MY_LARGECHANGE ] elsif request = SB_PAGEDOWN then -- move down by 1 page pos = pos + window_scroll[ id ][ MY_LARGECHANGE ] elsif request = SB_TOP then -- to top of page pos = range[1] elsif request = SB_BOTTOM then -- to bottom of page pos = range[2] elsif request = SB_THUMBPOSITION or request = SB_THUMBTRACK then -- track thumb position pos = hi_word( wParam ) -- NEW! 0.15c Gary Unger noted this was redundant elsif request = SB_ENDSCROLL then -- ignore return end if -- clip to range if pos < range[1] then pos = range[1] elsif pos > range[2] then pos = range[2] end if -- call global routine to do the work setScrollPos( id, pos ) end procedure ----------------------------------------------------------------------------- global function WndProc(atom hWnd, atom iMsg, atom wParam, atom lParam) -- callback routine to handle Window class -- This routine processes messages sent by Windows -- NEW! 0.15 renamed "pointer" to "action"; "action" to "event" integer id, event, action, mouseX, mouseY sequence parms object result -- find the control -- NEW! 0.20d replaced find( hWnd, window_handle ) with getId( lParam ) id = getId( hWnd ) -- save the id for getSelf() myId = id -- not one of mine? if id = 0 then -- default processing return c_func( xDefWindowProc, { hWnd, iMsg, wParam, lParam } ) end if -- user can process events that Win32Lib doesn't have handlers for. if onEvent[ id ] > 0 then -- call routine call_proc( onEvent[ id ], {iMsg, wParam, lParam} ) end if -- if not a window, run subclassed behavior if window_class[ id ] != WINDOW then -- run the subclassed behavior return subclassed(id, hWnd, iMsg, wParam, lParam) end if -- NEW! 0.15 Added MOUSEMOVE, LBUTTONDOWN and LBUTTON tests if iMsg = WM_MOUSEMOVE or iMsg = WM_LBUTTONDOWN -- NEW! 0.14c detect right click or iMsg = WM_RBUTTONDOWN or iMsg = WM_LBUTTONUP or iMsg = WM_RBUTTONUP or iMsg = WM_LBUTTONDBLCLK or iMsg = WM_RBUTTONDBLCLK then -- decode parameters -- NEW! 0.20 use shortInt so negative values are handled mouseX = shortInt( lo_word( lParam ) ) mouseY = shortInt( hi_word( lParam ) ) -- get command if iMsg = WM_LBUTTONDOWN then -- action? action = onClick[ id ] if action != -1 then call_proc( action, {} ) end if end if -- NEW! 0.15 folded general events into onMouse -- mouse up or down? if iMsg = WM_MOUSEMOVE or iMsg = WM_LBUTTONDOWN or iMsg = WM_RBUTTONDOWN or iMsg = WM_LBUTTONUP or iMsg = WM_RBUTTONUP or iMsg = WM_LBUTTONDBLCLK or iMsg = WM_RBUTTONDBLCLK then -- generate an event? action = onMouse[id] if action != -1 then -- trigger action call_proc( action, { iMsg, mouseX, mouseY } ) end if end if return 0 elsif iMsg = WM_SIZE then -- resize behavior? if onResize[ id ] != - 1 then call_proc( onResize[ id ], { wParam, -- size style lo_word( lParam ), -- x size hi_word( lParam ) } ) -- y size end if return 0 elsif iMsg = WM_SETFOCUS then -- item to focus on? if window_tab[ id ] then -- get id of item to focus on result = window_focus[ id ] -- no focus? if result = 0 then -- focus on first item tab_to( id, 1 ) else -- focus on current tab stop tab_to( id, window_tab[ result ] ) end if end if -- NEW! 0.14c -- is there a window with modal focus? if modalWindow and id != modalWindow then -- set focus c_proc( xSetFocus, {window_handle[modalWindow]} ) else -- NEW! 0.15c missing onGotFocus for window -- call proc? if onGotFocus[ id ] != -1 then call_proc( onGotFocus[ id ], {} ) end if end if -- handled return 0 elsif iMsg = WM_KILLFOCUS then -- NEW! 0.15c add behavior for window if onLostFocus[ id ] != -1 then call_proc( onLostFocus[ id ], {} ) end if -- NEW! 0.15b added onKeyUp and onKeyDown; onKeyPress mapped to WM_CHAR elsif iMsg = WM_KEYDOWN then if onKeyDown[ id ] != - 1 then call_proc( onKeyDown[ id ], {wParam} ) end if elsif iMsg = WM_CHAR then if onKeyPress[ id ] != - 1 then call_proc( onKeyPress[ id ], {wParam} ) end if elsif iMsg = WM_KEYUP then if onKeyUp[ id ] != - 1 then call_proc( onKeyUp[ id ], {wParam} ) end if elsif ( iMsg = WM_COMMAND and lParam = NULL) then -- menu or accelerator? if hi_word( wParam ) = 1 then -- from accelerator; -- this should not happen else -- get the menu id id = lo_word( wParam ) -- get the action action = onClick[ id ] -- action? if action != -1 then call_proc( action, {} ) end if end if elsif iMsg = WM_COMMAND then -- notification from control -- determine which window sent the message -- NEW! 0.20d replaced find( lParam, window_handle ) with getId() myControl = getId( lParam ) -- this shouldn't happen... if myControl = 0 then return 0 end if -- clear parms parms = {} event = hi_word( wParam ) action = -1 -- click? if event = BN_CLICKED then -- button -- get command action = onClick[ myControl ] -- NEW! 0.15 no longer passes position on click -- get mouse position -- mouseX = lo_word( lParam ) -- mouseY = hi_word( lParam ) -- save as parameters parms = {} -- double click? elsif event = LBN_DBLCLK -- list box or event = CBN_DBLCLK -- combo box then -- get command action = onMouse[ myControl ] -- get mouse position -- NEW! 0.20 added shortInt so negative values properly handled mouseX = shortInt( lo_word( lParam ) ) mouseY = shortInt( hi_word( lParam ) ) -- save as parameters parms = { LEFT_DOUBLECLICK, mouseX, mouseY } -- change? elsif event = CBN_EDITCHANGE -- combo notify change or event = LBN_SELCHANGE -- list box notify change or event = EN_CHANGE -- editbox notify change then action = onChange[ myControl ] end if -- action? if action != -1 then call_proc( action, parms ) end if return 0 elsif iMsg = WM_PAINT then -- NEW! 0.14 pass window area in onPaint -- begin paint myHdc = c_func( xBeginPaint, { hWnd, myPs } ) -- get address of update rectangle myRect = address( myPs, psPaintRect ) -- fetch the update rectangle result = { fetch( myRect, rectLeft ), fetch( myRect, rectTop ), fetch( myRect, rectRight ), fetch( myRect, rectBottom ) } -- allow any part of the window to be written to if not c_func( xGetClientRect, {hWnd, myRect} ) then warnErr( "GetClientRect in WndProc failed." ) end if -- set hasDC flag hasDC = id -- is there an onPaint routine? if onPaint[ id ] > 0 then -- call routine with update rectangle call_proc( onPaint[ id ], result ) end if -- end of paint c_proc( xEndPaint, { hWnd, myPs } ) -- try to release the resources releasePaintResources() -- release the DC hasDC = 0 return 0 elsif iMsg = WM_VSCROLL or iMsg = WM_HSCROLL then -- scroll handling code -- NEW! 0.20d added hWnd to parameters wm_scroll( hWnd, wParam, lParam ) return 0 elsif iMsg = WM_TIMER then -- timer event -- is one set for this window? if onTimer[ id ] > 0 then -- pass it the timer id (in wParam) call_proc( onTimer[ id ], {wParam} ) end if return 0 elsif iMsg = WM_SYSCOLORCHANGE then -- system color changed. force a redraw of the window if not c_func( xInvalidateRect, {hWnd, NULL, -1} ) then warnErr( "InvalidateRect in WndProc failed." ) end if return 0 elsif iMsg = WM_CTLCOLORBTN or iMsg = WM_CTLCOLORSTATIC -- or iMsg = WM_CTLCOLOREDIT -- these do NOT adjust the color -- or iMsg = WM_CTLCOLORLISTBOX -- or iMsg = WM_CTLCOLORMSGBOX -- or iMsg = WM_CTLCOLORDLG -- or iMsg = WM_CTLCOLORSCROLLBAR then -- system is about to draw the colors for a control. -- this intercepts the command, and returns the brush we want -- wParam contains the device context of the control -- set text background color to the window background color if c_func(xSetBkColor, {wParam, window_bcolor[id]} ) = CLR_INVALID then warnErr( "SetBkColor in wndProc failed." ) end if -- get the parent's background color brush return c_func( xGetClassLong, {window_handle[id], GCL_HBRBACKGROUND} ) -- NEW! 0.15 moved to bottom of tests. This happens only once per window elsif iMsg = WM_CREATE then -- the problem here is i don't know what the ID is until it's -- returned! That's why the onOpen action is placed in the -- create window routine, not here. -- force a screen refresh repaintWindow( id ) return 0 -- NEW! 0.14c elsif iMsg = WM_CLOSE then -- close modal grab? if modalWindow then popModal() end if -- hide the window if not the primary if id != defaultWindow then ok = c_func( xShowWindow, {window_handle[id], SW_HIDE} ) return 0 end if -- NEW! 0.15b added onClose -- action? if onClose[id] != -1 then call_proc( onClose[id], {} ) end if elsif iMsg = WM_DESTROY then -- action? if onDestroy[id] != -1 then call_proc( onDestroy[id], {} ) end if -- primary window? -- if id != defaultWindow then -- -- destroy the window -- if not c_func( xDestroyWindow, {window_handle[ id ]} ) then -- abortErr( "DestroyWindow in WndProc failed." ) -- end if -- -- -- delete the class -- if not c_func( xUnregisterClass, { -- allot_string( -- sprintf( "Win32Lib%d", {id} ) ), -- class name -- NULL}) -- owner handle -- then -- -- failed -- abortErr( "UnregisterClass in destroyWindow failed." ) -- end if -- -- -- free the string -- free_strings() -- -- end if -- -- -- handled -- return 0 -- close the app c_proc( xPostQuitMessage, { wParam } ) end if return c_func( xDefWindowProc, { hWnd, iMsg, wParam, lParam } ) end function ----------------------------------------------------------------------------- -- store routine id procedure get_proc_address() atom id id = routine_id("WndProc") if id = -1 then abortErr( "routine_id for WndProc failed!\n") end if WndProcAddress = call_back( id ) -- get 32-bit address for callback end procedure ----------------------------------------------------------------------------- get_proc_address() ----------------------------------------------------------------------------- global procedure openWindow( integer id ) atom hWnd -- get the handle hWnd = window_handle[ id ] -- set the text and background colors setTextColor( id, getSysColor( COLOR_WINDOWTEXT ) ) setBackColor( id, getSysColor( COLOR_WINDOW ) ) -- NEW! 0.15b renamed onLoad to onOpen -- action? if onOpen[ id ] != -1 then call_proc( onOpen[ id ], {} ) end if -- need to show menubar? if window_menu[ id ] then ok = c_func( xDrawMenuBar, {hWnd} ) end if -- display the window ok = c_func( xShowWindow, { hWnd, SW_SHOWNORMAL } ) -- update the window c_proc( xUpdateWindow, { hWnd } ) -- NEW! 0.14c -- set focus c_proc( xSetFocus, {hWnd} ) end procedure ------------------------------------------------------------------------------ -- NEW! 0.14c -- NEW! 0.15b renamed to openModal global procedure openModal( integer id ) -- same as openWindow, but window is opened as modal openWindow( id ) pushModal( id ) end procedure ----------------------------------------------------------------------------- global procedure WinMain( integer id ) -- main routine atom hWnd atom msg -- allocate a message buffer -- NEW! 0.15b changed allocate to allocate_struct msg = allocate_struct(SIZEOF_MESSAGE) -- create the default window defaultWindow = id openWindow( id ) -- message loop while c_func( xGetMessage, { msg, NULL, 0, 0 } ) do c_proc( xTranslateMessage, { msg } ) c_proc( xDispatchMessage, { msg } ) end while -- release all resources releaseAllResources() end procedure -- NEW ROUTINES ----------------------------------------------------------------------------- global procedure setFocus( integer id ) -- set the focus c_proc( xSetFocus, {window_handle[id]} ) end procedure -- In Euphoria 2.1 this file (unless modified) is FREE - 0 statements. with 5276208051 -- delete this statement if it causes an error