;;; DESCRIPTION:
;;; Sample profile manipulation utilities.
;;; All functions return T on success and nil
;;; on failure. See comments above each function
;;; for additional details.
;;;
;;; EXAMPLES:
;;;
;;; - Set active profile:
;;; (sample-profile-set-active "MyProfile")
;;;
;;; - Import a profile:
;;; (sample-profile-import
;;; "c:\\myExportedProfile.arg" "MyFavoriteProfile" T)
;;;
;;; - Delete a profile:
;;; (sample-profile-delete "unwanted")
;;;
;;;
;;; - Import a profile, even if it already exists, and set it active.
;;;
;;; (sample-profile-import "c:\\CompanyProfile.arg" "MyProfile" T)
;;; (sample-profile-set-active "MyProfile")
;;;
;;;
;;; - Import a profile, if not already present, and set it active
;;;
;;; (if (not (sample-profile-exists "myProfile"))
;;; (progn
;;; (sample-profile-import "c:\\CompanyProfile.arg" "MyProfile" T)
;;; (sample-profile-set-active "MyProfile")
;;; )
;;; )
;;;
;;;
;;; - Import a profile and set it active when AutoCAD is first started.
;;; Place the following code in acaddoc.lsp with the desired ".arg" filename
;;; and profile name...
;;;
;;; (defun s::startup ()
;;; (if (not (vl-bb-ref ':sample-imported-profile))
;;; ;;have we imported the profile yet?
;;; (progn
;;;
;;; ;; Set a variable on the bulletin-board
;;; ;; to indicate that we've been here before.
;;; (vl-bb-set ':sample-imported-profile T)
;;;
;;; ;; Import the profile and set it active
;;; (sample-profile-import
;;; "c:\\CompanyProfile.arg" "MyProfile" T)
;;; (sample-profile-set-active "MyProfile")
;;;
;;; );progn then
;;; );if
;;; );defun s::startup
;;;
;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; This helper function gets the profiles object.
;;
(defun sample-get-profiles-object ( / app pref profs )
(vl-load-com)
(and
(setq app (vlax-get-acad-object))
(setq pref (vla-get-preferences app))
(setq profs (vla-get-profiles pref))
)
profs
);defun sample-get-profiles-object
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; Determine if a profile exists.
;; Returns T if the specified profile name exists, and nil if not.
;;
(defun sample-profile-exists ( name / profs )
(and name
(setq names (sample-profile-names))
(member (strcase name) (mapcar 'strcase names))
)
);defun sample-profile-exists
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; Set the active profile.
;; NOTES:
;; - If the specified profile name is already active
;; then the function returns T and makes no additional
;; changes.
;;
;; - The specified profile must exist.
;; (You can import a profile using the 'sample-profile-import'
;; function.) If the specified profile does not exist, the
;; function returns nil.
;;
(defun sample-profile-set-Active ( name / profs )
(and
name
(setq profs (sample-get-profiles-object))
(or (equal (strcase name) (strcase (getvar "cprofile")))
(not (vl-catch-all-error-p (vl-catch-all-apply
'vla-put-activeProfile (list profs name))))
)
);and
);defun sample-profile-set-Active
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; Delete the specified profile.
;; Fails if the specified profile is current.
;;
(defun sample-profile-delete ( name / profs )
(and
name
(setq profs (sample-get-profiles-object))
(not (vl-catch-all-error-p (vl-catch-all-apply
'vla-deleteprofile (list profs name))))
)
);defun sample-profile-delete
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; Copy profile.
;;
(defun acad-pref-profile-copy ( source target / profs )
(and
source
target
(setq profs (sample-get-profiles-object))
(not (vl-catch-all-error-p (vl-catch-all-apply
'vla-CopyProfile (list profs source target))))
)
);defun sample-profile-copy
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; Get a list of profile names
;;
(defun sample-profile-names ( / profs result )
(and
(setq profs (sample-get-profiles-object))
(not (vl-catch-all-error-p (vl-catch-all-apply
'vla-GetAllProfileNames (list profs 'result))))
result
(setq result (vlax-safearray->list result))
)
result
);defun sample-profile-names
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; Rename
;;
(defun sample-profile-rename ( oldName newName / profs )
(and
oldName
newName
(setq profs (sample-get-profiles-object))
(not (vl-catch-all-error-p (vl-catch-all-apply
'vla-RenameProfile (list profs oldName newName))))
)
);defun sample-profile-rename
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; Get a unique profile name.
;; This function returns a unique profile name
;; that is guaranteed to not be present in the current
;; list of profiles.
;;
(defun sample-get-unique-profile-name ( / names n name )
(setq names (sample-profile-names)
names (mapcar 'strcase names)
name "TempProfileName"
n 1
)
(while (member (strcase (setq name (strcat name (itoa n)))) names)
(setq n (+ n 1))
)
name
);defun sample-get-unique-profile-name
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; Import
;; This function imports the specified .arg file and creates
;; a new profile with the provided profile name.
;; If the specified profile already exists, it will be overwritten.
;; If the 'bUsePathInfo' parameter is non-nil then path information
;; will be imported from the specified
;; file. Otherwise, path information will be ignored.
;;
;; NOTES:
;; This function does not set the active profile.
;; If you import a new profile it will not become active
;; unless it matches the name of the existing active profile.
;;
;; You can set the active profile by calling:
;; (sample-profile-set-active "ProfileName")
;;
(defun sample-profile-import ( filename profileName bUsePathInfo /
sample-old Error profs isCProfile
tempProfile result )
;; Set up an error handler so, if something goes wrong,
;;we can put things back the way we found them
(setq sample-oldError *error*)
(defun *error* ( msg / )
(if (and profileName
tempProfile
(equal tempProfile (getvar "cprofile"))
)
(progn
;; Something went wrong so put things back the way they were.
(sample-profile-rename tempProfile profileName)
(sample-profile-set-active profileName)
(sample-profile-delete tempProfile)
);progn then
);if
(setq *error* sample-oldError)
(if msg
(*error* msg)
(princ)
)
);defun *error*
(if (and bUsePathInfo
(not (equal :vlax-false bUsePathInfo))
)
(setq bUsePathInfo :vlax-true)
(setq bUsePathInfo :vlax-false)
)
(if (and filename
(setq filename (findfile filename))
profileName
(setq profs (sample-get-profiles-object))
);and
(progn
;; We can't import directly to the current profile,
;; so if the provided profile name matches
;; the current profile, we'll need to:
;; - rename the current profile to a unique name
;; - import
;; - set the new one current
;; - delete the old one with the temp name
(setq isCProfile (equal (strcase (getvar "cprofile"))
(strcase profileName)))
(if isCProfile
(progn
(setq tempProfile (sample-get-unique-profile-name))
(sample-profile-rename (getvar "cprofile") tempProfile)
);progn then
);if
;; Import
(setq result (not (vl-catch-all-error-p (vl-catch-all-apply
'vla-ImportProfile (list profs profileName
filename bUsePathInfo)))))
(if isCProfile
(progn
;; Handle current profile case...
;; If the import was successful,
;;then set the new profile active and delete the original
;; else if something went wrong, then put the old profile back
(if (and result
(setq result (sample-profile-set-Active profileName))
;; set the newly imported profile active
);and
(sample-profile-delete tempProfile)
;; then delete the old profile
(sample-profile-rename tempProfile profileName)
;; else rename the original profile back to its old name
);if
);progn then
);if
);progn then
);if
(*error* nil) ;; quietly restore the original error handler
result
);defun sample-profile-import
(princ)
|
