My code works for me. Here it is again.
I add mail-folder properties to get a default in the vm-save-folder prompt
and the mail-fcc prompt (with vm-fcc.el, appended); auto-fcc properties
cause automatic insertion of FCC fields when sending a message (except for
replies, this only works with mailabbrev).
(defun bbdb/auto-fcc-by-net (net)
(let* ((record (bbdb-search-simple nil net))
(folder (and record (bbdb-record-getprop record 'auto-fcc))))
(if folder
(mail-fcc (expand-file-name folder vm-folder-directory)))))
(add-hook 'after-load-alist
'("bbdb-com"
(insert-hooks 'bbdb-mail-abbrev-expand-hook nil
'after-bbdb-mail-abbrev-expand-hook)))
(add-hook 'after-bbdb-mail-abbrev-expand-hook 'bbdb/mail-abbrev-auto-fcc)
(defun bbdb/mail-abbrev-auto-fcc ()
(mapcar 'bbdb/auto-fcc-by-net records))
(add-hook 'mail-setup-hook 'bbdb/mail-auto-fcc)
(defun bbdb/mail-auto-fcc ()
(let ((to (mail-fetch-field "to" nil t)))
(if to
(mapcar 'bbdb/auto-fcc-by-net (rfc822-addresses to)))))
(defadvice vm-auto-select-folder (around bbdb-auto-select activate compile)
"If the message sender's BBDB entry has a `mail-folder' property, use that."
(let* ((record (bbdb/vm-update-record t))
(folder (and record (bbdb-record-getprop record 'mail-folder))))
(if folder
(setq ad-return-value (expand-file-name folder vm-folder-directory))
;; ad-do-it is the original body of vm-auto-select-folder.
ad-do-it)))
;;; vm-fcc.el -- mail-fcc command for VM users.
;;; Copyright (C) 1992 Roland McGrath
;;; Based on code from vm-summary.el, version 5.32 beta.
;;; Copyright (C) 1989, 1990 Kyle E. Jones
;;;
;;; This program is free software; you can redistribute it and/or modify
;;; it under the terms of the GNU General Public License as published by
;;; the Free Software Foundation; either version 2, or (at your option)
;;; any later version.
;;;
;;; This program is distributed in the hope that it will be useful,
;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
;;; GNU General Public License for more details.
;;;
;;; A copy of the GNU General Public License can be obtained from this
;;; program's author (send electronic mail to [EMAIL PROTECTED]) or
;;; from the Free Software Foundation, Inc., 675 Mass Ave, Cambridge, MA
;;; 02139, USA.
;;;
;;; Send bug reports to [EMAIL PROTECTED]
;;;
;;; This is a mail-fcc function, bound to C-c C-f C-f in mail-mode,
;;; that gives you completion on the folder name, looking by default
;;; in your vm-folder-directory. It uses vm-auto-folder-alist to pick
;;; a default folder.
;;; From vm-summary.el
(defun vm-match-data ()
(let ((index '(9 8 7 6 5 4 3 2 1 0))
(list))
(while index
(setq list (cons (match-beginning (car index))
(cons (match-end (car index)) list))
index (cdr index)))
list))
(defun mail-fcc-auto-select-folder (auto-folder-alist)
(catch 'match
(let (header alist tuple-list)
(setq alist auto-folder-alist)
(while alist
(setq header (mail-get-header-contents (car (car alist))))
(if (null header)
()
(setq tuple-list (cdr (car alist)))
(while tuple-list
(if (let ((case-fold-search
(if (boundp 'vm-auto-folder-case-fold-search)
vm-auto-folder-case-fold-search
case-fold-search)))
(not (equal (mapcar (lambda (header)
(string-match (car (car tuple-list))
header))
header)
(make-list (length header) nil))))
;; Don't waste time eval'ing an atom.
(if (atom (cdr (car tuple-list)))
(throw 'match (cdr (car tuple-list)))
(let* ((match-data (vm-match-data))
(buf (get-buffer-create " *VM scratch*"))
(result))
;; Set up a buffer that matches our cached
;; match data.
(save-excursion
(set-buffer buf)
(widen)
(erase-buffer)
(apply 'insert header)
;; It appears that get-buffer-create clobbers the
;; match-data.
;;
;; The match data is off by one because we matched
;; a string and Emacs indexes strings from 0 and
;; buffers from 1.
;;
;; Also store-match-data only accepts MARKERS!!
;; AUGHGHGH!!
(store-match-data
(mapcar
(function (lambda (n) (and n (vm-marker n))))
(mapcar
(function (lambda (n) (and n (1+ n))))
match-data)))
(setq result (eval (cdr (car tuple-list))))
(throw 'match
(if (listp result)
(mail-fcc-auto-select-folder result)
result))))))
(setq tuple-list (cdr tuple-list))))
(setq alist (cdr alist)))
nil)))
(defvar mail-fcc-header "FCC"
"*Header inserted by \\[mail-fcc].")
(defun mail-fcc (folder)
"Add a new FCC field for FOLDER, with file name completion."
(interactive (list (let ((default (mail-fcc-auto-select-folder
vm-auto-folder-alist)))
(read-file-name
(if default
(format "Folder carbon copy (default %s): "
default)
"Folder carbon copy: ")
vm-folder-directory
(and default
(expand-file-name default
vm-folder-directory))))))
(expand-abbrev)
(save-excursion
(or (mail-position-on-field "fcc" t) ;Put new field after exiting FCC.
(mail-position-on-field "to"))
(insert "\n" mail-fcc-header ": " folder)))
(define-key mail-mode-map "\C-c\C-f\C-f" 'mail-fcc)
(provide 'vm-fcc)
