Function: image-crop

image-crop is an autoloaded, interactive and byte-compiled function defined in image-crop.el.gz.

Signature

(image-crop &optional CUT)

Documentation

Crop the image under point.

This command presents the image with a rectangular area superimposed on it, and allows moving and resizing the area to define which part of it to crop.

While moving/resizing the cropping area, the following key bindings are available:

q: Exit without changing anything.
RET: Crop/cut the image.
m: Make mouse movements move the rectangle instead of altering the
       rectangle shape.
s: Same as m, but make the rectangle into a square first.

After cropping the image, you can save it by M-x image-save or i o (image-save) when point is over the image.

When called from Lisp, if CUT is non-nil, remove a rectangle from the image instead of cropping the image. In that case, CUT should be the name of a color to fill the rectangle.

View in manual

Probably introduced at or before Emacs version 29.1.

Key Bindings

Source Code

;; Defined in /usr/src/emacs/lisp/image/image-crop.el.gz
;;;###autoload
(defun image-crop (&optional cut)
  "Crop the image under point.
This command presents the image with a rectangular area superimposed
on it, and allows moving and resizing the area to define which
part of it to crop.

While moving/resizing the cropping area, the following key bindings
are available:

`q':   Exit without changing anything.
`RET': Crop/cut the image.
`m':   Make mouse movements move the rectangle instead of altering the
       rectangle shape.
`s':   Same as `m', but make the rectangle into a square first.

After cropping the image, you can save it by `M-x image-save' or
\\<image-map>\\[image-save] when point is over the image.

When called from Lisp, if CUT is non-nil, remove a rectangle from
the image instead of cropping the image.  In that case, CUT should
be the name of a color to fill the rectangle."
  (interactive)
  (unless (image-type-available-p 'svg)
    (error "SVG support is needed to crop and cut images"))
  (let* ((crop-cmd (car image-crop-crop-command))
         (found (executable-find crop-cmd)))
    (unless found
      (error "Couldn't find `%s' command to crop/cut the image" crop-cmd))
    (if (and (memq system-type '(windows-nt ms-dos))
             ;; MS-Windows has an incompatible convert.exe, used to
             ;; convert filesystems...
             (string-equal crop-cmd "convert")
             (= 0 (string-search "Invalid drive specification."
                                 (shell-command-to-string
                                  (format "%s %s" crop-cmd null-device)))))
        (error "The program `%s' is not an image conversion program"
               found)))
  (let ((image (image--get-image)))
    (unless (imagep image)
      (user-error "No image under point"))
    (when (overlays-at (point))
      (user-error "Can't edit images that have overlays"))
    ;; We replace the image under point with an SVG image that looks
    ;; just like that image.  That allows us to draw lines over it.
    ;; At the end, we replace that SVG with a cropped version of the
    ;; original image.
    (let* ((data (cl-getf (cdr image) :data))
	   (undo-handle (prepare-change-group))
	   (type (cond
		  ((cl-getf (cdr image) :format)
		   (format "%s" (cl-getf (cdr image) :format)))
		  (data
		   (image-crop--content-type data))))
	   (image-scaling-factor 1)
           (orig-point (point))
	   (size (image-size image t))
	   (svg (svg-create (car size) (cdr size)
			    :xmlns:xlink "http://www.w3.org/1999/xlink"
			    :stroke-width 5))
           ;; We want to get the original text that's covered by the
           ;; image so that we can restore it.
           (image-start
            (save-excursion
              (let ((match (text-property-search-backward 'display image)))
                (if match
                    (prop-match-end match)
                  (point-min)))))
           (image-end
            (save-excursion
              (let ((match (text-property-search-forward 'display image)))
                (if match
                    (prop-match-beginning match)
                  (point-max)))))
	   (text (buffer-substring image-start image-end))
	   (inhibit-read-only t)
           orig-data svg-end)
      (with-temp-buffer
	(set-buffer-multibyte nil)
	(if (null data)
	    (insert-file-contents-literally (cl-getf (cdr image) :file))
	  (insert data))
	(let ((image-crop-exif-rotate nil))
	  (image-crop--possibly-rotate-buffer image))
	(setq orig-data (buffer-string))
	(setq type (image-crop--content-type orig-data))
        (image-crop--process image-crop-resize-command
                             `((?w . 600)
                               (?f . ,(cadr (split-string type "/")))))
	(setq data (buffer-string)))
      (svg-embed svg data type t
		 :width (car size)
		 :height (cdr size))
      (with-buffer-unmodified-if-unchanged
        (delete-region image-start image-end)
        (svg-insert-image svg)
        (setq svg-end (point))
        (let ((area (condition-case _
                        (save-excursion
			  (forward-line 1)
			  (image-crop--crop-image-1
                           svg (if cut "cut" "crop")))
                      (quit nil))))
          (message (substitute-command-keys
                    "Type \\[image-save] to save %s image to file")
                   (if cut "cut" "cropped"))
	  (delete-region image-start svg-end)
	  (if area
	      (image-crop--crop-image-update
               area orig-data size type cut text)
	    ;; If the user didn't complete the crop, re-insert the
	    ;; original image (and text).
	    (insert text)
            (goto-char orig-point))
	  (undo-amalgamate-change-group undo-handle))))))