Profile Utilities
- See also:
- Visual Lisp and Profiles
Just a few Sample Profile Utilities.
Compliments of Autodesk :
;;; 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)