cgit.sxemacs.org Git - packages/blob - xemacs-packages/mew/mew/contrib/mew-wheel.el

   1 ;;
   2 ;; mew-wheel.el by Yuuichi Teranishi \e$B;{@>M50l\e(B <teranisi@isl.ntt.co.jp>
   3 ;; Read the mew messages by spinning the mouse wheel.
   4
   5 ;; [How to Use]
   6 ;;
   7 ;;(require 'mew-wheel)
   8 ;;(add-hook
   9 ;; 'mew-summary-mode-hook
  10 ;; (lambda ()
  11 ;;   (if mew-xemacs-p
  12 ;;       (progn
  13 ;;       (define-key mew-summary-mode-map 'button4 'mew-summary-wheel-up)
  14 ;;       (define-key mew-summary-mode-map 'button5 'mew-summary-wheel-down)
  15 ;;       (define-key mew-summary-mode-map [(shift button4)]
  16 ;;         'mew-summary-wheel-up)
  17 ;;       (define-key mew-summary-mode-map [(shift button5)]
  18 ;;         'mew-summary-wheel-down)
  19 ;;       )
  20 ;;     (define-key mew-summary-mode-map [mouse-4] 'mew-summary-wheel-up)
  21 ;;     (define-key mew-summary-mode-map [mouse-5] 'mew-summary-wheel-down)
  22 ;;     (define-key mew-summary-mode-map [S-mouse-4] 'mew-summary-wheel-up)
  23 ;;     (define-key mew-summary-mode-map [S-mouse-5] 'mew-summary-wheel-down))))
  24
  25 ;;(add-hook
  26 ;; 'mew-message-mode-hook
  27 ;; (lambda ()
  28 ;;   (if mew-xemacs-p
  29 ;;       (progn
  30 ;;       (define-key mew-message-mode-map 'button4 'mew-message-wheel-up)
  31 ;;       (define-key mew-message-mode-map 'button5 'mew-message-wheel-down)
  32 ;;       (define-key mew-message-mode-map [(shift button4)]
  33 ;;         'mew-message-wheel-up)
  34 ;;       (define-key mew-message-mode-map [(shift button5)]
  35 ;;         'mew-message-wheel-down)
  36 ;;       )
  37 ;;     (define-key mew-message-mode-map [mouse-4] 'mew-message-wheel-up)
  38 ;;     (define-key mew-message-mode-map [mouse-5] 'mew-message-wheel-down)
  39 ;;     (define-key mew-message-mode-map [S-mouse-4] 'mew-message-wheel-up)
  40 ;;     (define-key mew-message-mode-map [S-mouse-5] 'mew-message-wheel-down))))
  41 ;;
  42
  43 (defvar mew-wheel-scroll-amount '(5 . 1)
  44   "Amount to scroll messages by spinning the mouse wheel.
  45 This is actually a cons cell, where the first item is the amount to scroll
  46 on a normal wheel event, and the second is the amount to scroll when the
  47 wheel is moved with the shift key depressed.")
  48
  49 (defun mew-summary-wheel-down (event)
  50   "Make this message scroll down by spinning the mouse wheel."
  51   (interactive "e")
  52   (let ((amount (if (memq 'shift (event-modifiers event))
  53                     (cdr mew-wheel-scroll-amount)
  54                   (car mew-wheel-scroll-amount))))
  55     (if mew-summary-buffer-disp-msg
  56           (let ((buf (current-buffer))
  57                 (msg (mew-summary-message-number))
  58                 (ofld-msg (mew-current-get 'message))
  59                 (part (mew-syntax-nums))
  60                 (opart (mew-current-get 'part)))
  61             (cond ((or (and msg (null part) (string= msg (cdr ofld-msg)))
  62                        (and part (equal part opart)))
  63                    (unwind-protect
  64                        (progn
  65                          (mew-window-configure buf 'message)
  66                          (if (mew-message-next-page (if amount amount 1))
  67                              (mew-message-next-msg))
  68                          )
  69                      (pop-to-buffer buf)))
  70                   ((or msg part)
  71                    (mew-summary-show))
  72                   (t
  73                    (message "No message or part here"))))
  74       (scroll-up amount))))
  75
  76 (defun mew-summary-wheel-up (event)
  77   "Make this message scroll up by spinning the mouse wheel."
  78   (interactive "e")
  79   (let ((amount (if (memq 'shift (event-modifiers event))
  80                     (cdr mew-wheel-scroll-amount)
  81                   (car mew-wheel-scroll-amount))))
  82     (if mew-summary-buffer-disp-msg
  83         (if (or (mew-summary-message-number) (mew-syntax-number))
  84             (let ((buf (current-buffer)))
  85               (unwind-protect
  86                   (progn
  87                     (mew-window-configure buf 'message)
  88                     (condition-case ()
  89                         (mew-message-prev-page (if amount amount 1))
  90                       (error
  91                        (mew-message-next-msg -1))))
  92                 (pop-to-buffer buf))
  93               )
  94           (mew-summary-display-up))
  95       (scroll-down amount))))
  96
  97 (defun mew-message-wheel-down (event)
  98   "Make this message scroll down by spinning the mouse wheel."
  99   (interactive "e")
 100   (save-selected-window
 101     (select-window (if (fboundp 'event-window)
 102                        (event-window event)
 103                      (posn-window (event-start event)))))
 104   (mew-summary-wheel-down event))
 105
 106 (defun mew-message-wheel-up (event)
 107   "Make this message scroll up by spinning the mouse wheel."
 108   (interactive "e")
 109   (save-selected-window
 110     (select-window (if (fboundp 'event-window)
 111                        (event-window event)
 112                      (posn-window (event-start event)))))
 113   (mew-summary-wheel-up event))
 114
 115
 116 (provide 'mew-wheel)