Not a member of Pastebin yet?
Sign Up,
it unlocks many cool features!
- (require 'org-archive)
- ; Set the function to use for org-archive-default (C-c C-x C-a)
- ; (setq org-archive-location (concat org-directory "/archive/%s_archive::"))
- ; (setq org-archive-location "archive/archived_%s::")
- (setq org-archive-location "::* ARCHIVED")
- ; unmap org-archive-subtree
- (define-key org-mode-map (kbd "C-c C-x C-s") nil)
- ; select command to execute via org-archive-subtree-default (C-c C-x C-a)
- (setq org-archive-default-command 'org-archive-subtree-hierarchical)
- (defun line-content-as-string ()
- "Returns the content of the current line as a string"
- (save-excursion
- (beginning-of-line)
- (buffer-substring-no-properties
- (line-beginning-position) (line-end-position))))
- (defun org-child-list (&optional top-level)
- "This function returns all children of a heading as a list. "
- (interactive)
- (save-excursion
- ;; this only works with org-version > 8.0, since in previous
- ;; org-mode versions the function (org-outline-level) returns
- ;; gargabe when the point is not on a heading.
- (unless top-level
- (if (= (org-outline-level) 0)
- (outline-next-visible-heading 1)
- (org-goto-first-child)))
- (let ((child-list (list (line-content-as-string))))
- (while (org-goto-sibling)
- (setq child-list (cons (line-content-as-string) child-list)))
- child-list)))
- (defun fa/org-struct-subtree ()
- "This function returns the tree structure in which a subtree
- belongs as a list."
- (interactive)
- (let ((archive-tree nil))
- (save-excursion
- (while (org-up-heading-safe)
- (let ((heading
- (buffer-substring-no-properties
- (line-beginning-position) (line-end-position))))
- (if (eq archive-tree nil)
- (setq archive-tree (list heading))
- (setq archive-tree (cons heading archive-tree))))))
- archive-tree))
- (defun org-archive-subtree-hierarchical ()
- "This function archives a subtree hierarchical"
- (interactive)
- (let ((org-tree (fa/org-struct-subtree))
- (this-buffer (current-buffer))
- (file (abbreviate-file-name
- (or (buffer-file-name (buffer-base-buffer))
- (error "No file associated to buffer")))))
- (save-excursion
- (setq location (org-get-local-archive-location)
- afile (org-extract-archive-file location)
- heading (org-extract-archive-heading location)
- infile-p (equal file (abbreviate-file-name (or afile ""))))
- (unless afile
- (error "Invalid `org-archive-location'"))
- (if (not (equal heading ""))
- (progn
- (setq org-tree (cons heading
- (mapcar (lambda (s) (concat "*" s)) org-tree)))
- (org-demote-subtree)))
- (if (> (length afile) 0)
- (setq newfile-p (not (file-exists-p afile))
- visiting (find-buffer-visiting afile)
- buffer (or visiting (find-file-noselect afile)))
- (progn
- (clone-indirect-buffer)
- (setq buffer (current-buffer))))
- (unless buffer
- (error "Cannot access file \"%s\"" afile))
- (org-cut-subtree)
- (set-buffer buffer)
- (org-mode)
- (goto-char (point-min))
- ; simplified version of org-complex-heading-regexp-format
- (setq my-org-complex-heading-regexp-format
- (concat "^"
- "\\(%s\\)"
- "\\(?: *\\[[0-9%%/]+\\]\\)*"
- "\\(?:[ \t]+\\(:[[:alnum:]_@#%%:]+:\\)\\)?"
- "[ \t]*$"))
- (setq top-level-p t)
- (while (not (equal org-tree nil))
- (let ((child-list (org-child-list top-level-p))
- (re (format my-org-complex-heading-regexp-format (regexp-quote (car org-tree))))
- )
- (if (member "______FOUND_MATCH" (mapcar (lambda (s) (replace-regexp-in-string re "______FOUND_MATCH" s)) child-list))
- (progn
- (re-search-forward re nil t)
- (setq org-tree (cdr org-tree)))
- (progn
- (if (not top-level-p) (newline))
- (org-insert-struct org-tree)
- (setq org-tree nil))))
- (setq top-level-p nil))
- (newline)
- (org-yank)
- ;; Save and kill the buffer, if it is not the same buffer.
- (when (not (eq this-buffer buffer))
- (save-buffer)
- (kill-buffer))
- (message "Subtree archived %s"
- (concat "in file: " (abbreviate-file-name afile))))))
- (defun org-insert-struct (struct)
- "TODO"
- (interactive)
- (when struct
- (insert (car struct))
- (if (not (equal (length struct) 1))
- (newline))
- (org-insert-struct (cdr struct))))
Add Comment
Please, Sign In to add comment