* xyzzy lisp : 位置とサイズの操作
また勢いだけで使いそうに無いものを作ってしまった。
メニュー周りの関数を使ったのは初めてかもしれない。
update : 2006-07-30 (Sun) 01:56:27
(eval-when (:compile-toplevel :load-toplevel :execute) (require "wip/winapi") (require "api")) (provide "geometry") (in-package "editor") (export '(maximize-height-window maximize-width-window move-to-left-window move-to-top-window move-to-right-window move-to-bottom-window move-window *geometry-presets-size* *geometry-presets*)) (defvar *geometry-presets-size* *menu-history-max*) (defvar *geometry-popup-menu* nil) (unless *geometry-popup-menu* (setq *geometry-popup-menu* (create-popup-menu :geometry-popup))) (define-history-variable *geometry-presets* nil) ; 上下に最大化 (defun maximize-height-window () (interactive) (let ((wr (winapi:make-RECT))) (winapi:GetWindowRect (get-window-handle) wr) (winapi:MoveWindow (get-window-handle) (winapi:RECT-left wr) 0 (- (winapi:RECT-right wr) (winapi:RECT-left wr)) (- (winapi:GetSystemMetrics winapi:SM_CYMAXIMIZED) (* 2 (winapi:GetSystemMetrics winapi:SM_CYSIZEFRAME))) 1)) t) ; 左右に最大化 (defun maximize-width-window () (interactive) (let ((wr (winapi:make-RECT))) (winapi:GetWindowRect (get-window-handle) wr) (winapi:MoveWindow (get-window-handle) 0 (winapi:RECT-top wr) (- (winapi:GetSystemMetrics winapi:SM_CXMAXIMIZED) (* 2 (winapi:GetSystemMetrics winapi:SM_CXSIZEFRAME))) (- (winapi:RECT-bottom wr) (winapi:RECT-top wr)) 1)) t) ; 左に寄せる (defun move-to-left-window () (interactive) (let ((wr (winapi:make-RECT))) (winapi:GetWindowRect (get-window-handle) wr) (winapi:MoveWindow (get-window-handle) 0 (winapi:RECT-top wr) (- (winapi:RECT-right wr) (winapi:RECT-left wr)) (- (winapi:RECT-bottom wr) (winapi:RECT-top wr)) 1)) t) ; 上に寄せる (defun move-to-top-window () (interactive) (let ((wr (winapi:make-RECT))) (winapi:GetWindowRect (get-window-handle) wr) (winapi:MoveWindow (get-window-handle) (winapi:RECT-left wr) 0 (- (winapi:RECT-right wr) (winapi:RECT-left wr)) (- (winapi:RECT-bottom wr) (winapi:RECT-top wr)) 1)) t) ; 右に寄せる (defun move-to-right-window () (interactive) (let ((wr (winapi:make-RECT))) (winapi:GetWindowRect (get-window-handle) wr) (winapi:MoveWindow (get-window-handle) (- (winapi:GetSystemMetrics winapi:SM_CXMAXIMIZED) (- (winapi:RECT-right wr) (winapi:RECT-left wr)) (* 2 (winapi:GetSystemMetrics winapi:SM_CXSIZEFRAME))) (winapi:RECT-top wr) (- (winapi:RECT-right wr) (winapi:RECT-left wr)) (- (winapi:RECT-bottom wr) (winapi:RECT-top wr)) 1)) t) ; 下に寄せる (defun move-to-bottom-window () (interactive) (let ((wr (winapi:make-RECT))) (winapi:GetWindowRect (get-window-handle) wr) (winapi:MoveWindow (get-window-handle) (winapi:RECT-left wr) (- (winapi:GetSystemMetrics winapi:SM_CYMAXIMIZED) (- (winapi:RECT-bottom wr) (winapi:RECT-top wr)) (* 2 (winapi:GetSystemMetrics winapi:SM_CYSIZEFRAME))) (- (winapi:RECT-right wr) (winapi:RECT-left wr)) (- (winapi:RECT-bottom wr) (winapi:RECT-top wr)) 1)) t) (defun move-window () (interactive) (let ((wr (winapi:make-RECT))) (winapi:GetWindowRect (get-window-handle) wr) (let ((left (winapi:RECT-left wr)) (top (winapi:RECT-top wr)) (width (- (winapi:RECT-right wr) (winapi:RECT-left wr))) (height (- (winapi:RECT-bottom wr) (winapi:RECT-top wr)))) (winapi:MoveWindow (get-window-handle) (parse-integer (read-string (format nil "left(~D): " left) :default (format nil "~D" left))) (parse-integer (read-string (format nil "top(~D): " top) :default (format nil "~D" top))) (parse-integer (read-string (format nil "width(~D): " width) :default (format nil "~D" width))) (parse-integer (read-string (format nil "height(~D): " height) :default (format nil "~D" height))) 1))) t) (defun set-geometry (text) (string-match "(\\([0-9]+\\),\\([0-9]+\\))-(\\([0-9]+\\),\\([0-9]+\\))" text) (let ((left (parse-integer (match-string 1))) (top (parse-integer (match-string 2))) (right (parse-integer (match-string 3))) (bottom (parse-integer (match-string 4)))) (winapi:MoveWindow (get-window-handle) left top (- right left) (- bottom top) 1)) t) (defun recode-geometry () (interactive) (let ((wr (winapi:make-RECT))) (winapi:GetWindowRect (get-window-handle) wr) (let ((text (format nil "(~D,~D)-(~D,~D)" (winapi:RECT-left wr) (winapi:RECT-top wr) (winapi:RECT-right wr) (winapi:RECT-bottom wr)))) (setq *geometry-presets* (delete text *geometry-presets* :test #'string= :key #'car)) (push (list text (winapi:RECT-left wr) (winapi:RECT-top wr) (- (winapi:RECT-right wr) (winapi:RECT-left wr)) (- (winapi:RECT-bottom wr) (winapi:RECT-top wr))) *geometry-presets*) (when (< *geometry-presets-size* (length *geometry-presets*)) (setq *geometry-presets* (nbutlast *geometry-presets*))))) (add-geometry-presets-to-menu)) (defun add-geometry-presets-menu (menu texts fn) (when (menup menu) (while (delete-menu menu 0 t)) (do ((text texts (cdr text)) (count 1)) ((or (null text) (> count *menu-history-max*)) t) (insert-menu-item menu (1- count) nil (format nil "&~:(~35r~): ~a" (rem count 36) (quote-string (car text) #\& #\&)) (funcall fn (car text))) (incf count)))) (defun add-geometry-presets-to-menu () (when (menup *app-menu*) (when *geometry-presets* (add-geometry-presets-menu *geometry-popup-menu* (mapcar #'car *geometry-presets*) #'(lambda (text) #'(lambda () (interactive) (let ((item (cdr (assoc text *geometry-presets* :test #'string=)))) (if item (winapi:MoveWindow (get-window-handle) (first item) (second item) (third item) (fourth item) 1) (set-geometry text)))))) (add-menu-separator *geometry-popup-menu* :above-recode-geometry)) (add-menu-item *geometry-popup-menu* nil "現在の位置とサイズを保存(&S)" 'recode-geometry))) (defun insert-menu-for-move-window (&optional (tag :above-next-xyzzy)) (when (menup *app-menu*) (let ((window-menu (get-menu *app-menu* 'window))) (insert-menu-separator window-menu (get-menu-position window-menu tag) :above-maximize-height-window) (insert-menu-item window-menu (get-menu-position window-menu tag) nil "上下に最大化(&H)" 'maximize-height-window) (insert-menu-item window-menu (get-menu-position window-menu tag) nil "左右に最大化(&W)" 'maximize-width-window) (insert-menu-item window-menu (get-menu-position window-menu tag) nil "左に寄せる(&<)" 'move-to-left-window) (insert-menu-item window-menu (get-menu-position window-menu tag) nil "右に寄せる(&>)" 'move-to-right-window) (insert-menu-item window-menu (get-menu-position window-menu tag) nil "上に寄せる(&^)" 'move-to-top-window) (insert-menu-item window-menu (get-menu-position window-menu tag) nil "下に寄せる(&_)" 'move-to-bottom-window) (insert-popup-menu window-menu (get-menu-position window-menu :above-next-xyzzy) *geometry-popup-menu* "既定")))) (defun init-geometry-menu () (add-geometry-presets-to-menu) (insert-menu-for-move-window)) (add-hook '*init-app-menus-hook* 'init-geometry-menu) #| (defun set-geometry (text) (string-match "\\([0-9]+\\)x\\([0-9]+\\)\\([---+][0-9]+\\)\\([---+][0-9]+\\)" text) (let ((w (match-string 1)) (h (match-string 2)) (x (match-string 3)) (y (match-string 4)) (cr (winapi:make-RECT)) width height left top) (winapi:GetClientRect (get-window-handle) cr) (setq width (+ (* (truncate (- (winapi:RECT-right cr) (winapi:RECT-left cr)) (screen-width)) (parse-integer w)) (* 2 (winapi:GetSystemMetrics winapi:SM_CXSIZEFRAME)))) (setq height (+ (* (truncate (- (winapi:RECT-bottom cr) (winapi:RECT-top cr)) (screen-height)) (parse-integer h)) (* 2 (winapi:GetSystemMetrics winapi:SM_CYSIZEFRAME)))) (setq left (if (char= #\+ (char x 0)) (parse-integer x) (- (winapi:GetSystemMetrics winapi:SM_CXMAXIMIZED) (abs (parse-integer x)) width (* 2 (winapi:GetSystemMetrics winapi:SM_CXSIZEFRAME))))) (setq top (if (char= #\+ (char y 0)) (parse-integer y) (- (winapi:GetSystemMetrics winapi:SM_CYMAXIMIZED) (abs (parse-integer y)) height (* 2 (winapi:GetSystemMetrics winapi:SM_CYSIZEFRAME))))) (winapi:MoveWindow (get-window-handle) left top width height 1)) t) (defun get-geometry (wr cr) (let ((w (truncate (- (- (winapi:RECT-right wr) (winapi:RECT-left wr)) (* 2 (winapi:GetSystemMetrics winapi:SM_CXSIZEFRAME))) (truncate (- (winapi:RECT-right cr) (winapi:RECT-left cr)) (screen-width)))) (h (truncate (- (- (winapi:RECT-bottom wr) (winapi:RECT-top wr)) (* 2 (winapi:GetSystemMetrics winapi:SM_CYSIZEFRAME))) (truncate (- (winapi:RECT-bottom cr) (winapi:RECT-top cr)) (screen-height)))) (x (winapi:RECT-left wr)) (y (winapi:RECT-top wr))) (values (format nil "~Dx~D~@D~@D" w h x y) (list w h x y)))) (defun recode-geometry () (interactive) (let ((wr (winapi:make-RECT)) (cr (winapi:make-RECT))) (winapi:GetWindowRect (get-window-handle) wr) (winapi:GetClientRect (get-window-handle) cr) (let ((text (get-geometry wr cr))) (setq *geometry-presets* (delete text *geometry-presets* :test #'string= :key #'car)) (push (list text (winapi:RECT-left wr) (winapi:RECT-top wr) (- (winapi:RECT-right wr) (winapi:RECT-left wr)) (- (winapi:RECT-bottom wr) (winapi:RECT-top wr))) *geometry-presets*) (when (< *geometry-presets-size* (length *geometry-presets*)) (setq *geometry-presets* (nbutlast *geometry-presets*))))) (add-geometry-presets-to-menu)) |#
メニュー周りの関数を使ったのは初めてかもしれない。
update : 2006-07-30 (Sun) 01:56:27