石必强大神函数excel数字日期转cad
;【管理员】石必强(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)
收藏 替换字体 好多号函数;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:List-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:List-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))
)
(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 <= x2x3<=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 ddnil nil (list 2 line2) (list 3 line1))) ;平行,包含
((equal x2 x3) (list 14 ddnil nil (list 2 3) nil)) ;直拐平行
((and (equal x1 x3 fuzz) (equal x2 x4 fuzz)) (list 15 ddnil 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)))
)
)
)
)
)
)
)
)
收藏@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))
兄弟很久没出山了，最近在哪发财~ czb203 发表于 2020-11-16 22:19
兄弟很久没出山了，最近在哪发财~
kubi苦逼打工中 大神一般不轻易发言。。。。。。。。。。 本帖最后由 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
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))
))
(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)
页:
[1]
2