;;--------------------------------------------------------------------------*
;;Qualle: http://www.cocreateusers.org/forum/showthread.php?t=8160
;;--------------------------------------------------------------------------*

(in-package :custom)
(use-package :OLI)
;;--------------------------------------------------------------------------*
(sd-defdialog 'Rename_shared_parts
:dialog-title "Change names of Parts/Assemblies"
:toolbox-button t
;;:dialog-control :sequential
:variables
'(
(alle
:initial-value t)
(csids)
(wahl
:selection
(*sd-object-seltype*)
:multiple-items t
:prompt-text "Select Part or Assembly to Rename"
:title "Select Part/Assy"
:initial-value nil
)
(cust :value-type :string
:title "New Name:"
:toggle-type :indicator-toggle-data
:initial-value nil
)
(ol :value-type :boolean
:toggle-type :wide-toggle
:title "One level"
:initial-value nil
)
)
:mutual-exclusion '((cust))
:local-functions
'(
(after-nur-action ()
(let (kind csid)
(dolist (kind nur)
(setf csid (sd-inq-obj-contents-sysid kind))
(push csid csids)
);;dolist
)
)
(next-action ()
(let ()
(dolist (kind wahl)
(dc4-mminfo-to-basename-in-bgr kind alle     cust csids ol)
);;dolist
)
)
)
:ok-action
'(sd-call-cmds (next-action))
)
(defun dc4-mminfo-to-basename-in-bgr (teil_bgr alle     cust csids ol)
(let (basename owner pathname mminfo basename newpath kind kinder csid)
(setf basename (sd-inq-obj-basename teil_bgr))
(setf csid (sd-inq-obj-contents-sysid teil_bgr))
(when (or (sd-inq-part-p teil_bgr)
(sd-inq-assembly-p teil_bgr)
(sd-inq-container-p teil_bgr)
)
(progn
(setf pathname (sd-inq-obj-pathname teil_bgr))
(when (sd-string/= pathname "/")
(progn
(cond
(
(setf mminfo (sd-inq-obj-contents-name teil_bgr))
)
(
(setf mminfo (dc4-desman-get-codice teil_bgr))
)
(
(setf mminfo (dc4-desman-get-benennung-info teil_bgr))
)
(
(setf mminfo (dc4-desman-get-codice-descrizione teil_bgr))
)
(cust
(setf mminfo cust)
)
(t
(setf mminfo (sd-inq-obj-contents-name teil_bgr))
)
);;if
(setf owner (sd-inq-parent-obj teil_bgr))
(when (not owner)
(setf owner (sd-pathname-to-obj "/"))
);;when
(when mminfo
(progn
(setf newname (dc4-gen-part-basename owner teil_bgr mminfo))
(when (or (and (sd-inq-part-p teil_bgr) (sd-string-match-pattern-p "[tT][0-9]*" basename))
(and (sd-inq-assembly-p teil_bgr) (sd-string-match-pattern-p "[bB][0-9]*" basename))
(and (sd-inq-container-p teil_bgr) (sd-string-match-pattern-p "[bB][hH][0-9]*" basename))
alle
)
(if csids
(progn
(when (member csid csids :test #'equal)
(progn
(if (not (sd-inq-obj-parent-contents-read-only-p teil_bgr))
(sd-call-cmds (CHANGE_NAME_PA :PART_ASMB pathname :NAME newname))
;; (display (format nil "~a La Parte/Gruppo non puo' essere rinominata" pathname))
);;if
);;progn
);;when
);;progn
(progn
(if (not (sd-inq-obj-parent-contents-read-only-p teil_bgr))
(sd-call-cmds (CHANGE_NAME_PA :PART_ASMB pathname :NAME newname))
;; (display (format nil "~a La Parte/Gruppo non puo' essere rinominata" pathname))
);;if
);;progn
);;if
);;when
);;progn
);;when
);;progn
);;when
(when (not ol)
(progn
(setf kinder (sd-inq-obj-children teil_bgr))
(dolist (kind kinder)
(dc4-mminfo-to-basename-in-bgr kind alle   cust csids ol)
) ;; dolist
);;progn
);;when
);;progn
);;when
) ;; let
)
(defun dc4-gen-part-basename (owner teil_bgr prefix)
(let (baslist chlist ch teiletyp bas index name)
(setf baslist (list))
(setf chlist (sd-inq-obj-children owner))
(dolist (ch chlist)
(when (or (sd-inq-part-p ch) (sd-inq-assembly-p ch) (sd-inq-container-p ch))
(progn
(when (not (equal ch teil_bgr))
(progn
(setf bas (sd-inq-obj-basename ch))
(setf baslist (nconc baslist (list bas)))
);;progn
);;when
);;progn
);;when
);;dolist
(setf index 0)
(loop
(setf index (+ index 1))
;(if (= digt 1) ;DC trying to implement digit choice
;(setf name (format nil "~a_~10,1,'0,'0r" prefix index)) ;DC trying to implement digit choice
(setf name (format nil "~a.~10,2,'0,'0r" prefix index))
;);;if
(if (not (member name baslist :test #'equal)) (return t))
);;loop
(values name)
);;let
)
(defun dc4-desman-get-benennung-info (teil)
(let (attributliste attribut inf)
(setf attributliste (sd-inq-item-attributes teil :attachment :contents))
(setf inf nil)
(dolist (attribut attributliste)
(progn
(when (string= attribut "DB-PREF")
(progn
(setq inf (sd-inq-item-attribute teil attribut :DESCRIZIONE :attachment :contents))
(setf inf (sd-string-replace inf " " "."))
(setf inf (sd-string-replace inf "=" "."))
(setf inf (sd-string-replace inf "," "."))
(setf inf (sd-string-replace inf "X" "x")) 
(setf inf (sd-string-replace inf "._" "."))
);;progn
);;when
);;progn
);;dolist
(when (typep inf 'STRING)
(when (= (length inf) 0) (setf inf nil))
);;when
(values inf)
);;let
)
(defun dc4-desman-get-codice (teil)
(let (attributliste attribut inf)
(setf attributliste (sd-inq-item-attributes teil :attachment :contents))
(setf inf nil)
(dolist (attribut attributliste)
(progn
(when (string= attribut "DB-PREF")
(progn
(setq inf (sd-inq-item-attribute teil attribut :CODICE :attachment :contents))
);;progn
);;when
);;progn
);;dolist
(when (typep inf 'STRING)
(when (= (length inf) 0) (setf inf nil))
);;when
(values inf)
);;let
)
(defun dc4-desman-get-codice-descrizione (teil)
(let (attributliste attribut inf)
(setf attributliste (sd-inq-item-attributes teil :attachment :contents))
(setf inf nil)
(setf infcodice nil)
(dolist (attribut attributliste)
(progn
(when (string= attribut "DB-PREF")
(progn
(setq infcodice (sd-inq-item-attribute teil attribut :CODICE :attachment :contents))
(setq inf (sd-inq-item-attribute teil attribut : DESCRIZIONE :attachment :contents))
(setf inf (sd-string-replace inf " " "."))
(setf inf (sd-string-replace inf "=" "."))
(setf inf (sd-string-replace inf "," "."))
(setf inf (sd-string-replace inf "X" "x")) 
(setf inf (sd-string-replace inf "._" "."))
(setf inf (format nil "~a_~a" infcodice inf ))
);;progn
);;when
);;progn
);;dolist
(when (typep inf 'STRING)
(when (= (length inf) 0) (setf inf nil))
);;when
(values inf)
);;let
)