\ File: StatusBar.f \ Author: Jeff Kelm \ Created: August 12th, 1998 - 16:07 \ Updated: September 11th, 1998 - 17:57 \ \\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\ \ \\\ Extensions to Win32For \ : ?WinError ( f) \ show an error dialog box if f=FALSE/0 0= IF \ Get last error message ID Call GetLastError >R \ format system message ID as a string NULL \ no arguments MAXSTRING \ size of buffer TEMP$ rel>abs \ buffer to hold resulting formatted string 0 \ default language ID R> \ message ID from above NULL \ ignored FORMAT_MESSAGE_FROM_SYSTEM \ format a message ID from the system Call FormatMessage \ returns message length or zero if not found \ handle the 'not found' case IF TEMP$ ELSE Z" Unknown Error" THEN rel>abs >R \ Create a message box with one button MB_OK MB_ICONWARNING OR \ message box style flags Z" Error" rel>abs \ title of message box R> \ error message string from above NULL \ no parent/owner window Call MessageBox \ create a message box with the error text DROP \ ignore return result THEN ; \ defines a default condition for CASE structure (must be last!) \ Usage: CASE \ n1 OF ... ENDOF \ n2 OF ... ENDOF \ ... \ nn OF ... ENDOF \ DEFAULTOF ... ENDOF \ ENDCASE \ : DEFAULTOF POSTPONE DUP POSTPONE OF ; IMMEDIATE \ create a new id number (hopefully unique) 200 VALUE (NextID) : CreateNewID ( -- id) (NextID) DUP 1+ TO (NextID) ; \ Add the advanced control library. \ Needed for "CreateToolbarEx" procedure and others. WinLibrary COMCTL32.DLL \ defines from WinUser.h not in Win32for WINCON.DLL 0x80000000 CONSTANT CW_USEDEFAULT WM_USER 1+ CONSTANT SB_SETTEXT \ \\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\ \ \\\ Define Command ID's \ CreateNewID constant IDM_NEW CreateNewID constant IDM_OPEN CreateNewID constant IDM_SAVE CreateNewID constant IDM_COPY CreateNewID constant IDM_PASTE CreateNewID constant IDM_PRINT CreateNewID constant IDM_ABOUT CreateNewID CONSTANT IDM_EXIT CreateNewID constant IDM_CUT CreateNewID constant ID_Status COMMENT: Explanation of what is happening in appMenu: Create an empty menubar structure: Call CreateMenu TO hMenu Creates an empty drop-down menu and saves the handle on the return stack: Call CreatePopupMenu >R Now create a menu entry in the application menubar for the PopupMenu created above: Z" &File" rel>abs \ menu-item content R@ \ handle of drop-down menu from return stack MF_STRING MF_POPUP OR \ menu-item flags hMenu \ handle to menubar Call AppendMenu ?WinError For each of the menu items within this PopupMenu, create a menuitem entry: Z" &New..." rel>abs \ menu-item content IDM_NEW \ menu-item identifier MF_STRING \ menu-item flags R@ \ handle to PopupMenu Call AppendMenu ?WinError A separator (horizontal line) is placed in a PopupMenu this way: NULL \ menu-item content NULL \ menu-item identifier MF_SEPARATOR \ menu-item flags R@ \ handle to PopupMenu Call AppendMenu ?WinError This process repeats itself for each item or seperator in the PopupMenu. Then the handle on the return stack is discarded and a new menubar item is defined and the process repeats. COMMENT; \ \\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\ \ \\\ Define Menu \ 0 VALUE hMenu \ to hold handle for menu : appMenu \ Create the main window menu Call CreateMenu TO hMenu \ create an empty menu structure Call CreatePopupMenu >R \ create File pull-down menu Z" &File" rel>abs R@ MF_STRING MF_POPUP OR hMenu Call AppendMenu ?WinError Z" &New..." rel>abs IDM_NEW MF_STRING R@ Call AppendMenu ?WinError Z" &Open..." rel>abs IDM_OPEN MF_STRING R@ Call AppendMenu ?WinError Z" &Save..." rel>abs IDM_SAVE MF_STRING R@ Call AppendMenu ?WinError NULL NULL MF_SEPARATOR R@ Call AppendMenu ?WinError Z" &Print..." rel>abs IDM_PRINT MF_STRING R@ Call AppendMenu ?WinError NULL NULL MF_SEPARATOR R@ Call AppendMenu ?WinError Z" E&xit" rel>abs IDM_EXIT MF_STRING R@ Call AppendMenu ?WinError R> DROP Call CreatePopupMenu >R \ create Edit pull-down menu Z" &Edit" rel>abs R@ MF_STRING MF_POPUP OR hMenu Call AppendMenu ?WinError Z" Cu&t" rel>abs IDM_CUT MF_STRING R@ Call AppendMenu ?WinError Z" &Copy..." rel>abs IDM_COPY MF_STRING R@ Call AppendMenu ?WinError Z" &Paste" rel>abs IDM_PASTE MF_STRING R@ Call AppendMenu ?WinError R> DROP Call CreatePopupMenu >R \ create Help pull-down menu Z" &Help" rel>abs R@ MF_STRING MF_POPUP OR hMenu Call AppendMenu ?WinError Z" &About..." rel>abs IDM_ABOUT MF_STRING R@ Call AppendMenu ?WinError R> DROP ; \ \\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\ \ \\\ Main Routine \ : MenuName Z" StatusbarMenu" rel>abs ; : ClassName Z" StatusbarWClass" rel>abs ; : wTitle Z" Statusbar Sample" rel>abs ; 0 VALUE hWnd \ application window handle 0 VALUE hStatusbar \ Status Bar handle : MenuFunc \ Default "Not Implemented" function for menu items MB_OK Z" Command" rel>abs Z" Not implemented in this sample." rel>abs hWnd ( NULL) Call MessageBox drop ; \ Object to build and hold mouse position string :Object szBuf D (D.) Append: self S" , " Append: self S>D (D.) Append: self ;M :M Display: ( -- lpString) Get: self DROP rel>abs ;M ;Object \ Define the window procedure : (HELLO-WNDPROC) { hWnd msg wParam lParam -- result } msg CASE WM_CREATE OF \ Create the Status Bar ID_Status \ Statusbar ID hWnd \ Parent Window handle NULL \ initial string to display WS_CHILD WS_BORDER or WS_VISIBLE or \ style Call CreateStatusWindow DUP TO hStatusbar ?WinError 0 ENDOF WM_MOUSEMOVE OF lParam LOWORD lParam HIWORD Update: szBuf Display: szBuf 0 SB_SETTEXT hStatusbar Call SendMessage ENDOF WM_SIZE OF NULL NULL WM_SIZE hStatusbar Call SendMessage \ resize Status Window 0 ENDOF WM_COMMAND OF \ ( hWndToolbar idButton WM_COMMAND hWnd) wParam LOWORD CASE IDM_NEW OF MenuFunc ENDOF IDM_OPEN OF MenuFunc ENDOF IDM_SAVE OF MenuFunc ENDOF IDM_CUT OF MenuFunc ENDOF IDM_COPY OF MenuFunc ENDOF IDM_PASTE OF MenuFunc ENDOF IDM_PRINT OF MenuFunc ENDOF IDM_EXIT OF MenuFunc ENDOF IDM_ABOUT OF MenuFunc ENDOF ENDCASE 0 ENDOF DEFAULTOF lParam wParam msg hWnd Call DefWindowProc ENDOF ENDCASE ; 4 callback hello-wndproc (hello-wndproc) \ Application Window Class structure CREATE wcStatusbar \ WNDCLASS structure NULL , \ style hello-wndproc rel>abs , \ lpfnWndProc 0 , \ cbClsExtra 0 , \ cbWndExtra appInst , \ hInstance IDI_WINLOGO NULL Call LoadIcon , \ hIcon IDC_CROSS NULL call LoadCursor , \ hCursor WHITE_BRUSH call GetStockObject , \ hbrBackground MenuName , \ lpszMenuName ClassName , \ lpszClassName : REGISTER-CLASS wcStatusbar rel>abs Call RegisterClass ?WinError ; : CREATE-DEMO-WINDOW NULL \ creation parameters AppInst \ instance handle hMenu \ menu handle NULL \ parent window CW_USEDEFAULT CW_USEDEFAULT \ window size ( h w) CW_USEDEFAULT CW_USEDEFAULT \ window position ( y x ) WS_OVERLAPPEDWINDOW \ window style wTitle \ window title ClassName \ class name NULL \ extended window style Call CreateWindowEx DUP TO hWnd ?WinError ; \ \\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\ \ \\\ Main Call \ : CLEANUP hWnd Call DestroyWindow ?WinError appInst ClassName Call UnregisterClass ?WinError ; : DEMO ( -- ) appMenu REGISTER-CLASS CREATE-DEMO-WINDOW SW_SHOWNORMAL hWnd Call ShowWindow DROP hWnd Call UpdateWindow DROP ; CR .( Type 'DEMO' to run program, 'CLEANUP' to kill demo.)