Move marked by `org-done-keywords' entries to archive file defined by `my-org-archive-location'.
authorOleksandr Gavenko <gavenkoa@gmail.com>
Mon, 03 Mar 2014 00:56:28 +0200
changeset 1112 1fc59cf19c28
parent 1111 494d4d574a26
child 1113 b0aec76c3745
Move marked by `org-done-keywords' entries to archive file defined by `my-org-archive-location'.
.emacs-my
--- a/.emacs-my	Sun Mar 02 22:44:07 2014 +0200
+++ b/.emacs-my	Mon Mar 03 00:56:28 2014 +0200
@@ -1340,7 +1340,6 @@
   (require 'org))
 
 ;; XXX org-todo-keywords '((sequence "TODO" "START" "|" "DONE")) for org-version 4.67c
-;; XXX (setq org-todo-keywords '("TODO" "START" "DONE")) for org-version 6.05b
 (when (or (featurep 'org) (featurep 'org-install))
   (add-to-list 'auto-mode-alist '("\\.org$" . org-mode))
   (setq org-directory "~/devel/my-devel/gtd")
@@ -1364,6 +1363,8 @@
   (define-key global-map "\C-va" 'org-agenda)
   (define-key global-map "\C-ve" (lambda nil (interactive) (find-file my-org-agenda-note-file)))
 
+  (setq org-todo-keywords '("TODO" "DONE"))
+
   ;; My tags for remember buffer.
   (setq org-tag-alist
         '(
@@ -1407,12 +1408,42 @@
     (org-remember-insinuate)
     ))
 
-  ;; (setq org-todo-keyword-faces
-  ;;       '(("TODO" . (:foreground "red" :weight bold))
-  ;;         ("WAIT" . (:foreground "orange" :weight bold))
-  ;;         ("DONE" . (:foreground "green" :weight bold))) )
   )
 
+
+(defun my-org-archive-location (org-file)
+  (concat (if (string-match "\\(.*\\)\\.org$" org-file)
+              (match-string 1 org-file)
+            org-file)
+          "_done.org"))
+
+(defun my-org-archive ()
+  "Move marked by `org-done-keywords' entries to archive file defined by `my-org-archive-location'."
+  (interactive)
+  (let ( (org-archive (my-org-archive-location (buffer-file-name)))
+         (entry-re (concat "^\\* "))
+         (entry-done-re (concat "^\\* *" (mapconcat 'regexp-quote org-done-keywords "\\|") " "))
+         entry-beg entry-end )
+    (save-excursion
+      (show-all)
+      (kill-new "")
+      (goto-char (point-min))
+      (while (re-search-forward entry-done-re nil t)
+        (setq entry-beg (line-beginning-position))
+        ()
+        (if (re-search-forward entry-re nil t)
+            (beginning-of-line)
+          (goto-char (point-max)))
+        (setq entry-end (point))
+        (let ( (last-command 'kill-region) )
+          (kill-region entry-beg entry-end))
+        )
+      (find-file org-archive)
+      (goto-char (point-max))
+      (insert ?\n)
+      (yank)
+      )))
+
 (setq org-agenda-include-diary t)
 
 (defun my-org-kill-by-tag (tag)