mirrors/ecl
1
Fork 0
mirror of https://gitlab.com/embeddable-common-lisp/ecl.git synced 2026-01-02 07:30:55 -08:00
Code Issues Projects Releases Packages Wiki Activity

Context menu support added.

Browse source
This commit is contained in:
goffioul 2005-06-13 11:41:43 +00:00
parent 298ef96c41
commit f885a005ab
2 changed files with 58 additions and 3 deletions
Download patch file Download diff file Expand all files Collapse all files

29
contrib/win32/txtedit.lisp
View file

@ -226,6 +226,11 @@ Copyright (c) 2005, Michael Goffioul.")
(update-caption hwnd)
(update-tab *txtedit-current*))))
(defun close-or-exit (idx hwnd)
(if (= (length *txtedit-edit*) 1)
(postmessage hwnd *WM_CLOSE* 0 0)
(close-editor idx hwnd)))
(defun tab-proc (hwnd umsg wparam lparam)
(cond ((= umsg *WM_COMMAND*)
(txtedit-proc (getparent hwnd) umsg wparam lparam))
@ -284,6 +289,26 @@ Copyright (c) 2005, Michael Goffioul.")
(t
))))
0)
((= umsg *WM_CONTEXTMENU*)
(let ((hnd (make-handle wparam))
(x (get-x-lparam lparam))
(y (get-y-lparam lparam)))
(cond ((equal hnd *txtedit-tab*)
(with-foreign-objects ((ht 'TCHITTESTINFO)
(pt 'POINT))
(setf (get-slot-value pt 'POINT 'x) x)
(setf (get-slot-value pt 'POINT 'y) y)
(screentoclient *txtedit-tab* pt)
(setf (get-slot-value ht 'TCHITTESTINFO 'pt) pt)
(let ((tab (sendmessage *txtedit-tab* *TCM_HITTEST* 0 (make-lparam ht))))
(when (>= tab 0)
(let ((hMenu (createpopupmenu))
menu-ID)
(appendmenu hMenu *MF_STRING* +IDM_CLOSE+ "&Close")
(when (/= (setq menu-ID (trackpopupmenuex hMenu (logior *TPM_NONOTIFY* *TPM_RETURNCMD*) x y hwnd *NULL*)) 0)
(close-or-exit tab hwnd))
(destroymenu hMenu))))))))
0)
((= umsg *WM_INITMENUPOPUP*)
(case (loword lparam)
(2 (let* ((wMenu (make-handle wparam))
@ -357,9 +382,7 @@ Copyright (c) 2005, Michael Goffioul.")
(unless (= *txtedit-current* 0)
(set-current-editor (1- *txtedit-current*) hwnd)))
((= ctrl-ID +IDM_CLOSE+)
(if (= (length *txtedit-edit*) 1)
(sendmessage hwnd *WM_CLOSE* 0 0)
(close-editor *txtedit-current* hwnd)))
(close-or-exit *txtedit-current* hwnd))
((<= +IDM_WINDOW_FIRST+ ctrl-ID +IDM_WINDOW_LAST+)
(set-current-editor (- ctrl-ID +IDM_WINDOW_FIRST+) hwnd)
0)

32
contrib/win32/win32.lisp
View file

@ -18,6 +18,7 @@
(clines "#define WINVER 0x500")
(clines "#include <windows.h>")
(clines "#include <windowsx.h>")
(clines "#include <commctrl.h>")
(clines "#include <richedit.h>")
@ -37,6 +38,7 @@
(define-win-constant *WM_CLOSE* "WM_CLOSE")
(define-win-constant *WM_COMMAND* "WM_COMMAND")
(define-win-constant *WM_CONTEXTMENU* "WM_CONTEXTMENU")
(define-win-constant *WM_COPY* "WM_COPY")
(define-win-constant *WM_CREATE* "WM_CREATE")
(define-win-constant *WM_CUT* "WM_CUT")
@ -110,14 +112,23 @@
(define-win-constant *TCIF_STATE* "TCIF_STATE")
(define-win-constant *TCIF_TEXT* "TCIF_TEXT")
(define-win-constant *TCHT_NOWHERE* "TCHT_NOWHERE")
(define-win-constant *TCHT_ONITEM* "TCHT_ONITEM")
(define-win-constant *TCHT_ONITEMICON* "TCHT_ONITEMICON")
(define-win-constant *TCHT_ONITEMLABEL* "TCHT_ONITEMLABEL")
(define-win-constant *TCM_ADJUSTRECT* "TCM_ADJUSTRECT")
(define-win-constant *TCM_DELETEITEM* "TCM_DELETEITEM")
(define-win-constant *TCM_GETCURSEL* "TCM_GETCURSEL")
(define-win-constant *TCM_HITTEST* "TCM_HITTEST")
(define-win-constant *TCM_INSERTITEM* "TCM_INSERTITEM")
(define-win-constant *TCM_SETCURSEL* "TCM_SETCURSEL")
(define-win-constant *TCM_SETITEM* "TCM_SETITEM")
(define-win-constant *TCN_SELCHANGE* "TCN_SELCHANGE" :unsigned-int)
(define-win-constant *NM_CLICK* "NM_CLICK" :unsigned-int)
(define-win-constant *NM_RCLICK* "NM_RCLICK" :unsigned-int)
(define-win-constant *SW_HIDE* "SW_HIDE")
(define-win-constant *SW_SHOW* "SW_SHOW")
(define-win-constant *SW_SHOWNORMAL* "SW_SHOWNORMAL")
@ -173,6 +184,17 @@
(define-win-constant *MF_STRING* "MF_STRING")
(define-win-constant *MF_UNCHECKED* "MF_UNCHECKED")
(define-win-constant *TPM_CENTERALIGN* "TPM_CENTERALIGN")
(define-win-constant *TPM_LEFTALIGN* "TPM_LEFTALIGN")
(define-win-constant *TPM_RIGHTALIGN* "TPM_RIGHTALIGN")
(define-win-constant *TPM_BOTTOMALIGN* "TPM_BOTTOMALIGN")
(define-win-constant *TPM_TOPALIGN* "TPM_TOPALIGN")
(define-win-constant *TPM_VCENTERALIGN* "TPM_VCENTERALIGN")
(define-win-constant *TPM_NONOTIFY* "TPM_NONOTIFY")
(define-win-constant *TPM_RETURNCMD* "TPM_RETURNCMD")
(define-win-constant *TPM_LEFTBUTTON* "TPM_LEFTBUTTON")
(define-win-constant *TPM_RIGHTBUTTON* "TPM_RIGHTBUTTON")
(define-win-constant *OFN_FILEMUSTEXIST* "OFN_FILEMUSTEXIST")
(define-win-constant *OFN_OVERWRITEPROMPT* "OFN_OVERWRITEPROMPT")
(define-win-constant *OFN_PATHMUSTEXIST* "OFN_PATHMUSTEXIST")
@ -271,6 +293,8 @@
(def-struct TCITEM (mask :unsigned-int) (dwState :unsigned-int) (dwStateMask :unsigned-int)
(pszText :cstring) (cchTextMax :int) (iImage :int) (lParam :long))
(def-struct NMHDR (hwndFrom HANDLE) (idFrom :unsigned-int) (code :unsigned-int))
(def-struct TCHITTESTINFO (pt POINT) (flag :unsigned-int))
(def-struct TPMPARAMS (cbSize :unsigned-int) (rcExclude RECT))
;; Windows functions
@ -393,6 +417,9 @@ LRESULT CALLBACK WndProc_proxy(HWND hwnd, UINT uMsg, WPARAM wParam, LPARAM lPara
(def-function ("CallWindowProc" callwindowproc) ((wndProc HANDLE) (hWnd HANDLE) (uMsg :unsigned-int) (wParam :unsigned-int) (lParam :int)) :returning :int)
(def-function ("HIWORD" hiword) ((dWord :unsigned-int)) :returning :unsigned-int)
(def-function ("LOWORD" loword) ((dWord :unsigned-int)) :returning :unsigned-int)
(def-function ("GET_X_LPARAM" get-x-lparam) ((lParam :int)) :returning :int)
(def-function ("GET_Y_LPARAM" get-y-lparam) ((lParam :int)) :returning :int)
(def-function ("ScreenToClient" screentoclient) ((hWnd HANDLE) (pt (* POINT))) :returning :int)
(def-function ("MessageBox" messagebox) ((hWnd HANDLE) (lpText LPCSTR) (lpCaption LPCSTR) (uType :unsigned-int)) :returning :int)
(def-function ("GetOpenFileName" getopenfilename) ((lpofn (* OPENFILENAME))) :returning :int)
(def-function ("GetSaveFileName" getsavefilename) ((lpofn (* OPENFILENAME))) :returning :int)
@ -401,6 +428,7 @@ LRESULT CALLBACK WndProc_proxy(HWND hwnd, UINT uMsg, WPARAM wParam, LPARAM lPara
(def-function ("DispatchMessage" dispatchmessage) ((lpMsg (* MSG))) :returning :int)
(def-function ("CreateMenu" createmenu) nil :returning HANDLE)
(def-function ("CreatePopupMenu" createpopupmenu) nil :returning HANDLE)
(def-function ("DestroyMenu" destroymenu) ((hMenu HANDLE)) :returning :int)
(def-function ("AppendMenu" appendmenu) ((hMenu HANDLE) (uFlags :unsigned-int) (uIDNewItem :unsigned-int) (lpNewItem LPCSTR)) :returning :int)
(def-function ("GetSubMenu" getsubmenu) ((hMenu HANDLE) (nPos :int)) :returning HANDLE)
(def-function ("DeleteMenu" deletemenu) ((hMenu HANDLE) (uPosition :unsigned-int) (uFlags :unsigned-int)) :returning :int)
@ -408,6 +436,10 @@ LRESULT CALLBACK WndProc_proxy(HWND hwnd, UINT uMsg, WPARAM wParam, LPARAM lPara
(def-function ("GetMenuItemCount" getmenuitemcount) ((hMenu HANDLE)) :returning :int)
(def-function ("CheckMenuItem" checkmenuitem) ((hMenu HANDLE) (uIDCheckItem :unsigned-int) (uCheck :unsigned-int)) :returning :int)
(def-function ("EnableMenuItem" enablemenuitem) ((hMenu HANDLE) (uIDCheckItem :unsigned-int) (uCheck :unsigned-int)) :returning :int)
(def-function ("TrackPopupMenu" trackpopupmenu) ((hMenu HANDLE) (uFlags :unsigned-int) (x :int) (y :int)
(nReserved :int) (hWnd HANDLE) (prcRect HANDLE)) :returning :int)
(def-function ("TrackPopupMenuEx" trackpopupmenuex) ((hMenu HANDLE) (fuFlags :unsigned-int) (x :int) (y :int)
(hWnd HANDLE) (lptpl (* TPMPARAMS))) :returning :int)
(def-function ("CreateAcceleratorTable" createacceleratortable) ((lpaccl (* ACCEL)) (cEntries :int)) :returning HANDLE)
(def-function ("TranslateAccelerator" translateaccelerator) ((hWnd HANDLE) (hAccTable HANDLE) (lpMsg (* MSG))) :returning :int)
(def-function ("DestroyAcceleratorTable" destroyacceleratortable) ((hAccTable HANDLE)) :returning :int)