石必强大神函数excel数字日期转cad

树櫴希德 · 发表于 2020-11-16 21:20:10

;【管理员】石必强(1291500406) 2020/11/16 16:56:13
(defun BB-USING-vbs ( str)
(if(or
ScriptControl
(setq ScriptControl (vlax-create-object "{e8540e26-d20e-483f-9fd5-a5a3553a7556}"))
(setq ScriptControl (vlax-create-object "{0e59f1d5-1fbe-11d0-8ff2-00a0d10038bc}"))
)(progn
(vl-catch-all-apply 'vlax-put (list ScriptControl "language" "vbscript"))
(vl-catch-all-apply ' vlax-invoke (list ScriptControl "eval" str )
))))
;【管理员】石必强(1291500406) 2020/11/16 16:56:18
;(BB-USING-vbs "Year(44024)")
;(BB-USING-vbs "Month(44024)")
;(BB-USING-vbs "Day(44024)")
;星期
;(BB-USING-vbs "Weekday(44024)")
(setq sz(strcat "(" (getstring "\n请输入数字：")")"))
(setq rq(strcat (rtos (BB-USING-vbs (strcat "Year" sz)) 2 0 ) "年" (rtos (BB-USING-vbs (strcat "Month" sz)) 2 0 )"月"(rtos (BB-USING-vbs (strcat "Day" sz)) 2 0 )"日"
) )
(print rq)

树櫴希德 · 发表于 2021-1-28 15:55:31

收藏替换字体好多号函数

;split 函数的基本功能是用一个短字符串去分割一个长字符串，并返回分割后的数组
;例如：用空格切割字符串 (split "i love you" " ") ，返回 ("i" "love" "you")
(defun split (str delim / buff l2)
(setq str (vl-string->list str)
delim (vl-string->list delim)
)
(while str
(if (member (car str) delim)
(setq l2 (cons (vl-list->string (reverse buff)) l2)
buff nil
)
(setq buff (cons (car str) buff))
)
(setq str (cdr str))
)
(setq l2 (cons (vl-list->string (reverse buff)) l2))
(reverse l2)
)
;;;;
(defun StrParse (String Seperator / Pos1 Pos2 NewStrList)
;|
Seperator a string (making a list of stings) at a given
string value
ie: (StrParse "1,1,0" ",")
returns: ("1" "1" "0")
Written when I couldn't find it on the web
By: Tim Willey 11/15/2004
|;
(setq Pos2 1)
(while (setq Pos1 (vl-string-search Seperator String Pos1))
(if (= Pos2 1)
(setq NewStrList (cons (substr String Pos2 Pos1) NewStrList))
(setq NewStrList
(cons (substr String Pos2 (- (1+ Pos1) Pos2))
NewStrList
)
)
)
(setq Pos2 (1+ (+ (strlen Seperator) Pos1)))
(setq Pos1 (+ Pos1 (strlen Seperator)))
)
(reverse
(setq NewStrList (cons (substr String Pos2) NewStrList))
)
)
;(StrParse (getenv "ACAD") ";")
;(vl-string->list (getenv "ACAD"))
;默认字体
(defun C:tiehuan ( / iChange)
(EF:Style-DefuntFont "TSSDENG.SHX" "TSSDCHN.SHX")
(princ)
)
;清除列表中连续重复元素
;'( 1 2 3 1 1 nil nil nil 4 4 5 6 nil nil) -> '( 1 2 3 1 nil 4 5 6 nil)
(defun EFist-Fix (lst1 / e lst2 )
(if lst1
(progn
(setq lst2 (list (setq e (car lst1))))
(while (setq lst1 (cdr lst1))
(if (not (equal e (car lst1)))
(setq lst2 (cons (car lst1) lst2))
)
(setq e (car lst1))
)
(reverse lst2)
)
)
)
;判断字体是否为大字体
(defun EF:Acad-isBigFont (filename / fh BigFont)
(setq fh (open filename "r"))
(setq BigFont (substr (read-line fh) 12 7))
(close fh)
(if (= (strcase BigFont) "BIGFONT")
(setq BigFont T)
(setq BigFont nil)
)
BigFont
)
;字体列表
(defun EF:Acad-getFonts ( /
e e1 e2
lstPath
fonts ;所有字体列表
bigfonts ;大字体列表
efonts ;普通字体列表
wfonts ;Windows字体
)
(setq lstPath (cdr(reverse (split (getenv "ACAD") ";"))) );取得所有系统搜索路径
(foreach e lstPath
(setq fonts (append fonts (vl-directory-files e "*.shx" 1)))
)
(setq fonts (vl-sort fonts '>))
(setq fonts (mapcar 'strcase fonts))
(setq fonts (EFist-Fix fonts))
(foreach e fonts
(if (EF:Acad-isBigFont (findfile e))
(setq bigFonts (cons e bigFonts))
(setq eFonts (cons e eFonts))
)
)
(setq wFonts (append (vl-directory-files (strcat (getenv "Windir") "\\FONTS\\") "*.TTC" 0)
(vl-directory-files (strcat (getenv "Windir") "\\FONTS\\") "*.TTF" 0)
))
(list eFonts bigFonts wFonts)
)
;获取所有字体样式
(defun EF:Style-getAllTextStyles (
/
TextStyles lstFonts
Typeface Bold Italic CharSet PitchAndFamily
)
(setq TextStyles (Vlax-Get (Vlax-Get (Vlax-Get-Acad-Object) 'ActiveDocument) 'TextStyles))
(vlax-for TextStyle TextStyles
(vla-getFont TextStyle 'Typeface 'Bold 'Italic 'CharSet 'PitchAndFamily)
(setq lstFonts (cons
(list
(vla-get-Name TextStyle)
(vla-get-FontFile TextStyle)
(vla-get-BigFontFile TextStyle)
Typeface
(vla-get-Height TextStyle)
(vla-get-Width TextStyle)
(vla-get-ObliqueAngle TextStyle)
)
lstFonts
)
)
)
(reverse lstFonts)
)
;未知字体替换默认字体
(defun EF:Style-DefuntFont (Font BigFont /
Font BigFont iChange
fonts bigfonts
ext
)
(setq lstStyle (EF:Style-getAllTextStyles))
(setq fonts (mapcar 'vl-filename-base $EF_Fonts))
(setq bigfonts (mapcar 'vl-filename-base $EF_BigFonts))
(mapcar '(lambda (e / edata eFont eBigFont bChange)
(cond ((/= (cadddr e) "")
)
((and (setq ext (vl-filename-extension (cadr e)))
(/= (strcase ext) ".SHX")
)
)
(T
(setq edata (entget (tblobjname "Style" (car e))))
(setq eFont (cdr (assoc 3 edata))
eBigFont (cdr (assoc 4 edata))
)
(if (not (member (strcase (vl-filename-base eFont)) fonts))
(setq edata (subst (cons 3 Font) (assoc 3 edata) edata)
bChange T
)
)
(if (not (member (strcase (vl-filename-base eBigFont)) bigfonts))
(setq edata (subst (cons 4 BigFont) (assoc 4 edata) edata)
bChange T
)
)
(if bChange (entmod edata))
)
)
) lstStyle
)
)
;检索字体
(setq $EF_Fonts (EF:Acad-getFonts))
(setq $EF_BigFonts (mapcar 'strcase (cadr $EF_Fonts))
$EF_WinFonts (mapcar 'strcase (caddr $EF_Fonts))
$EF_Fonts (mapcar 'strcase (car $EF_Fonts))
)

;split 函数的基本功能是用一个短字符串去分割一个长字符串，并返回分割后的数组 
;例如： 用空格切割字符串 (split "i love you" " ") ，返回 ("i" "love" "you") 
(defun split (str delim / buff l2) 
  (setq str (vl-string->list str) 
  delim (vl-string->list delim) 
  ) 
  (while str 
    (if (member (car str) delim) 
      (setq l2 (cons (vl-list->string (reverse buff)) l2) 
      buff nil 
      ) 
      (setq buff (cons (car str) buff)) 
    ) 
    (setq str (cdr str)) 
  ) 
  (setq l2 (cons (vl-list->string (reverse buff)) l2)) 
  (reverse l2) 
) 
;;;; 
(defun StrParse        (String Seperator / Pos1 Pos2 NewStrList) 
                ;| 
  Seperator a string (making a list of stings) at a given 
  string value 
  ie: (StrParse "1,1,0" ",") 
  returns: ("1" "1" "0") 
  Written when I couldn't find it on the web 
  By: Tim Willey 11/15/2004 
|; 
 
  (setq Pos2 1) 
  (while (setq Pos1 (vl-string-search Seperator String Pos1)) 
    (if        (= Pos2 1) 
      (setq NewStrList (cons (substr String Pos2 Pos1) NewStrList)) 
      (setq NewStrList 
             (cons (substr String Pos2 (- (1+ Pos1) Pos2)) 
                   NewStrList 
             ) 
      ) 
    ) 
    (setq Pos2 (1+ (+ (strlen Seperator) Pos1))) 
    (setq Pos1 (+ Pos1 (strlen Seperator))) 
  ) 
  (reverse 
    (setq NewStrList (cons (substr String Pos2) NewStrList)) 
  ) 
) 
 
 
;(StrParse (getenv "ACAD") ";") 
 
;(vl-string->list (getenv "ACAD")) 
 
 
 
 
;默认字体 
(defun C:tiehuan ( / iChange) 
  (EF:Style-DefuntFont "TSSDENG.SHX" "TSSDCHN.SHX") 
  (princ) 
) 
;清除列表中连续重复元素 
;'( 1 2 3 1 1 nil nil nil 4 4 5 6 nil nil) -> '( 1 2 3 1 nil 4 5 6 nil) 
(defun EF<img src="static/image/smiley/default/sweat.gif" smilieid="10" border="0" alt="" />ist-Fix (lst1 / e lst2 ) 
  (if lst1 
    (progn 
      (setq lst2 (list (setq e (car lst1)))) 
      (while (setq lst1 (cdr lst1)) 
        (if (not (equal e (car lst1))) 
          (setq lst2 (cons (car lst1) lst2)) 
        ) 
        (setq e (car lst1)) 
      ) 
      (reverse lst2) 
    ) 
  ) 
) 
;判断字体是否为大字体 
(defun EF:Acad-isBigFont (filename / fh BigFont) 
  (setq fh (open filename "r")) 
  (setq BigFont (substr (read-line fh) 12 7)) 
  (close fh) 
  (if (= (strcase BigFont) "BIGFONT") 
    (setq BigFont T) 
    (setq BigFont nil) 
  ) 
  BigFont 
) 
;字体列表 
(defun EF:Acad-getFonts ( / 
                          e e1 e2 
                          lstPath 
                          fonts    ;所有字体列表 
                          bigfonts    ;大字体列表 
                          efonts    ;普通字体列表 
                          wfonts    ;Windows字体 
                        ) 
  (setq lstPath (cdr(reverse (split (getenv "ACAD") ";"))) );取得所有系统搜索路径 
  (foreach e lstPath 
    (setq fonts (append fonts (vl-directory-files e "*.shx" 1))) 
  ) 
  (setq fonts (vl-sort fonts '>)) 
  (setq fonts (mapcar 'strcase fonts)) 
  (setq fonts (EF<img src="static/image/smiley/default/sweat.gif" smilieid="10" border="0" alt="" />ist-Fix fonts)) 
  (foreach e fonts 
    (if (EF:Acad-isBigFont (findfile e)) 
      (setq bigFonts (cons e bigFonts)) 
      (setq eFonts (cons e eFonts)) 
    ) 
  ) 
  (setq wFonts (append (vl-directory-files (strcat (getenv "Windir") "\\FONTS\\") "*.TTC" 0) 
                 (vl-directory-files (strcat (getenv "Windir") "\\FONTS\\") "*.TTF" 0) 
               )) 
  (list eFonts bigFonts wFonts) 
) 
;获取所有字体样式 
(defun EF:Style-getAllTextStyles ( 
                                   / 
                                   TextStyles lstFonts 
                                   Typeface Bold Italic CharSet PitchAndFamily 
                                 ) 
  (setq TextStyles (Vlax-Get (Vlax-Get (Vlax-Get-Acad-Object) 'ActiveDocument) 'TextStyles)) 
  (vlax-for TextStyle TextStyles 
    (vla-getFont TextStyle 'Typeface 'Bold 'Italic 'CharSet 'PitchAndFamily) 
    (setq lstFonts (cons 
                     (list 
                           (vla-get-Name TextStyle) 
                           (vla-get-FontFile TextStyle) 
                           (vla-get-BigFontFile TextStyle) 
                           Typeface 
                           (vla-get-Height TextStyle) 
                           (vla-get-Width TextStyle) 
                           (vla-get-ObliqueAngle TextStyle) 
                         ) 
                     lstFonts 
                   ) 
    ) 
  ) 
  (reverse lstFonts) 
) 
;未知字体替换默认字体 
(defun EF:Style-DefuntFont (Font BigFont / 
                             Font BigFont iChange 
                             fonts bigfonts 
                             ext 
                           ) 
  (setq lstStyle (EF:Style-getAllTextStyles)) 
  (setq fonts (mapcar 'vl-filename-base $EF_Fonts)) 
  (setq bigfonts (mapcar 'vl-filename-base $EF_BigFonts)) 
  (mapcar '(lambda (e / edata eFont eBigFont bChange) 
             (cond ((/= (cadddr e) "") 
                   ) 
               ((and (setq ext (vl-filename-extension (cadr e))) 
                  (/= (strcase ext) ".SHX") 
                ) 
               ) 
               (T 
                 (setq edata (entget (tblobjname "Style" (car e)))) 
                 (setq eFont (cdr (assoc 3 edata)) 
                   eBigFont (cdr (assoc 4 edata)) 
                 ) 
                 (if (not (member (strcase (vl-filename-base eFont)) fonts)) 
                   (setq edata (subst (cons 3 Font) (assoc 3 edata) edata) 
                     bChange T 
                   ) 
                 ) 
                 (if (not (member (strcase (vl-filename-base eBigFont)) bigfonts)) 
                   (setq edata (subst (cons 4 BigFont) (assoc 4 edata) edata) 
                     bChange T 
                   ) 
                 ) 
                 (if bChange (entmod edata)) 
               ) 
             ) 
           ) lstStyle 
  ) 
) 
;检索字体 
(setq $EF_Fonts (EF:Acad-getFonts)) 
(setq $EF_BigFonts (mapcar 'strcase (cadr $EF_Fonts)) 
  $EF_WinFonts (mapcar 'strcase (caddr $EF_Fonts)) 
  $EF_Fonts (mapcar 'strcase (car $EF_Fonts)) 
)

树櫴希德 · 发表于 2020-12-23 20:31:33

(defun LINE:Distance_LineToLine_2d_i (p1 p2 p3 p4)
;;两直线间最小间距及相关点坐标的索引 (0 1 2 3 4) 对应 (nil p1 p2 p3 p4)
;;返回list 类型距离 [交点1] [交点2] [[点1 [点2]/[线1]] [点3 [点4]/[线2]]])
;;距离0重合或点在线上 ,交点1是表是斜交点 ,垂距或平行间距
;;线段长度不为0 p1/=p2 p3/=p4
;;默认已做顺向处理x1 <= x2 x3<=x4
;;以最左边的线变换坐标系.
(setq fuzz 1e-9 fuzz-jj 0.1)
(setq pts (list p1 p2 p3 p4))
(and (> (car p1) (car p3)) (setq jiaoHuan T) (mapcar 'set '(p1 p2 p3 p4) (list p3 p4 p1 p2)))
(setq m (MAT:Rotation p1 (ang p1 p2)))
(setq lst (mapcar (function (lambda (x) (MAT:mxp m x))) (list p1 p2 p3 p4)))
(mapcar 'set '(p1 p2 p3 p4) lst)
(setq line1 (list 1 2) line2 (list 3 4))
(mapcar 'set '(x1 y1 x2 y2 x3 y3 x4 y4) (apply 'append (list p1 p2 p3 p4)))
(setq k1 0)
(setq k2 (/ (- y3 y4) (if (equal x3 x4 fuzz) fuzz (- x3 x4))))
;;用斜率分
(setq lst
(if (equal k1 k2 fuzz)
(progn
;;斜率相同
;;用两线的垂直距离分
(setq dd (- y3 y2))
(if (equal dd 0 fuzz)
(progn
;;间距为0在同一条线上
(cond
((equal x2 x3 fuzz) (list 6 0 2 nil (list 2 3) nil)) ;尾首相接
((> x3 x2) (list 7 0 nil nil (list 2 3) nil)) ;离开
((equal x1 x3 fuzz)
(cond
((equal x2 x4 fuzz) (list 8 0 1 2 nil nil)) ;完全重合
((< x2 x4) (list 9 0 2 nil (list 2 line2) nil)) ;有一个端点相同部分重合
((> x2 x4) (list 9 0 4 nil (list 4 line1) nil)) ;有一个端点相同部分重合
(T (alert "未考虑到的情况1"))
)
)
((< x3 x2 x4) (list 10 0 3 2 (list 2 line2) (list 3 line1))) ;部分重合
(T (alert "未考虑到的情况2"))
)
)
(progn
;;两平行线
(cond
((> x3 x2) (list 11 dd nil nil (list 2 3) nil)) ;平行离开
((and (< x1 x3 x2) (> x4 x2)) (list 12 dd nil nil (list 2 line2) (list 3 line1))) ;平行,部分垂足在线上
((< x1 x3 x2) (list 13 dd nil nil (list 2 line2) (list 3 line1))) ;平行,包含
((equal x2 x3) (list 14 dd nil nil (list 2 3) nil)) ;直拐平行
((and (equal x1 x3 fuzz) (equal x2 x4 fuzz)) (list 15 dd nil nil (list 1 3) (list 2 4))) ;完全平行
(T (alert "未考虑到的情况3"))
)
)
)
)
(progn
;;斜率不同
;;用交点分
(if (setq int-pt (LINE:Intersection p1 p2 p3 p4))
(progn
;;有交点
(setq pt1 nil)
(if (equal int-pt p1 fuzz)
(setq pt1 1)
(if (equal int-pt p2 fuzz)
(setq pt1 2)
)
)
(setq pt2 nil)
(if (equal int-pt p3 fuzz)
(setq pt2 3)
(if (equal int-pt p4 fuzz)
(setq pt2 4)
)
)
(cond
((and pt1 pt2) (list 3 0 pt1 nil (list pt1 pt2) nil)) ;两端点相接
(pt1 (list 4 0 pt1 nil (list pt1 line2) nil)) ;端点在2线上
(pt2 (list 4 0 pt2 nil (list pt2 line1) nil)) ;端点在1线上
;;交点在两线中间.
(T (setq da (LINE:Perpendicular_Distance p3 p1 p2))
(setq pt (LINE:Perpendicular_Foot_1 p2 p3 p4))
(if (equal (distance p3 p4) (+ (distance pt p3) (distance pt p4)) fuzz)
;;p2到线2上有垂足
(setq db (LINE:Perpendicular_Distance p2 p3 p4) tmp (list 2 line2))
;;p2到线2上无垂足
(setq db (LINE:Perpendicular_Distance p4 p1 p2) tmp (list 4 line1))
)
(if (<= da db)
(list 5 da (list 1 2 3 4) nil (list 3 line1) tmp)
(list 5 db (list 1 2 3 4) nil tmp (list 3 line1))
)
)
)
)
(progn
;;无交点
(if (<= x4 x2)
;;x方向线1包含线2,线1上有2个垂足
(if (< (abs (setq da (- y3 y1))) (abs (setq db (- y4 y1))))
(list 2 da nil nil (list 3 line1) (if (< db fuzz-jj) (list 4 line1)))
(list 2 db nil nil (list 4 line1) (if (< da fuzz-jj) (list 3 line1)))
)
(if (< x2 x3)
;;线2离开线1,线1上没有垂足
(progn
(setq pt (LINE:Perpendicular_Foot_1 p2 p3 p4))
(if (equal (distance p3 p4) (+ (distance pt p3) (distance pt p4)) fuzz)
;;p2到线2上垂距最短,省略了p1的计算
(list 2 (LINE:Perpendicular_Distance p2 p3 p4) nil nil (list p2 line2) nil)
;;两条线上均无垂足,比较斜距
(if (< (setq da (distance p2 p3)) (setq db (distance p2 p4)))
(list 1 da nil nil (list 2 3) (if (< db fuzz-jj) (list 2 4)))
(list 1 db nil nil (list 2 4) (if (< da fuzz-jj) (list 2 3)))
)
)
)
;;一个垂足在线1上,另一个在线2上
(if (< (setq da (LINE:Perpendicular_Distance p2 p3 p4)) (setq db (LINE:Perpendicular_Distance p3 p1 p2)))
(list 1 da nil nil (list 2 line2) (if (< db fuzz-jj) (list 3 line1)))
(list 1 db nil nil (list 3 line1) (if (< da fuzz-jj) (list 2 line2)))
)
)
)
)
)
)
)
)

(defun LINE:Distance_LineToLine_2d_i (p1 p2 p3 p4) 
  ;;两直线间最小间距及相关点坐标的索引 (0 1 2 3 4) 对应 (nil p1 p2 p3 p4) 
  ;;返回<img src="static/image/smiley/default/sad.gif" smilieid="2" border="0" alt="" />list 类型 距离 [交点1] [交点2] [[点1 [点2]/[线1]] [点3 [点4]/[线2]]]) 
  ;;距离0重合或点在线上 ,交点1是表是斜交点 ,垂距或平行间距 
  ;;线段长度不为0 p1/=p2 p3/=p4 
  ;;默认已做顺向处理x1 <= x2  x3<=x4 
  ;;以最左边的线变换坐标系. 
  (setq fuzz 1e-9 fuzz-jj 0.1) 
  (setq pts (list p1 p2 p3 p4)) 
  (and (> (car p1) (car p3)) (setq jiaoHuan T) (mapcar 'set '(p1 p2 p3 p4) (list p3 p4 p1 p2))) 
  (setq m (MAT:Rotation p1 (ang p1 p2))) 
  (setq lst (mapcar (function (lambda (x) (MAT:mxp m x))) (list p1 p2 p3 p4))) 
  (mapcar 'set '(p1 p2 p3 p4) lst) 
  (setq line1 (list 1 2) line2 (list 3 4)) 
  (mapcar 'set '(x1 y1 x2 y2 x3 y3 x4 y4) (apply 'append (list p1 p2 p3 p4))) 
  (setq k1 0) 
  (setq k2 (/ (- y3 y4) (if (equal x3 x4 fuzz) fuzz (- x3 x4)))) 
  ;;用斜率分 
  (setq lst 
    (if (equal k1 k2 fuzz) 
      (progn 
        ;;斜率相同 
        ;;用两线的垂直距离分 
        (setq dd (- y3 y2)) 
        (if (equal dd 0 fuzz) 
          (progn 
            ;;间距为0在同一条线上 
            (cond 
              ((equal x2 x3 fuzz) (list 6 0 2 nil (list 2 3) nil)) ;尾首相接 
              ((> x3 x2) (list 7 0 nil nil (list 2 3) nil)) ;离开 
              ((equal x1 x3 fuzz) 
                (cond 
                  ((equal x2 x4 fuzz) (list 8 0 1 2 nil nil)) ;完全重合 
                  ((< x2 x4) (list 9 0 2 nil (list 2 line2) nil)) ;有一个端点相同部分重合 
                  ((> x2 x4) (list 9 0 4 nil (list 4 line1) nil)) ;有一个端点相同部分重合 
                  (T (alert "未考虑到的情况1"))                
                ) 
              ) 
              ((< x3 x2 x4) (list 10 0 3 2 (list 2 line2) (list 3 line1))) ;部分重合 
              (T (alert "未考虑到的情况2")) 
            ) 
          ) 
          (progn 
            ;;两平行线 
            (cond 
              ((> x3 x2) (list 11 dd nil nil (list 2 3) nil)) ;平行离开 
              ((and (< x1 x3 x2) (> x4 x2)) (list 12 dd nil nil (list 2 line2) (list 3 line1))) ;平行,部分垂足在线上 
              ((< x1 x3 x2) (list 13 dd  nil nil (list 2 line2) (list 3 line1))) ;平行,包含 
              ((equal x2 x3) (list 14 dd  nil nil (list 2 3) nil)) ;直拐平行 
              ((and (equal x1 x3 fuzz) (equal x2 x4 fuzz)) (list 15 dd  nil nil (list 1 3) (list 2 4))) ;完全平行 
              (T (alert "未考虑到的情况3")) 
            ) 
          ) 
        ) 
      ) 
      (progn 
        ;;斜率不同 
        ;;用交点分 
        (if (setq int-pt (LINE:Intersection p1 p2 p3 p4)) 
          (progn 
            ;;有交点 
            (setq pt1 nil) 
            (if (equal int-pt p1 fuzz) 
              (setq pt1 1) 
              (if (equal int-pt p2 fuzz) 
                (setq pt1 2) 
              ) 
            ) 
            (setq pt2 nil) 
            (if (equal int-pt p3 fuzz) 
              (setq pt2 3) 
              (if (equal int-pt p4 fuzz) 
                (setq pt2 4) 
              ) 
            ) 
            (cond 
              ((and pt1 pt2) (list 3 0 pt1 nil (list pt1 pt2) nil)) ;两端点相接 
              (pt1 (list 4 0 pt1 nil (list pt1 line2) nil)) ;端点在2线上 
              (pt2 (list 4 0 pt2 nil (list pt2 line1) nil)) ;端点在1线上 
              ;;交点在两线中间. 
              (T (setq da (LINE:Perpendicular_Distance p3 p1 p2)) 
                (setq pt (LINE:Perpendicular_Foot_1 p2 p3 p4)) 
                (if (equal (distance p3 p4) (+ (distance pt p3) (distance pt p4)) fuzz) 
                  ;;p2到线2上有垂足 
                  (setq db (LINE:Perpendicular_Distance p2 p3 p4) tmp (list 2 line2)) 
                  ;;p2到线2上无垂足 
                  (setq db (LINE:Perpendicular_Distance p4 p1 p2) tmp (list 4 line1)) 
                ) 
                (if (<= da db) 
                  (list 5 da (list 1 2 3 4) nil (list 3 line1) tmp) 
                  (list 5 db (list 1 2 3 4) nil tmp (list 3 line1)) 
                ) 
              ) 
            ) 
          ) 
          (progn 
            ;;无交点 
            (if (<= x4 x2) 
              ;;x方向线1包含线2,线1上有2个垂足 
              (if (< (abs (setq da (- y3 y1))) (abs (setq db (- y4 y1)))) 
                (list 2 da nil nil (list 3 line1) (if (< db fuzz-jj) (list 4 line1))) 
                (list 2 db nil nil (list 4 line1) (if (< da fuzz-jj) (list 3 line1))) 
              ) 
              (if (< x2 x3) 
                ;;线2离开线1,线1上没有垂足 
                (progn 
                  (setq pt (LINE:Perpendicular_Foot_1 p2 p3 p4)) 
                  (if (equal (distance p3 p4) (+ (distance pt p3) (distance pt p4)) fuzz) 
                    ;;p2到线2上垂距最短,省略了p1的计算 
                    (list 2 (LINE:Perpendicular_Distance p2 p3 p4) nil nil (list p2 line2) nil) 
                    ;;两条线上均无垂足,比较斜距 
                    (if (< (setq da (distance p2 p3)) (setq db (distance p2 p4))) 
                      (list 1 da nil nil (list 2 3) (if (< db fuzz-jj) (list 2 4))) 
                      (list 1 db nil nil (list 2 4) (if (< da fuzz-jj) (list 2 3))) 
                    ) 
                  ) 
                ) 
                ;;一个垂足在线1上,另一个在线2上 
                (if (< (setq da (LINE:Perpendicular_Distance p2 p3 p4)) (setq db (LINE:Perpendicular_Distance p3 p1 p2))) 
                  (list 1 da nil nil (list 2 line2) (if (< db fuzz-jj) (list 3 line1))) 
                  (list 1 db nil nil (list 3 line1) (if (< da fuzz-jj) (list 2 line2))) 
                ) 
              ) 
            ) 
          ) 
        ) 
      ) 
    ) 
  )

树櫴希德 · 发表于 2020-12-28 21:27:52

收藏@wkq004[地形图程序首尾连接的多段线生成路径试多段线

(defun c:tt ()
(if (and (princ "\n选择起始线段")
(setq ss (ssget "+.:E:S" '((0 . "LWPOLYLINE") (-4 . "&=") (70 . 0))))
(setq e (ssname ss 0))
(setq el (entget e))
(setq pt (cadar (cdddr (car (ssnamex ss)))))
(setq pt (list (car pt) (cadr pt)))
(setq line (BF-curve-subsegment-picked-Points (vlax-ename->vla-object e) pt))
;;靠近起点或终点,中间搜索两端
(setq
a (distance pt (car line))
b (distance pt (cadr line))
)
(setq start (cdr (assoc 10 el)) end (cdr (assoc 10 (reverse el))))
(if (< 0.5 (/ a b) 2)
(setq ab (list (list start end) (list end start)))
(if (> b a)
(setq ab (list (list end start) nil))
(setq ab (list (list start end) nil))
)
)
(setq pt (cdr (assoc 10 el)))
(princ "\n 选择范围")
(setq ss (ssget '((0 . "LWPOLYLINE"))))
(setq lst (bf-pickset->list ss))
)
(progn
(setq lst (apply 'append (mapcar (function (lambda (x) (setq pts (mapcar 'cdr (vl-remove-if-not (function (lambda (x) (= 10 (car x)))) (entget x)))) (mapcar 'list pts (cdr pts)))) lst)))
(setq **lines lst) ;全局变量
(setq line (car ab))
(setq p**lines (fun line (list line)))
(vl-every (function (lambda (x)(ybl-mkpline-1 (append (mapcar (function (lambda (x) (car x))) x) (cdr (last x)))))) p**lines)
)
)
)
(vl-load-com)
(setq fuzz 1e-9)
(defun fun (line pline / new lst)
(setq b (cadr line))
(while **lines
(setq a (car **lines)
**lines (cdr **lines)
)
(cond
((equal b (car a) fuzz)
(setq lst (cons a lst))
)
((equal b (cadr a) fuzz)
(setq a (list (cadr a) (car a)))
(setq lst (cons a lst))
)
(T (setq new (cons a new)))
)
)
(setq **lines new)
(if lst
(apply 'append (mapcar (function (lambda (x) (fun x (append pline (list x))))) lst))
(list pline)
)
)
;(progn
; (setq lst-lst '())
; (setq **lines
; '(
; ((3 4) (5 6)) ;_第一条线
; ((3 4) (9 10))
; ((7 8) (3 4))
; ((5 6) (11 12))
; ((99 100) (11 12))
; ((99 100) (22 33))
; ((99 100) (44 55))
; )
; )
; (setq line '((1 2) (3 4)))
; (setq aa (fun line (list line)))
;;((((1 2) (3 4)) ((3 4) (7 8)))
;; (((1 2) (3 4)) ((3 4) (9 10)))
;; (((1 2) (3 4))
;; ((3 4) (5 6))
;; ((5 6) (11 12))
;; ((11 12) (99 100))
;; ((99 100) (22 33))
;; )
;; (((1 2) (3 4))
;; ((3 4) (5 6))
;; ((5 6) (11 12))
;; ((11 12) (99 100))
;; ((99 100) (44 55))
;; )
;;)
;
;)
(defun ybl-mkpline-1 (pts)
(if (entmake (append (list '(0 . "LWPOLYLINE")
'(100 . "AcDbEntity")
'(100 . "AcDbPolyline")
(cons 90 (length pts))
)
(mapcar '(lambda (x) (cons 10 x)) pts)
'((210 0. 0. 1.))
)
)
(entlast)
)
)
;;;======================================
;;;===========以下为内裤部分=============
;;;======================================
(defun BF-curve-subsegment-picked-Points (obj p)
(BF-curve-subsegment-points
obj
(fix
(vlax-curve-getParamAtPoint
obj
(vlax-curve-getClosestPointTo obj (trans p 1 0))
)
)
)
)
(defun BF-pickset->list (ss)
(vl-remove-if-not 'BF-enamep (mapcar 'cadr (ssnamex ss))))
(defun BF-curve-subsegment-points (curve n)
(list (vlax-curve-getPointAtParam curve (fix n))
(vlax-curve-getPointAtParam curve (1+ (fix n)))
)
)
(defun BF-enamep (arg) (equal (type arg) 'ename))

(defun c:tt () 
  (if (and (princ "\n选择起始线段") 
        (setq ss (ssget "+.:E:S" '((0 . "LWPOLYLINE") (-4 . "&=") (70 . 0)))) 
        (setq e (ssname ss 0)) 
        (setq el (entget e)) 
        (setq pt (cadar (cdddr (car (ssnamex ss))))) 
        (setq pt (list (car pt) (cadr pt))) 
        (setq line (BF-curve-subsegment-picked-Points (vlax-ename->vla-object e) pt)) 
        ;;靠近起点或终点,中间搜索两端 
        (setq 
          a (distance pt (car line)) 
          b (distance pt (cadr line)) 
        ) 
        (setq start (cdr (assoc 10 el)) end (cdr (assoc 10 (reverse el)))) 
        (if (< 0.5 (/ a b) 2) 
          (setq ab (list (list start end) (list end start))) 
          (if (> b a) 
            (setq ab (list (list end start) nil)) 
            (setq ab (list (list start end) nil)) 
          ) 
        ) 
        (setq pt (cdr (assoc 10 el))) 
        (princ "\n 选择范围") 
        (setq ss (ssget '((0 . "LWPOLYLINE")))) 
        (setq lst (bf-pickset->list ss)) 
      ) 
    (progn 
      (setq lst (apply 'append (mapcar (function (lambda (x) (setq pts (mapcar 'cdr (vl-remove-if-not (function (lambda (x) (= 10 (car x)))) (entget x)))) (mapcar 'list pts (cdr pts)))) lst))) 
      (setq **lines lst) ;全局变量 
      (setq line (car ab)) 
      (setq p**lines (fun line (list line))) 
      (vl-every (function (lambda (x)(ybl-mkpline-1 (append (mapcar (function (lambda (x) (car x))) x) (cdr (last x)))))) p**lines) 
    ) 
  ) 
) 
 
(vl-load-com) 
(setq fuzz 1e-9) 
(defun fun (line pline / new lst) 
  (setq b (cadr line)) 
  (while **lines 
    (setq a  (car **lines) 
      **lines  (cdr **lines) 
    ) 
    (cond 
      ((equal b (car a) fuzz) 
        (setq lst (cons a lst)) 
      ) 
      ((equal b (cadr a) fuzz) 
        (setq a (list (cadr a) (car a))) 
        (setq lst (cons a lst)) 
      ) 
      (T (setq new (cons a new))) 
    ) 
  ) 
  (setq **lines new) 
  (if lst 
    (apply 'append (mapcar (function (lambda (x) (fun x (append pline (list x))))) lst)) 
    (list pline) 
  ) 
) 
 
;(progn 
;  (setq lst-lst '()) 
;  (setq  **lines 
;   '( 
;     ((3 4) (5 6)) ;_第一条线 
;     ((3 4) (9 10)) 
;     ((7 8) (3 4)) 
;     ((5 6) (11 12)) 
;     ((99 100) (11 12)) 
;     ((99 100) (22 33)) 
;     ((99 100) (44 55)) 
;    ) 
;  ) 
;  (setq line '((1 2) (3 4))) 
;  (setq aa (fun line (list line))) 
;;((((1 2) (3 4)) ((3 4) (7 8))) 
;;  (((1 2) (3 4)) ((3 4) (9 10))) 
;;  (((1 2) (3 4)) 
;;    ((3 4) (5 6)) 
;;    ((5 6) (11 12)) 
;;    ((11 12) (99 100)) 
;;    ((99 100) (22 33)) 
;;  ) 
;;  (((1 2) (3 4)) 
;;    ((3 4) (5 6)) 
;;    ((5 6) (11 12)) 
;;    ((11 12) (99 100)) 
;;    ((99 100) (44 55)) 
;;  ) 
;;) 
; 
;) 
 
(defun ybl-mkpline-1 (pts) 
  (if (entmake (append (list '(0 . "LWPOLYLINE") 
           '(100 . "AcDbEntity") 
           '(100 . "AcDbPolyline") 
           (cons 90 (length pts)) 
           ) 
           (mapcar '(lambda (x) (cons 10 x)) pts) 
           '((210 0. 0. 1.)) 
         ) 
      ) 
    (entlast) 
  ) 
) 
 
 
 
 
 
;;;====================================== 
;;;===========以下为内裤部分============= 
;;;====================================== 
(defun BF-curve-subsegment-picked-Points (obj p) 
  (BF-curve-subsegment-points 
    obj 
    (fix 
      (vlax-curve-getParamAtPoint 
        obj 
        (vlax-curve-getClosestPointTo obj (trans p 1 0)) 
      ) 
    ) 
  ) 
) 
(defun BF-pickset->list (ss) 
  (vl-remove-if-not 'BF-enamep (mapcar 'cadr (ssnamex ss)))) 
(defun BF-curve-subsegment-points (curve n) 
  (list  (vlax-curve-getPointAtParam curve (fix n)) 
    (vlax-curve-getPointAtParam curve (1+ (fix n))) 
  ) 
) 
(defun BF-enamep (arg) (equal (type arg) 'ename))

czb203 · 发表于 2020-11-16 22:19:24

兄弟很久没出山了，最近在哪发财~

树櫴希德 · 发表于 2020-11-17 15:31:04

czb203 发表于 2020-11-16 22:19
兄弟很久没出山了，最近在哪发财~

kubi苦逼打工中

f4800 · 发表于 2020-11-17 23:47:50

大神一般不轻易发言。。。。。。。。。。

crtrccrt · 发表于 2020-11-18 09:44:24

本帖最后由 crtrccrt 于 2020-11-18 09:49 编辑

;; 1900年日期系统，作为起始点使用1900年1月1日计算日期。;
;; 1904年日期系统，作为起始点使用1904年1月1日计算日期。;
(BB-USING-vbs "Year(1)")==1899
(BB-USING-vbs "Month(1)")=12
(BB-USING-vbs "Day(1)")===31
????

日期格式	1900/1/1

常规格式	1

树櫴希德 · 发表于 2021-1-21 17:50:47

73ge哥程序快速切换布局和模型空间

(defun c:NM (/ *doc layouts i l ls)
(setq *doc(vla-get-ActiveDocument(vlax-get-acad-object)))
(setq layouts(vla-get-layouts *doc)l(vla-get-count layouts)i l)
(repeat l(setq ls(cons(vla-get-name(vla-item layouts(setq i(1- i))))ls)))
(setq i(VL-POSITION(vla-get-name(vla-get-ActiveLayout *doc))ls))
(while(getpoint)
(or(<(setq i(1+ i))l)(setq i 0))
(vla-put-ActiveLayout *doc(vla-item layouts i))
))

树櫴希德 · 发表于 2021-1-28 20:02:19

(defun plinexy(e / p a b n ob q et d d1 en et)
(setq a(entget e)ob(vlax-ename->vla-object e)et(cdr(assoc 0 a))n 0 p nil d nil)
(cond((="LWPOLYLINE"et)
(repeat(length a)(setq b (nth n a) n (+ n 1))
(if (= 10 (car b))(progn
(setq q(list (cadr b) (caddr b))d1(vlax-curve-getDistAtPoint ob q))
(if p (if (not(member d1 d)) (setq p (append p (list q))d (append d (list d1))))
(setq p (list q)))))))
((="POLYLINE"et)
(SETQ EN (ENTGET (SETQ E (ENTNEXT E))))
(WHILE (/= (CDR (ASSOC 0 EN)) "SEQEND")
(SETQ q (CDR (ASSOC 10 EN))d1(vlax-curve-getDistAtPoint ob q)q(reverse(cdr(reverse q))))
(if p(if (not(member d1 d)) (setq p (append p (list q))d (append d (list d1))))(setq p(list q)))
(SETQ EN (ENTGET (SETQ E (ENTNEXT E)))))
(setq p(reverse p))))P)
(defun pt2v(pt n);;坐标点表转为坐标数组
(setq pt(apply'append(if(= n 2)(mapcar'(lambda(x)(mapcar'+'(0 0)x))pt)pt)))
(vlax-make-variant(vlax-safearray-fill(vlax-make-safearray vlax-vbDouble(cons 0(1-(length pt))))pt)))
;(pt2v (plinexy(car(entsel)))3)

(defun plinexy(e / p a b n ob q et d d1 en et) 
    (setq a(entget e)ob(vlax-ename->vla-object e)et(cdr(assoc 0 a))n 0 p nil d nil) 
    (cond((="LWPOLYLINE"et) 
    (repeat(length a)(setq b (nth n a) n (+ n 1)) 
      (if (= 10 (car b))(progn 
        (setq q(list (cadr b) (caddr b))d1(vlax-curve-getDistAtPoint ob q)) 
        (if p (if (not(member d1 d)) (setq p (append p (list q))d (append d (list d1)))) 
          (setq p (list q))))))) 
   ((="POLYLINE"et) 
    (SETQ EN (ENTGET (SETQ E (ENTNEXT E)))) 
    (WHILE (/= (CDR (ASSOC 0 EN)) "SEQEND") 
      (SETQ q (CDR (ASSOC 10 EN))d1(vlax-curve-getDistAtPoint ob q)q(reverse(cdr(reverse q)))) 
      (if p(if (not(member d1 d)) (setq p (append p (list q))d (append d (list d1))))(setq p(list q))) 
      (SETQ EN (ENTGET (SETQ E (ENTNEXT E))))) 
    (setq p(reverse p))))P) 
 
(defun pt2v(pt n);;坐标点表转为坐标数组 
  (setq pt(apply'append(if(= n 2)(mapcar'(lambda(x)(mapcar'+'(0 0)x))pt)pt))) 
  (vlax-make-variant(vlax-safearray-fill(vlax-make-safearray vlax-vbDouble(cons 0(1-(length pt))))pt))) 
 
 
;(pt2v (plinexy(car(entsel)))3)

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

石必强大神函数excel数字日期转cad

相关帖子