DesignCenter Datei-Erweiterungs-Enabler (Autodesk/Lisp)

Hi,
wie schon im RuA- Forum angekündigt, hier das vorläufige Tool
zum aktivieren/deaktivieren von Dateierweiterungen die eigentlich DWG's sind, standardmäßig aber vom DesignCenter nicht angezeigt werden.
Wünsche, Fragen, Anregungen bitte hier posten.

Code:

(vl-load-com)
(defun C:ADC+ (/ ERASEFLAG EXTENSION)
(if (not (REG:TESTWRITE))
(alert
(strcat
"Sorry, Sie haben keine Schreib-Rechte auf die Windows-Registrierung."
"\nKontaktieren Sie Ihren CAD-Admin oder loggen Sie sich als User"
"\nmit entsprechenden Rechten auf der lokalen Maschine ein."
) ;_ end of strcat
) ;_ end of alert
(progn
(initget 1 "dwT dwS Alle-genannten")
(setq EXTENSION
(getkword
"DateiTyp-Unterstützung für DesignCenter manipulieren, Erweiterung wählen [dwT/dwS/Alle-genannten]: "
) ;_ end of getkword
) ;_ end of setq
(if EXTENSION
(progn
(initget "Aktivieren Deaktivieren")
(setq ERASEFLAG
(getkword
(strcat
"\nDesignCenter-Unterstützung für "
(strcase EXTENSION)
" Dateityp(en) [Aktivieren/Deaktivieren]<Aktivieren>? "
) ;_ end of strcat
) ;_ end of getkword
) ;_ end of setq
(if (or (not ERASEFLAG) (= ERASEFLAG "Aktivieren"))
(setq ERASEFLAG NIL)
(setq ERASEFLAG t)
) ;_ end of if
(if (= EXTENSION "Alle-genannten")
(mapcar
(function (lambda (X) (MS:DC-SWITCH-EXTENSION ERASEFLAG X))
) ;_ end of function
'("dwt" "dws")
) ;_ end of mapcar
(MS:DC-SWITCH-EXTENSION ERASEFLAG EXTENSION)
) ;_ end of if
(if ERASEFLAG
(princ (strcat "\nOK, DesignCenter-Unterstützung für "
(strcase EXTENSION)
" Dateityp(en) DEAKTIVIERT."
) ;_ end of strcat
) ;_ end of princ
(princ (strcat "\nOK, DesignCenter-Unterstützung für "
(strcase EXTENSION)
" Dateityp(en) AKTIVIERT."
) ;_ end of strcat
) ;_ end of princ
) ;_ end of if
(princ "\nÄnderungen werden erst nach einem Neustart von AutoCAD übernommen.")
) ;_ end of progn
) ;_ end of if
) ;_ end of progn
) ;_ end of if
(princ)
) ;_ end of defun

;;; erzeugt oder löscht den DCenter-Wert für die übergebene Extension.
;;; Argumente:
;;; ERASEFLAG = nil oder T, wenn T wird die extension gelöscht, wenn nil erzeugt
;;; EXTENSION = Zeichenkette, definiert die zu berücksichtigende Dateierweiterung
;;; Prüfung auf Länge und "dw" Anfang
;;;
;;; Funktion legt in jedem Fall eine Backup-Extension der "dwg" als "..." an.
(defun MS:DC-SWITCH-EXTENSION (ERASEFLAG EXTENSION
/ ADCBACKUPKEY
ADCDWGKEY ADCEXTKEY
ADCKEY ADCTARGETKEY
CHANGED-EXT WRITE-BACKUP
)
(setq EXTENSION (strcase EXTENSION t))
(if (and (= (strlen EXTENSION) 3) (wcmatch EXTENSION "dw?"))
(progn
(if (setq ADCKEY (REG:ACADDCKEY))
(progn
(setq ADCEXTKEY (strcat ADCKEY "\\" "Extensions")
ADCTARGETKEY (strcat ADCEXTKEY "\\." EXTENSION)
ADCBACKUPKEY (strcat ADCEXTKEY "\\.zzz")
ADCDWGKEY (strcat ADCEXTKEY "\\.dwg")
) ;_ end of setq
;; Cleanup Backup-Pfad
(if (member ".zzz" (vl-registry-descendents ADCEXTKEY)) ;_ existiert der Backup-Eintrag schon?
(if
(not (REG:TEST-LAYOUT-CLSID ADCBACKUPKEY)) ;_ existiert, aber keine Daten gesichert...
(setq WRITE-BACKUP t) ;_ erzeuge Backup
(setq WRITE-BACKUP NIL) ;_ Backup existiert schon
) ;_ end of if
(setq WRITE-BACKUP t) ;_ erzeuge Backup
) ;_ end of if
(if WRITE-BACKUP
(progn
(setq CHANGED-EXT
(REG:->KEY-LST-STRING-SUBST
"zzz"
"dwg"
(REG:->KEY-VALUE-LST ADCDWGKEY)
) ;_ end of REG:->KEY-LST-STRING-SUBST
) ;_ end of setq
(REG:WRITE-KEY-VALUE-LST CHANGED-EXT)
) ;_ end of progn
) ;_ end of if
(if ERASEFLAG
(if (REG:TEST-LAYOUT-CLSID ADCTARGETKEY)
(REG:DELETE-KEY-VALUE-LST
(REG:->KEY-VALUE-LST ADCTARGETKEY)
) ;_ end of REG:DELETE-KEY-VALUE-LST
) ;_ end of if
(REG:WRITE-KEY-VALUE-LST
(REG:->KEY-LST-STRING-SUBST
EXTENSION
"zzz"
(REG:->KEY-VALUE-LST ADCBACKUPKEY)
) ;_ end of REG:->KEY-LST-STRING-SUBST
) ;_ end of REG:WRITE-KEY-VALUE-LST
) ;_ end of if
) ;_ end of progn
) ;_ end of if
) ;_ end of progn
) ;_ end of if
) ;_ end of defun
;;; Gibt den Namen "HKEY_LOCAL_MACHINE" zurück
(defun REG:WINBASEKEY (/)
"HKEY_LOCAL_MACHINE"
) ;_ end of defun
;;; Gibt den Namen "HKEY_LOCAL_MACHINE\\SOFTWARE" zurück
(defun REG:WINSOFTWAREKEY (/)
(strcat (REG:WINBASEKEY) "\\" "SOFTWARE")
) ;_ end of defun
;;; Liest den DesignCenter Key für die aktuell laufende AutoCAD-VErsion aus
(defun REG:ACADDCKEY (/ DCKEY retval)
(setq DCKEY "AutodeskApps\\AcadDC" ;_ Teilschlüssel zum ADC Eintrag von R2000 bis R2004 identisch
RETVAL (strcat (REG:WINBASEKEY) "\\" (vlax-product-key) "\\" DCKEY)
) ;_ end of setq
(if (not (vl-registry-descendents RETVAL))
(setq RETVAL NIL)
) ;_ end of if
retval
) ;_ end of defun
;;; Liest einen Registry-Tree ab dem übergebenen Key
;;; und erzeugt daraus eine entsprechende, hierarchische Liste:
;;; Format:
;;; ("KEYNAME" [((VALUENAME . VALUEDATA)(VALUENAME . VALUEDATA)...) oder nil] [SUBKEY-LIST oder nil])
;;; Format der SUBKEY-LIST: Liste von Listen, die genauso wie die Hauptliste aufgebaut sind.
;;; Verschachtelung entsprechend des Registry-Trees.
;;; Z.B.:
;;; ("HKEY_LOCAL_MACHINE\\Software\\Autodesk\\...\\.dwg"
;;; (("Container" . 1)
;;; ("Default_IconIndex" . 2)
;;; ("Default_Clsid" . "{C8F4366D-BAC6-4463-9F42-C2627D8E86FB}")
;;; )
;;; (("HKEY_LOCAL_MACHINE\\Software\\Autodesk\\...\\.dwg\\Blocks" (("LocalName" . "Blöcke")...) nil)
;;; ("HKEY_LOCAL_MACHINE\\Software\\Autodesk\\...\\.dwg\\Dimstyles" (("LocalName" . "Bemstile")... ) nil)
;;; ("HKEY_LOCAL_MACHINE\\Software\\Autodesk\\...\\.dwg\\Layers" (("LocalName" . "Layer")...) nil)
;;; (...)
;;; )
;;; )
(defun REG:->KEY-VALUE-LST (KEY / RETVAL SUBKEYNAMES VNAMES)
;; Value-Handling für Key
(if (setq VNAMES (reverse (vl-registry-descendents KEY t))) ;_ hat der Key values?
(setq
VNAMES (mapcar (function (lambda (X)
(cons X (vl-registry-read KEY X))
) ;_ end of lambda
) ;_ end of function
VNAMES
) ;_ end of mapcar
) ;_ end of setq
) ;_ end of if
(setq RETVAL (list KEY VNAMES))
(if (setq SUBKEYNAMES (reverse (vl-registry-descendents KEY)))
(setq SUBKEYNAMES
(mapcar
(function (lambda (X)
(REG:->KEY-VALUE-LST (strcat KEY "\\" X))
) ;_ end of lambda
) ;_ end of function
SUBKEYNAMES
) ;_ end of mapcar
) ;_ end of setq
) ;_ end of if
(append RETVAL (list SUBKEYNAMES))
) ;_ end of defun
;;; tauscht einen String in allen Keys der Registry-Tree-Liste
(defun REG:->KEY-LST-STRING-SUBST
(NEW PATTERN KEYLST / ELEM-NEU KEY SUB-KEY-LST SUB-KEY-LST-NEW)
(setq KEY (car KEYLST)
KEYLST (subst (vl-string-subst NEW PATTERN KEY) KEY KEYLST)
) ;_ end of setq
(if (setq SUB-KEY-LST (nth 2 KEYLST))
(foreach ELEM SUB-KEY-LST
(setq SUB-KEY-LST-NEW
(cons
(REG:->KEY-LST-STRING-SUBST NEW PATTERN ELEM)
SUB-KEY-LST-NEW
) ;_ end of cons
) ;_ end of setq
) ;_ end of foreach
) ;_ end of if
(setq KEYLST (list (nth 0 KEYLST)
(nth 1 KEYLST)
(reverse SUB-KEY-LST-NEW)
) ;_ end of list
) ;_ end of setq
) ;_ end of defun
;;; Erzeugt alle Registrierungseinträge die in der übergebenen Registry-Tree-Liste
;;; enthalten sind.
(defun REG:WRITE-KEY-VALUE-LST (LST / KEY SUB-LST VAL-LST)
(if (setq KEY (car LST))
(if (vl-registry-write KEY)
(progn
(if (setq VAL-LST (nth 1 LST))
(foreach ELEM VAL-LST
(vl-registry-write KEY (car ELEM) (cdr ELEM))
) ;_ end of foreach
) ;_ end of if
(if (setq SUB-LST (nth 2 LST))
(foreach ELEM SUB-LST
(REG:WRITE-KEY-VALUE-LST ELEM)
) ;_ end of foreach
) ;_ end of if
) ;_ end of progn
) ;_ end of if
) ;_ end of if
) ;_ end of defun
;;; Löscht alle Registrierungseinträge die in der übergebenen Registry-Tree-Liste
;;; enthalten sind.
(defun REG:DELETE-KEY-VALUE-LST (LST / SUB-KEYS)
(while (not (vl-registry-delete (car LST)))
(if (setq SUB-KEYS (nth 2 LST))
(foreach ELEM SUB-KEYS
(REG:DELETE-KEY-VALUE-LST ELEM)
) ;_ end of foreach
) ;_ end of if
) ;_ end of while
) ;_ end of defun
;;; Testfunktion: Kann der User in die Registrierung schreiben?
(defun REG:TESTWRITE (/ RETVAL TESTKEY)
(setq TESTKEY (strcat (REG:WINSOFTWAREKEY) "\\" "VLWRITETEST")
RETVAL (vl-registry-write TESTKEY)
) ;_ end of setq
(if RETVAL
(vl-registry-delete TESTKEY)
) ;_ end of if
RETVAL
) ;_ end of defun
;;; Testet für einen übergebenen Key, ob es für den SubKey "Layouts",
;;; Wertname "CLSID" einen Wert gibt.
(defun REG:TEST-LAYOUT-CLSID (key /)
(vl-registry-read (strcat key "\\Layouts") "CLSID")
) ;_ end of defun

;;; Liest die Keys für den übergebenen Schlüssel in "HKEY_LOCAL_MACHINE\\SOFTWARE"
;;; aus. z.B.: (REG:FIND-SW-KEYS "Autodesk")
(defun REG:FIND-SW-KEYS (SWKEY / RETVAL)
(setq RETVAL (REG:WINSOFTWAREKEY)
SWKEY (strcase SWKEY)
) ;_ end of setq
(if (member SWKEY (mapcar 'strcase (vl-registry-descendents RETVAL)))
(setq RETVAL (vl-registry-descendents (strcat RETVAL "\\" SWKEY)))
(setq RETVAL NIL)
) ;_ end of if
(reverse RETVAL)
) ;_ end of defun

------------------
Ciao,
Marc

[Diese Nachricht wurde von marc.scherer am 01. Mrz. 2004 editiert.]

Eine Antwort auf diesen Beitrag verfassen (mit Zitat/Zitat des Beitrags) IP

Qscape CAD APP für Landschaft, Landschaftsarchitektur