几个函数

st788796 · 发表于 2013-7-18 20:40:34

马上注册，结交更多好友，享用更多功能，让你轻松玩转社区。

您需要登录才可以下载或查看，没有账号？立即注册

×

(defun jk:ACX_ActDoc ()
(if
(not *jk-ActDoc)
(setq *jk-ActDoc (vla-get-activedocument (vlax-get-acad-object)))
*jk-ActDoc
)
)
(defun jk:ACX_GetModel ()
(if
(not *jk-Model)
(setq *jk-Model (vla-get-modelspace (jk:ACX_ActDoc)))
*jk-Model
)
)
(defun jk:ACX_GetActiveSpace ()
(if
(= 1 (getvar "TILEMODE"))
(jk:ACX_GetModel)
(if
(= 2 (getvar "CVPORT"))
(jk:ACX_GetModel)
(vla-item (jk:ACX_GetBlocks) "*Paper_Space")
)
)
)
(defun jk:ACX_GetBlocks ()
(if
(not *jk-Blocks)
(setq *jk-Blocks (vla-get-Blocks (jk:ACX_ActDoc)))
*jk-Blocks
)
)
(defun jk:ACX_ChangeObj (Obj Lay Col LTp LTs LTw)
(setq Obj (jk:CON_VlaObject Obj))
(if
(vlax-write-enabled-p Obj)
(progn
(if
(and Lay (= (type Lay) 'STR))
(if
(not (jk:TBL_LayIsLocked Lay))
(vla-put-layer Obj Lay)
)
)
(if
(and Col (= (type Col) 'INT))
(if
(and (>= Col 0)(<= Col 256))
(vla-put-color Obj Col)
)
)
(if
(and LTp (= (type LTp) 'STR))
(if
(jk:TBL_isLtp LTp)
(vla-put-linetype Obj LTp)
)
)
(if
(and LTs (numberp LTs))
(if
(< LTs 0.0)
(vla-put-LinetypeScale Obj LTs)
)
)
(if
(and LTw (numberp LTw))
(vla-put-lineweight Obj LTw)
)
)
)
)
(defun jk:ACX_MakeMline
(Space Name plst Width Closed Lay
Col Ltp Lts Ltw / ary
Obj Mst Mw
)
(setq plst (mapcar '(lambda (&) (list (car &) (cadr &) (caddr &)))
plst
)
Mst (getvar "CMLSTYLE")
)
(setvar "CMLSTYLE" Name)
(setq plst (apply 'append plst)
ary (vlax-make-safearray
vlax-vbdouble
(cons 1 (length plst))
)
Obj (vla-addmline
Space
(vlax-make-variant
(vlax-safearray-fill ary plst)
)
)
)
(jk:ACX_ChangeObj Obj Lay Col LTp LTs LTw)
(setvar "CMLSTYLE" Mst)
(if Closed
(progn
(setq Mw (entget (jk:CON_Ename Obj)))
(entmod
(subst (cons 71 (+ 2 (cdr (assoc 71 Mw)))) (assoc 71 Mw) Mw)
)
)
)
(setq Mw (entget (jk:CON_Ename Obj)))
(if (numberp Width)
(entmod (subst (cons 40 Width) (assoc 40 Mw) Mw))
)
(vla-put-Coordinates Obj ary)
Obj
)
(defun jk:ENT_isLocked (e m)
(if
(= 4
(logand
4
(jk:DXF 70 (tblsearch "LAYER" (jk:DXF 8 (entget e))))
)
)
(progn
(if m (princ "\nObiekt na zamkni?tej warstwie. "))
T
)
nil
)
)
(defun jk:CON_VlaObject (In)
(cond
((= (type In) 'VLA-OBJECT) In)
((= (type In) 'ENAME)(vlax-ename->vla-object In))
(T Nil)
)
)
(defun jk:CON_Ename (In)
(cond
((= (type In) 'VLA-OBJECT)(vlax-vla-object->ename In))
((= (type In) 'ENAME) In)
(T Nil)
)
)
;; by kojacek
;; Funkcja zwraca list? ?ańcuchów tekstowych dziel?c argument STR na
;; pod?ańcuchy. Separatorem ?ańcucha jest znak ",". UWAGA! - argument
;; [STR] nie mo?e by? ?ańcuchem w którym wyst?puj? separatory jeden
;; za drugim.
(defun jk:CON_Str->List (Str / inc tmp res)
(setq inc 0)
(while
(/= tmp "")
(setq tmp
(menucmd
(strcat "M=$(index," (itoa inc) ",\"" Str "\")")
)
inc (1+ inc)
)
(setq res (append (list tmp) res))
)
(reverse (cdr res))
)
;; by kojacek
;; Zwraca liste ?ańcuchów tekstowych reprezentuj?cych aktualn?
;; dat? o formacie: MM-rzym Miesi?c DD MM YYYY DzieńTygodnia
;; Wymaga funkcji jk:CON_Str->List
(defun jk:SYS_TodayList (/ Date Mont)
(setq Date
(jk:CON_Str->List
(menucmd
(strcat
"M=$(edtime,$(getvar,date),MONTH"
"\",\"MO\",\"DD\",\"YYYY\",\"DDDD)"
)
)
)
)
(setq Mont
(menucmd
(strcat "M=$(index,"
(itoa (1- (read (nth 1 Date))))
",\"I,II,III,IV,V,VI,VII,VIII,IX,X,XI,XII\")"
)
)
)
(cons Mont Date)
)
;; by kojacek
;; Awraca liste ?ańcuchów tekstowych reprezentuj?cych aktualny czas:
;; Wymaga funkcji jk:CON_Str->List
;; Zwraca list? formatu: ("HH" "MM" "SS" "MSEC")
(defun jk:SYS_CurTime ()
(jk:CON_Str->List
(menucmd
"M=$(edtime,$(getvar,date),HH\",\"MM\",\"SS\",\"MSEC)"
)
)
)
(defun jk:CON_GetvarAsStr (Var)
(menucmd
(strcat
"M=$(getvar,\"" Var "\")"
)
)
)
(defun jk:DXF (Code Lst)
(cdr (assoc Code Lst))
)
(defun jk:DXF_MakeDxfList (CodeLst DataLst / Tmp inc)
(setq Inc -1)
(if
(/= (length CodeLst)(length DataLst))
Nil
(mapcar
'(lambda (%)
(setq inc (1+ Inc))
(if
(listp (setq Tmp (nth Inc DataLst)))
(append (list %) Tmp)
(cons % Tmp)
)
)
CodeLst
)
)
)
;|
Przyk?ad:
(jk:DXF_MakeDxfList '(0 2 10)'("INSERT" "NAZWA" (0.0 0.0 0.0)))
zwraca:
((0 . "INSERT")(2 . "NAZWA")(10 0.0 0.0 0.0))
oraz:
(jk:DXF_MakeDxfList '(0 2 10)'("INSERT" "NAZWA"))
zwraca:
nil |;
(defun jk:DXF_mAssoc (key alist / x nlist)
(foreach % alist
(if (eq key (car %))
(setq nlist (cons (cdr %) nlist))
)
)
(reverse nlist)
)
(defun jk:CAL_Sequence (start lengt step / Tmp TmpList)
(if
(and (numberp start)(numberp lengt)(numberp step))
(progn
(setq Tmp Start)
(while
(< (length TmpList) (1- Lengt))
(setq Tmp (+ Tmp Step))
(setq TmpList (append (list Tmp) TmpList))
)
(cons Start (reverse TmpList))
)
Nil
)
)
(defun jk:TBL_isLay (Name)
(tblobjname "LAYER" (strcase Name))
)
(defun jk:TBL_isLTp (Name)
(tblobjname "LTYPE" (strcase Name))
)
(defun jk:TBL_LayIsLocked (Name)
(if
(jk:TBL_isLay Name)
(= 4 (logand 4 (cdr (assoc 70
(tblsearch "LAYER" (strcase Name))
)))
)
0
)
)
(defun jk:SYS_UndoBegin ()
(vla-StartUndoMark (jk:ACX_ActDoc))
)
;; =====================================
(defun jk:SYS_UndoEnd ()
(vla-EndUndoMark (jk:ACX_ActDoc))
)
;;; by kojacek
;;;
(defun jk:SYS_GetCpu ()
(apply 'strcat
(mapcar
'(lambda (%)
(if
(numberp %)
(strcat "(" (itoa %) " MHz)")
(strcat % ", ")
)
)
(mapcar
'(lambda (%)
(vl-registry-read
(strcat "HKEY_LOCAL_MACHINE\\Hardware\\"
"Description\\System\\CentralProcessor\\0"
)
%
)
)
'("Identifier" "ProcessorNameString" "~MHz")
)
)
)
)
;; ------------------------------------------ by kojacek 2002 -;
;; Tworzy katalog. Zwraca T lub Nil (gdy niepowodzenie) ;
;; ;
(defun jk:SYS_MkDir (Pth / Lst)
(if
(setq Lst (cdr (jk:SYS_PathList Pth)))
(foreach % Lst
(if (not (vl-file-directory-p %))(vl-mkdir %))
)
)
)
;; ------------------------------------------ by kojacek 2002 -;
;; Zwraca liste kolejnych sciezek dostepu katalogu ;
;; ;
(defun jk:SYS_PathList (Pth / tmp x Res)
(if
(setq tmp (jk:STR_parse Pth "\\"))
(while Tmp
(setq x (apply
'strcat
(append
(reverse
(mapcar
'(lambda (%)(strcat % "\\"))
(cdr (reverse Tmp))
)
)
(list (last tmp))
)
)
Tmp (reverse (cdr (reverse Tmp)))
Res (append (list x) Res)
)
)
)
Res
)
(defun jk:STR_parse (str chs / len c l s chsl cnt )
(setq chsl (jk:STR_MakeList chs))
(setq len (strlen str) s "" cnt (1+ len))
(while (> (setq cnt (1- cnt)) 0)
(setq c (substr str cnt 1))
(if (member c chsl)
(if (/= cnt len)
(setq l (cons s l) s "")
)
(setq s (strcat c s))
)
)
(cons s l)
)
;;; by kojacek
;;; Zmienia warto?ci zmiennych z listy podanej jako argument [l]
;;;
(defun jk:SYS_SetVars (l / e)
(if
(listp l)
(while l
(if
(setq e
(vl-catch-all-error-p
(vl-catch-all-apply
'setvar
(list (car l)(cadr l))
)
)
)
Nil
(setvar (car l)(cadr l))
)
(setq l (cddr l))
)
(setq e T)
)
e
)
;;; by kojacek
;;; Funkcja zapamietuj?ca warto?ci zmiennych
;;;
(defun jk:SYS_ModeS (l)
(if
(listp l)
(if
(setq l (vl-remove-if-not 'getvar l))
(if
(not *jk-Var)
(setq *jk-Var (mapcar '(lambda (%)(cons % (getvar %))) l))
(foreach % (mapcar '(lambda (%)(cons % (getvar %))) l)
(if
(not (car (assoc (car %) *jk-var)))
(setq *jk-Var (append *jk-Var (list %)))
Nil
)
)
)
)
)
*jk-Var
)
;;; by kojacek
;;; Funkcja przywracaj?ca warto?ci zmiennych
;;;
(defun jk:SYS_ModeR ()
(if
*jk-Var
(jk:SYS_SetVars
(apply
'append
(mapcar '(lambda (%)(list (car %)(cdr %)))
*jk-var
)
)
)
Nil
)
(setq *jk-var nil)
)
;; by kojacek
;; ---------------------------------------------------------- ;
;; zwraca liste symboli globalnych ;
;; ;
(defun jk:SYS_GetGlobals (/ s)
(setq s
(vl-remove-if
'(lambda (%)
(/= (strcase (substr % 1 4)) "*JK-")
)
(atoms-family 1)
)
)
(if s
(mapcar
'(lambda (%)(cons % (vl-symbol-value (read %))))
(vl-sort s '<)
)
Nil
)
)
;; --------------------------------------------------------- ;
;; zeruje zmienne globalne "*JK-..." ;
;; ;
(defun jk:SYS_KillGlobals (/ s)
(if
(setq Lst (jk:SYS_GetGlobals))
(foreach % s
(cond
( (= (type (cdr %)) 'VLA-OBJECT)
(vlax-release-object (cdr %))
(set (read (car %)) Nil)
)
(T (set (read (car %)) Nil))
)
)
)
)
;;; 2002 by kojacek
(vl-load-com)
;;;
(defun C:REGCEN (/ Sel Data Reg Obj Obj1 Obj2 Add Pt)
(if
(setq Sel (entsel "\n Wska? region lub bry??: "))
(if
(member
(jk:DXF 0 (setq Data (entget (setq Obj (car Sel)))))
'("3DSOLID" "REGION")
)
(if
(not (jk:ENT_isLocked Obj 1))
(progn
(jk:SYS_UndoBegin)
(cond
((= (jk:DXF 0 Data) "REGION")
(setq Reg (jk:CON_VlaObject Obj)
Obj1 (vla-Copy Reg)
Obj2 (vla-Copy Reg)
)
(vla-Boolean
(vla-AddExtrudedSolid
(jk:ACX_GetModel)
Obj1
1.0
0.0
)
acUnion
(vla-AddExtrudedSolid
(jk:ACX_GetModel)
Obj2
-1.0
0.0
)
)
(vla-Delete Obj1)
(vla-Delete Obj2)
(setq Add (jk:CON_VlaObject (entlast)))
(setq Pt (vla-get-centroid Add))
(vla-Delete Add)
)
(T
(setq Pt
(vla-get-centroid (jk:CON_VlaObject Obj))
)
)
)
(entmake
(append
(jk:DXF_MakeDxfList
'(0 100 100)
'("POINT" "AcDbEntity" "AcDbPoint")
)
(list
(cons 410 (getvar "CTAB"))
(cons
10
(vlax-safearray->list (vlax-variant-value Pt))
)
)
)
)
(jk:SYS_UndoEnd)
)
)
(princ "\nNale?y wskaza? region lub bry??. ")
)
(princ "\nNic nie wskazano. ")
)
(princ)
)

(defun jk:ACX_ActDoc () 
  (if 
    (not *jk-ActDoc) 
    (setq *jk-ActDoc (vla-get-activedocument (vlax-get-acad-object))) 
    *jk-ActDoc 
  ) 
) 
(defun jk:ACX_GetModel () 
  (if 
    (not *jk-Model) 
    (setq *jk-Model (vla-get-modelspace (jk:ACX_ActDoc))) 
    *jk-Model 
  ) 
) 
(defun jk:ACX_GetActiveSpace () 
  (if 
    (= 1 (getvar "TILEMODE")) 
    (jk:ACX_GetModel) 
    (if 
      (= 2 (getvar "CVPORT")) 
      (jk:ACX_GetModel) 
      (vla-item (jk:ACX_GetBlocks) "*Paper_Space") 
    ) 
  ) 
) 
(defun jk:ACX_GetBlocks () 
  (if 
    (not *jk-Blocks) 
    (setq *jk-Blocks (vla-get-Blocks (jk:ACX_ActDoc))) 
    *jk-Blocks 
  ) 
) 
(defun jk:ACX_ChangeObj (Obj Lay Col LTp LTs LTw) 
  (setq Obj (jk:CON_VlaObject Obj)) 
  (if 
    (vlax-write-enabled-p Obj) 
    (progn 
      (if 
        (and Lay (= (type Lay) 'STR)) 
        (if 
          (not (jk:TBL_LayIsLocked Lay)) 
          (vla-put-layer Obj Lay) 
        ) 
      ) 
      (if 
        (and Col (= (type Col) 'INT)) 
        (if 
          (and (>= Col 0)(<= Col 256)) 
          (vla-put-color Obj Col) 
        ) 
      ) 
      (if 
        (and LTp (= (type LTp) 'STR)) 
        (if 
          (jk:TBL_isLtp LTp) 
          (vla-put-linetype Obj LTp) 
        ) 
      ) 
      (if 
        (and LTs (numberp LTs)) 
        (if 
          (< LTs 0.0) 
          (vla-put-LinetypeScale Obj LTs) 
        ) 
      ) 
      (if 
        (and LTw (numberp LTw)) 
        (vla-put-lineweight Obj LTw) 
      ) 
    ) 
  ) 
) 
(defun jk:ACX_MakeMline 
   (Space Name   plst   Width  Closed Lay 
    Col Ltp    Lts    Ltw    /     ary 
    Obj Mst    Mw 
   ) 
  (setq plst (mapcar '(lambda (&) (list (car &) (cadr &) (caddr &))) 
       plst 
      ) 
 Mst  (getvar "CMLSTYLE") 
  ) 
  (setvar "CMLSTYLE" Name) 
  (setq plst (apply 'append plst) 
 ary  (vlax-make-safearray 
        vlax-vbdouble 
        (cons 1 (length plst)) 
      ) 
 Obj  (vla-addmline 
        Space 
        (vlax-make-variant 
   (vlax-safearray-fill ary plst) 
        ) 
      ) 
  ) 
  (jk:ACX_ChangeObj Obj Lay Col LTp LTs LTw) 
  (setvar "CMLSTYLE" Mst) 
  (if Closed 
    (progn 
      (setq Mw (entget (jk:CON_Ename Obj))) 
      (entmod 
 (subst (cons 71 (+ 2 (cdr (assoc 71 Mw)))) (assoc 71 Mw) Mw) 
      ) 
    ) 
  ) 
  (setq Mw (entget (jk:CON_Ename Obj))) 
  (if (numberp Width) 
    (entmod (subst (cons 40 Width) (assoc 40 Mw) Mw)) 
  ) 
  (vla-put-Coordinates Obj ary) 
  Obj 
) 
(defun jk:ENT_isLocked (e m) 
  (if 
    (= 4 
      (logand 
        4 
        (jk:DXF 70 (tblsearch "LAYER" (jk:DXF 8 (entget e)))) 
      ) 
    ) 
    (progn 
      (if m (princ "\nObiekt na zamkni?tej warstwie. ")) 
      T 
    ) 
    nil 
  ) 
) 
(defun jk:CON_VlaObject (In) 
  (cond 
    ((= (type In) 'VLA-OBJECT) In) 
    ((= (type In) 'ENAME)(vlax-ename->vla-object In)) 
    (T Nil) 
  ) 
) 
(defun jk:CON_Ename (In) 
  (cond 
    ((= (type In) 'VLA-OBJECT)(vlax-vla-object->ename In)) 
    ((= (type In) 'ENAME) In) 
    (T Nil) 
  ) 
) 
;; by kojacek 
;; Funkcja zwraca list? ?ańcuchów tekstowych dziel?c  argument STR na 
;; pod?ańcuchy. Separatorem ?ańcucha jest znak ",". UWAGA! - argument 
;; [STR] nie mo?e by? ?ańcuchem w którym wyst?puj? separatory jeden 
;; za drugim. 
(defun jk:CON_Str->List (Str / inc tmp res) 
  (setq inc 0) 
  (while 
    (/= tmp "") 
    (setq tmp 
      (menucmd 
        (strcat "M=$(index," (itoa inc) ",\"" Str "\")") 
      ) 
      inc (1+ inc) 
    ) 
    (setq res (append (list tmp) res)) 
  ) 
  (reverse (cdr res)) 
) 
;; by kojacek 
;; Zwraca liste ?ańcuchów tekstowych reprezentuj?cych aktualn? 
;; dat? o formacie: MM-rzym Miesi?c DD MM YYYY DzieńTygodnia 
;; Wymaga funkcji jk:CON_Str->List 
(defun jk:SYS_TodayList (/ Date Mont) 
  (setq Date 
    (jk:CON_Str->List 
      (menucmd 
        (strcat 
          "M=$(edtime,$(getvar,date),MONTH" 
          "\",\"MO\",\"DD\",\"YYYY\",\"DDDD)" 
        ) 
      ) 
    ) 
  ) 
  (setq Mont 
    (menucmd 
      (strcat "M=$(index," 
              (itoa (1- (read (nth 1 Date)))) 
              ",\"I,II,III,IV,V,VI,VII,VIII,IX,X,XI,XII\")" 
      ) 
    ) 
  ) 
  (cons Mont Date) 
) 
;; by kojacek 
;; Awraca liste ?ańcuchów tekstowych reprezentuj?cych aktualny czas: 
;; Wymaga funkcji jk:CON_Str->List 
;; Zwraca list? formatu: ("HH" "MM" "SS" "MSEC") 
(defun jk:SYS_CurTime () 
  (jk:CON_Str->List 
    (menucmd 
      "M=$(edtime,$(getvar,date),HH\",\"MM\",\"SS\",\"MSEC)" 
    ) 
  ) 
) 
(defun jk:CON_GetvarAsStr (Var) 
  (menucmd 
    (strcat 
      "M=$(getvar,\"" Var "\")" 
    ) 
  ) 
) 
(defun jk:DXF (Code Lst) 
  (cdr (assoc Code Lst)) 
) 
 
(defun jk:DXF_MakeDxfList (CodeLst DataLst / Tmp inc) 
  (setq Inc -1) 
  (if 
    (/= (length CodeLst)(length DataLst)) 
    Nil 
    (mapcar 
      '(lambda (%) 
         (setq inc (1+ Inc)) 
         (if 
           (listp (setq Tmp (nth Inc DataLst))) 
           (append (list %) Tmp) 
           (cons % Tmp) 
         ) 
       ) 
       CodeLst 
    ) 
  ) 
) 
;| 
Przyk?ad: 
(jk:DXF_MakeDxfList '(0 2 10)'("INSERT" "NAZWA" (0.0 0.0 0.0))) 
zwraca: 
((0 . "INSERT")(2 . "NAZWA")(10 0.0 0.0 0.0)) 
oraz: 
(jk:DXF_MakeDxfList '(0 2 10)'("INSERT" "NAZWA")) 
zwraca: 
nil |; 
(defun jk:DXF_mAssoc (key alist / x nlist) 
  (foreach % alist 
    (if (eq key (car %)) 
      (setq nlist (cons (cdr %) nlist)) 
    ) 
  ) 
  (reverse nlist) 
) 
(defun jk:CAL_Sequence (start lengt step / Tmp TmpList) 
  (if 
    (and (numberp start)(numberp lengt)(numberp step)) 
    (progn 
      (setq Tmp Start) 
      (while 
        (< (length TmpList) (1- Lengt)) 
        (setq Tmp (+ Tmp Step)) 
        (setq TmpList (append (list Tmp) TmpList)) 
      ) 
      (cons Start (reverse TmpList)) 
    ) 
    Nil 
  ) 
) 
(defun jk:TBL_isLay (Name) 
  (tblobjname "LAYER" (strcase Name)) 
) 
 
(defun jk:TBL_isLTp (Name) 
  (tblobjname "LTYPE" (strcase Name)) 
) 
 
(defun jk:TBL_LayIsLocked (Name) 
  (if 
    (jk:TBL_isLay Name) 
    (= 4 (logand 4 (cdr (assoc 70 
                          (tblsearch "LAYER" (strcase Name)) 
      ))) 
    ) 
    0 
  ) 
) 
(defun jk:SYS_UndoBegin () 
  (vla-StartUndoMark (jk:ACX_ActDoc)) 
) 
;; =====================================   
(defun jk:SYS_UndoEnd () 
  (vla-EndUndoMark (jk:ACX_ActDoc)) 
) 
;;; by kojacek 
;;; 
(defun jk:SYS_GetCpu () 
  (apply 'strcat 
    (mapcar 
      '(lambda (%) 
         (if 
    (numberp %) 
    (strcat "(" (itoa %) " MHz)") 
    (strcat % ", ") 
         ) 
       ) 
       (mapcar 
        '(lambda (%) 
          (vl-registry-read 
     (strcat "HKEY_LOCAL_MACHINE\\Hardware\\" 
             "Description\\System\\CentralProcessor\\0" 
     ) 
     % 
   ) 
        ) 
        '("Identifier" "ProcessorNameString" "~MHz") 
      ) 
    ) 
  ) 
) 
;; ------------------------------------------ by kojacek 2002 -; 
;; Tworzy katalog. Zwraca T lub Nil (gdy niepowodzenie)        ; 
;;                                                             ; 
(defun jk:SYS_MkDir (Pth / Lst) 
  (if 
    (setq Lst (cdr (jk:SYS_PathList Pth))) 
    (foreach % Lst 
      (if (not (vl-file-directory-p %))(vl-mkdir %)) 
    ) 
  ) 
) 
;; ------------------------------------------ by kojacek 2002 -; 
;; Zwraca liste kolejnych sciezek dostepu katalogu             ; 
;;                                                             ; 
(defun jk:SYS_PathList (Pth / tmp x Res) 
  (if 
    (setq tmp (jk:STR_parse Pth "\\")) 
    (while Tmp 
      (setq x (apply 
                'strcat 
                (append 
                  (reverse 
                    (mapcar 
                      '(lambda (%)(strcat % "\\")) 
                      (cdr (reverse Tmp)) 
                    ) 
                  ) 
                  (list (last tmp)) 
                ) 
              ) 
            Tmp (reverse (cdr (reverse Tmp))) 
            Res (append (list x) Res) 
      ) 
    ) 
  ) 
  Res 
) 
(defun jk:STR_parse (str chs / len c l s chsl cnt ) 
  (setq chsl (jk:STR_MakeList chs)) 
  (setq len (strlen str) s "" cnt (1+ len)) 
  (while (> (setq cnt (1- cnt)) 0) 
    (setq c (substr str cnt 1)) 
    (if (member c chsl) 
      (if (/= cnt len) 
        (setq l (cons s l) s "") 
      ) 
      (setq s (strcat c s)) 
    ) 
  ) 
  (cons s l) 
) 
;;; by kojacek 
;;; Zmienia warto?ci zmiennych z listy podanej jako argument [l] 
;;; 
(defun jk:SYS_SetVars (l / e) 
  (if 
    (listp l) 
    (while l 
      (if 
        (setq e 
          (vl-catch-all-error-p 
            (vl-catch-all-apply 
              'setvar 
              (list (car l)(cadr l)) 
            ) 
          ) 
        ) 
        Nil 
        (setvar (car l)(cadr l)) 
      ) 
      (setq l (cddr l)) 
    ) 
    (setq e T) 
  ) 
  e 
) 
;;; by kojacek 
;;; Funkcja zapamietuj?ca warto?ci zmiennych 
;;; 
(defun jk:SYS_ModeS (l) 
  (if 
    (listp l) 
    (if 
      (setq l (vl-remove-if-not 'getvar l)) 
      (if 
        (not *jk-Var) 
        (setq *jk-Var (mapcar '(lambda (%)(cons % (getvar %))) l)) 
        (foreach % (mapcar '(lambda (%)(cons % (getvar %))) l) 
          (if 
            (not (car (assoc (car %) *jk-var))) 
            (setq *jk-Var (append *jk-Var (list %))) 
            Nil 
          ) 
        ) 
      ) 
    ) 
  ) 
  *jk-Var 
) 
;;; by kojacek 
;;; Funkcja przywracaj?ca warto?ci zmiennych 
;;; 
(defun jk:SYS_ModeR () 
  (if 
    *jk-Var 
    (jk:SYS_SetVars 
      (apply 
        'append 
        (mapcar '(lambda (%)(list (car %)(cdr %))) 
                *jk-var 
        ) 
      ) 
    ) 
    Nil 
  ) 
  (setq *jk-var nil) 
) 
;; by kojacek 
;; ---------------------------------------------------------- ; 
;; zwraca liste symboli globalnych                            ; 
;;                                                            ; 
(defun jk:SYS_GetGlobals (/ s) 
  (setq s 
     (vl-remove-if 
       '(lambda (%) 
         (/= (strcase (substr % 1 4)) "*JK-") 
       ) 
       (atoms-family 1) 
     ) 
  ) 
  (if s 
    (mapcar 
      '(lambda (%)(cons % (vl-symbol-value (read %)))) 
      (vl-sort s '<) 
    ) 
    Nil 
  ) 
) 
;; --------------------------------------------------------- ; 
;; zeruje zmienne globalne "*JK-..."                         ; 
;;                                                           ; 
(defun jk:SYS_KillGlobals (/ s) 
  (if 
    (setq Lst (jk:SYS_GetGlobals)) 
    (foreach % s 
      (cond 
        ( (= (type (cdr %)) 'VLA-OBJECT) 
          (vlax-release-object (cdr %)) 
          (set (read (car %)) Nil) 
        ) 
        (T (set (read (car %)) Nil)) 
      ) 
    ) 
  ) 
) 
 
;;; 2002 by kojacek 
(vl-load-com) 
;;;                                                             
(defun C:REGCEN (/ Sel Data Reg Obj Obj1 Obj2 Add Pt) 
  (if 
    (setq Sel (entsel "\n Wska? region lub bry??: ")) 
     (if 
       (member 
  (jk:DXF 0 (setq Data (entget (setq Obj (car Sel))))) 
  '("3DSOLID" "REGION") 
       ) 
 (if 
   (not (jk:ENT_isLocked Obj 1)) 
    (progn 
      (jk:SYS_UndoBegin) 
      (cond 
        ((= (jk:DXF 0 Data) "REGION") 
  (setq Reg  (jk:CON_VlaObject Obj) 
        Obj1 (vla-Copy Reg) 
        Obj2 (vla-Copy Reg) 
  ) 
  (vla-Boolean 
    (vla-AddExtrudedSolid 
      (jk:ACX_GetModel) 
      Obj1 
      1.0 
      0.0 
    ) 
    acUnion 
    (vla-AddExtrudedSolid 
      (jk:ACX_GetModel) 
      Obj2 
      -1.0 
      0.0 
    ) 
  ) 
  (vla-Delete Obj1) 
  (vla-Delete Obj2) 
  (setq Add (jk:CON_VlaObject (entlast))) 
  (setq Pt (vla-get-centroid Add)) 
  (vla-Delete Add) 
        ) 
        (T 
  (setq Pt 
         (vla-get-centroid (jk:CON_VlaObject Obj)) 
  ) 
        ) 
      ) 
      (entmake 
        (append 
   (jk:DXF_MakeDxfList 
     '(0 100 100) 
     '("POINT" "AcDbEntity" "AcDbPoint") 
   ) 
   (list 
     (cons 410 (getvar "CTAB")) 
     (cons 
       10 
       (vlax-safearray->list (vlax-variant-value Pt)) 
     ) 
   ) 
        ) 
      ) 
      (jk:SYS_UndoEnd) 
    ) 
 ) 
 (princ "\nNale?y wskaza? region lub bry??. ") 
     ) 
     (princ "\nNic nie wskazano. ") 
  ) 
  (princ) 
)

jyzas · 发表于 2013-7-19 06:50:19

程序没有注解，最起码也要说明函数的作用

st788796 · 发表于 2013-7-19 08:48:42

jyzas 发表于 2013-7-19 06:50
程序没有注解，最起码也要说明函数的作用

很简单的功能，不解释

duotu007 · 发表于 2013-7-19 16:41:08

代码优化减肥

账号		自动登录	找回密码
密码			立即注册

[他山之石] 几个函数

马上注册，结交更多好友，享用更多功能，让你轻松玩转社区。

评分

点评

浏览过的版块