;;常用函数 收集：自贡黄明儒[face7.gif]
;;1 [功能] 检查加载vlisp扩展
(vl-Load-COM)
;;2 常数(lisp编辑器在输出局部变量时,带*的会排在前面.Caoyin这样写很有道理)
(setq *En2Obj*
vlax-ename->vla-object
*Obj2En*
vlax-vla-object->ename
*2PI* (* PI 2)
*0.5PI* (/ PI 2)
*0.25PI* (/
PI 4)
;;常用VLA对象、集合
*ACAD*
(vlax-get-acad-object)
*DOC*
(vla-get-ActiveDocument *ACAD*)
*DOCS*
(vla-get-Documents *ACAD*)
*MS* (vla-get-modelSpace
*DOC*)
*PS*
(vla-get-paperSpace *DOC*)
*BLKS*
(vla-get-Blocks *DOC*)
*LAYS*
(vla-get-Layers *DOC*)
*LTS*
(vla-get-Linetypes *DOC*)
*STS*
(vla-get-TextStyles *DOC*)
*GRPS*
(vla-get-groups *DOC*)
*DIMS*
(vla-get-DimStyles *DOC*)
*LOUTS*
(vla-get-Layouts *DOC*)
*VPS*
(vla-get-Viewports *DOC*)
*VS* (vla-get-Views *DOC*)
*DICS* (vla-get-Dictionaries *DOC*)
;;常用的几个外部接口对象
*FSO*
(vlax-get-or-create-object
"Scripting.FileSystemObject")
*WSH* (vlax-get-or-create-object
"wscript.shell")
*SHELL*
(vlax-get-or-create-object
"Shell.Application")
*SCR*
(vlax-get-or-create-object "ScriptControl")
*WBEM* (vlax-get-or-create-object "WbemScripting.SWbemLocator")
)
;;3 [功能] 返回活动空间vla对象
(defun MJ:ActiveSpace()
(if (= 1
(vlax-get-Property *DOC* 'ActiveSpace));模型1,布局0
*MS*
*PS*
)
)
;;4.1 [功能] 返回当前活动空间名称("Model" or "Paper")
(defun MJ:ActiveSpace-Name
()
(if (= 1 (vla-get-ActiveSpace *DOC*))
"Model"
"Paper"
)
)
;;4.2 [功能]
返回空间名称,如"Model"或者"Layout1"...
(defun MJ:ActiveSpace1 ()
(vla-get-Name (vla-get-ActiveLayout *DOC*))
)
;;5 [功能] 返回Preferences vla对象
(defun MJ:AcadPrefs ()
(vlax-Get-Property *ACAD* 'Preferences)
)
;;6 [功能]
返回指定引用的属性
;;TabName:Application,Display,Drafting,Files,OpenSave,Output,Profiles,Selection,System,User
;;
示例 (MJ:GetPrefKey 'Files 'SupportPath) 获取支持文件路径
(defun
MJ:GetPrefKey (TabName KeyName)
(vlax-get-property
(vlax-get-property (MJ:AcadPrefs)
TabName)
KeyName
)
)
;;7 [功能] 更改引用设置
;; 示例 (MJ:SetPrefKey "OpenSave" "IncrementalSavePercent"
0)
(defun MJ:SetPrefKey (TabName KeyName NewVal)
(vlax-put-property
(vlax-get-property (MJ:AcadPrefs)
TabName)
KeyName
NewVal
)
)
;;8 [功能] 返回
acad对象的属性
;;PropName:ActiveDocument,Application,Caption,Documents,FullName,Height,HWND,LocaleId,MenuBar,
;;MenuGroups,Name,Path,Preferences,StatusId,VBE,Version,Visible,Width,WindowLeft,WindowState,WindowTop
;; 示例 (MJ:AcadProp 'FullName)
(defun MJ:AcadProp (PropName)
(vlax-get-property *ACAD* PropName)
)
;;9 [功能] 对象名称
;; 示例 (MJ:Name *ACAD*) returns "AutoCAD"
;; 示例 (MJ:Name
*MS*)返回"*Model_Space"
(defun MJ:Name (obj)
(if
(vlax-property-available-p obj 'Name)
(vlax-get-property
obj 'Name)
"<NONE_NAME>"
)
)
;;10.1 [功能] 打开文件名列表(见95)
;;verbose:T,nil
;; 示例: (MJ:DocsList T)
;;
NOTES: Verbose为T时full path+filename ; nil时filenames
(defun MJ:DocsList
(verbose / docname out)
(vlax-for each
*DOCS*
(if verbose
(setq docname
(strcat
(vlax-get-property each
'Path)
"\\"
(MJ:Name
each)
)
)
(setq docname (MJ:Name
each))
)
(setq out (cons docname
out))
)
(reverse out)
)
;;10.2 [功能] (打开文件
未打开文件)列表
;;示例(car (MJ:DocsList1 DwgFileLst))取得列表文件中打开的文件列表
(defun
MJ:DocsList1 (DwgFileLst / NOTOPENED OPENED)
(setq Opened
(vl-remove-if 'VL-FILE-SYSTIME DwgFileLst)
notOpened
(vl-remove-if-not 'VL-FILE-SYSTIME DwgFileLst)
)
(list Opened notOpened)
)
;;11 [功能] 查询对象属性和方法(见20.1)
(defun C:HHDump (/ ent)
(while (setq
ent (entsel))
(vlax-Dump-Object
(vlax-Ename->Vla-Object
(car ent))
)
)
(princ)
)
;;12 [功能] 设置 Qleader 命令"引线设置"对话框的相关参数
;;注：<font
color=\"red\">引线的箭头跟DIMSTYLE使用同一设置，可以直接修改DIMLDRBLK系统变量</font>
;;2011.5.5
by caoyin
(defun QleaderSet (/ DICEN)
(setq DICEN
(namedobjdict));(enget DICEN)可查看内容(3 . 词典)
(if (dictsearch DICEN
"AcadDim")
(dictremove DICEN "AcadDim")
)
(dictadd
DICEN
"AcadDim"
(entmakex '((0 .
"XRECORD")
(100 .
"AcDbXrecord")
(280 .
1)
(90 .
990106)
(3 . "");;-----引线和箭头-〉箭头[用户箭头的缺省块名，""则表示未设置]
(60 . 0);;-----注释-〉注释类型[0,1,2,3,4]
(61 . 0);;-----注释-〉重复使用注释[0,1,2]
(62 . 1);;-----附着-〉文字在右边[0,1,2,3,4]
(63 . 1);;-----附着-〉文字在左边[0,1,2,3,4]
(64 . 0);;-----附着-〉最后一行加下划线[0,1]
(65 . 0);;-----引线和箭头-〉引线[0,1]
(66 . 0);;-----引线和箭头-〉点数-〉无限制[0,1]
(67 . 3);;-----引线和箭头-〉点数[任意正整数]
(68 . 1);;-----注释-〉多行文字选项-〉提示输入宽度[0,1]
(69 . 0);;-----注释-〉多行文字选项-〉始终左对齐[0,1]
(70 . 0);;-----引线和箭头-〉角度约束->第一段[0,1,2,3,4,5]
(71 . 0);;-----引线和箭头-〉角度约束->第二段[0,1,2,3,4,5]
(72 . 0);;-----注释-〉多行文字选项-〉文字边框[0,1]
(40 .
0.0)
(170 . 2);;----控制"引线设置"对话框的缺省选项卡[0,1,2]
;; (340 .
图元名)
;;-----当DXF组码60的值为3，且已经设定了块参照的块名，则340组码才会出现
;;-----格式为(340 . 上次使用块参照作为注释对象，实际插入的块实例的图元名)
)
)
)
)
;;13 [功能] 求点集中最远，最近点表 By 无痕(见178)
;:(最远两点 最近两点)
;;示例(MJ:lensort
(while (setq pt(getpoint)) (setq plst (cons pt plst)))))
;;(((14857.8
-599.932 0.0) (26695.2 -3687.68 0.0)) ((15733.8 -3687.68 0.0) (15630.7 -3842.07
0.0)))
(defun MJ:lensort (ptlst / pt d maxd mind maxl minl)
(setq minl (list (car ptlst) (cadr ptlst))
maxd 0
mind
(apply 'distance minl)
)
(while (setq pt
(car ptlst)
ptlst (cdr
ptlst)
)
(foreach n
ptlst
(setq d (distance n
pt))
(cond ((< maxd
d)
(setq
maxd d
maxl (list n
pt)
)
)
((> mind d)
(setq mind d
minl (list n
pt)
)
)
)
)
)
(list maxl minl)
)
;;14.1 [功能] 返回指定集合的数量
;; 示例: (MJ:CollectionCount
(MJ:GetLayers)))
(defun MJ:CollectionCount (Collection)
(vlax-get-property Collection 'Count)
)
;;14.2 [功能] 返回文档集合的数量
(defun
MJ:DocsCount ()
(vlax-get-property *DOCS* 'Count)
)
;;15 [功能]
返回文档指定对象的属性
;;Cname:
Active,ActiveDimStyle,ActiveLayer,ActiveLayout,ActiveLinetype,ActivePViewport,ActiveSelectionSet,
;;ActiveSpace,ActiveTextStyle,ActiveUCS,ActiveViewport,Application,Blocks,Database,Dictionaries,DimStyles,
;;ElevationModelSpace,ElevationPaperSpace,FileDependencies,FullName,Groups,Height,HWND,Layers,Layouts,Limits,
;;Linetypes,ModelSpace,MSpace,
Name,ObjectSnapMode,PaperSpace,Path,PickfirstSelectionSet,Plot,PlotConfigurations,
;;Preferences,ReadOnly,RegisteredApplications,Saved,SelectionSets,SummaryInfo,TextStyles,UserCoordinateSystems,Utility,
;;Viewports,Views,Width,WindowState,WindowTitle
;;示例
(MJ:DocCollection "WindowState")
(defun MJ:DocCollection (Cname)
(vlax-Get-Property *DOC* Cname)
)
;;15.1 [功能] 图层集合
(defun MJ:GetLayers
() (vlax-Get-Property *DOC* 'Layers))
;;15.2 [功能] 线型集合
(defun MJ:GetLtypes
() (vlax-Get-Property *DOC* 'Linetypes))
;;15.3 [功能] 文字样式集合
(defun
MJ:GetTextStyles () (vlax-Get-Property *DOC* 'TextStyles))
;;15.4 [功能]
尺寸样式集合
(defun MJ:GetDimStyles () (vlax-Get-Property *DOC*
'DimStyles))
;;15.5 [功能] 布局集合
(defun MJ:GetLayouts () (vlax-Get-Property
*DOC* 'Layouts))
;;15.6 [功能] 词典集合
(defun MJ:GetDictionaries ()
(vlax-Get-Property *DOC* 'Dictionaries))
;;15.7 [功能]
块集合(不是我们平时绘图时所说的块)
(defun MJ:GetBlocks () (vlax-Get-Property *DOC*
'Blocks))
;;15.8 [功能] 打印配置集合
(defun MJ:GetPlotConfigs ()(vlax-Get-Property
*DOC* 'PlotConfigurations))
;;15.9 [功能] 视图集合
(defun MJ:GetViews ()
(vlax-Get-Property *DOC* 'Views))
;;15.10 [功能] 视口集合
(defun MJ:GetViewports
() (vlax-Get-Property *DOC* 'Viewports))
;;15.11 [功能] 组集合
(defun
MJ:GetGroups () (vlax-Get-Property *DOC* 'Groups))
;;15.12 [功能]
注册程序集合
(defun MJ:GetRegApps () (vlax-Get-Property *DOC*
'RegisteredApplications))
;;16 [功能] 返回集合成员名称列表
;;示例 (MJ:ListCollectionMemberNames
(MJ:GetLayers))返回:图层列表("0" "中心线" "文字" "DIM")
(defun
MJ:ListCollectionMemberNames (collection / out)
(vlax-for each
collection
(setq out (cons (MJ:Name each) out))
)
(reverse out)
)
;;16.1 [功能] 返回线型集合成员名称列表(常量*LTS*)
(defun
MJ:ListLtypes ()
(MJ:ListCollectionMemberNames (vlax-Get-Property
*DOC* 'Linetypes))
)
;;16.2 [功能] 图层列表(常量*LAYS*)
;;示例("0" "中心线" "文字"
"DIM")
(defun MJ:ListLayers ()
(MJ:ListCollectionMemberNames
(vlax-Get-Property *DOC* 'Layers))
)
;;16.3 [功能]
返回文字样式集合成员名称列表(常量*STS*)
(defun MJ:ListTextStyles ()
(MJ:ListCollectionMemberNames (vlax-Get-Property *DOC*
'TextStyles))
)
;;16.4 [功能] 返回尺寸样式集合成员名称列表
(defun MJ:ListDimStyles
()
(MJ:ListCollectionMemberNames *DIMS*)
)
;;16.5 [功能]
返回布局集合成员名称列表
(defun MJ:ListLayouts ()
(MJ:ListCollectionMemberNames *LOUTS*)
)
;;16.6 [功能]
返回词典集合成员名称列表
(defun MJ:ListDictionaries ()
(MJ:ListCollectionMemberNames *DICS*)
)
;;16.7 [功能] 返回块集合成员名称列表
(defun
MJ:ListBlocks ()
(MJ:ListCollectionMemberNames *BLKS*)
)
;;16.8
[功能] 返回打印配置集合成员名称列表
(defun MJ:ListPlotConfigs ()
(MJ:ListCollectionMemberNames (MJ:GetPlotConfigs))
)
;;16.9 [功能]
返回视图集合成员名称列表
(defun MJ:ListViews ()
(MJ:ListCollectionMemberNames
(MJ:GetViews))
)
;;16.10 [功能] 返回视口集合成员名称列表(同常量*VPS*)
(defun
MJ:ListViewPorts ()
(MJ:ListCollectionMemberNames
(MJ:GetViewports))
)
;;16.11 [功能] 返回组集合成员名称列表
(defun MJ:ListGroups
()
(MJ:ListCollectionMemberNames (MJ:GetGroups))
)
;;16.12 [功能]
返回注册程序集合成员名称列表
(defun MJ:ListRegApps ()
(MJ:ListCollectionMemberNames (MJ:GetRegApps))
)
;;17 [功能] 点表排序(141差)
;;ssPts: 1 选择集，返回图元列表
;; 2 点表(1到n维
1维时key只能是x或X)，返回点表
;; 3
图元列表，返回图元列表
;; 4 字符列表或者数值列表
;;Key:
"xyzXYZ"任意组合,例如"yX",y在前表示y坐标优先，小y表示从小到大(注:二维点时，不能有z)
;;FUZZ:
允许误差
;;注:点表可以1到n维混合,Key长度不大于点的最小维数。
;;示例1 (HH:ssPts:Sort (ssget) "YxZ"
0.5);返回(<Entity name: 7ef7b3a8> <Entity name: 7ef7b3a0>)
;;示例2
(HH:ssPts:Sort (list '(2 3) '(3 5)) "Yx" 0.5);返回((3 5) (2 3))
;;示例3
(HH:ssPts:Sort '(<Entity name: 7ef79a28> <Entity name: 7ef79a10>)
"YxZ" 0.5)
;;示例4 (HH:ssPts:Sort (list "DF" "ZX" "A" "DD" "A") "X"
1)=>("ZX" "DF" "DD" "A" "A")
;;示例5 (HH:ssPts:Sort (list 5 8 5.0 9 5) "X"
1)=>(9 8 5 5.0)
;;本程序是在fsxm的扩展 自贡黄明儒 2014年3月22日
(defun HH:ssPts:Sort
(ssPts KEY FUZZ / E EN FUN LST N)
;;1 点列表排序
(defun sortpts
(PTS FUN xyz FUZZ)
(vl-sort
pts
'(lambda (a b)
(if (not
(equal (xyz a) (xyz b) fuzz))
(fun (xyz a) (xyz
b))
)
)
)
)
;;2 排序先后
(defun
sortpts1 (PTS KEY FUZZ)
(setq Key (vl-string->list
Key))
(foreach xyz (reverse
Key)
(cond ((< xyz
100)
(setq fun
>)
(setq xyz (nth (- xyz 88) (list car cadr
caddr)))
)
(T
(setq fun
<)
(setq xyz (nth (- xyz 120) (list car
cadr caddr)))
)
)
(setq Pts (sortpts Pts fun xyz
fuzz))
)
)
;;3 本程序主程序
(cond
((= (type ssPts)
'PICKSET)
(repeat (setq n (sslength
ssPts))
(if (and (setq e (ssname
ssPts (setq n (1- n))))
(setq en (entget
e))
)
(setq lst (cons (append (cdr (assoc 10
en)) (list e)) lst))
)
)
(mapcar 'last
(sortpts1 lst KEY FUZZ))
)
((Listp
ssPts)
(cond
((vl-consp (car ssPts))
(sortpts1 ssPts KEY FUZZ))
((= (type (car ssPts)) 'ENAME)
(foreach e ssPts
(if (setq en (entget
e))
(setq lst (cons (append (cdr (assoc 10
en)) (list e)) lst))
)
)
(mapcar 'last
(sortpts1 lst KEY FUZZ))
)
(T
(cond ((equal key "X")
(vl-sort ssPts '>))
((equal key
"x") (vl-sort ssPts '<))
)
)
)
)
)
)
;;18 [功能] 集合->列表
;; 示例: (MJ:CollectionList (MJ:GetLtypes))
返回:线性列表
(defun MJ:CollectionList (Collection / name out)
(vlax-for each Collection
(setq name (MJ:Name
each))
(setq out (cons name out))
)
(reverse out)
)
;;19 [功能] 线型数量
(defun MJ:CountLtypes ()
(MJ:CollectionCount
(vlax-Get-Property *DOC* 'Linetypes))
)
;;20 [功能] 对集合对象的每个成员执行指定函数的操作
;; 示例: (MJ:MapCollection all-arcs
'MJ:DeleteObject)
(defun MJ:MapCollection (Collection qFunction)
(vlax-map-collection Collection qFunction)
)
;;20.1 [功能]
显示集合对象每个成员的方法和属性.既然是集合,方法是相同的(见11)
;; 示例: (MJ:DumpCollection
(MJ:GetLayers))
(defun MJ:DumpCollection (Collection)
(MJ:MapCollection Collection 'vlax-dump-object)
)
;;20.2 [功能] 删除对象
;;
示例: (MJ:DeleteObject arc-object1)
(defun MJ:DeleteObject (obj)
(cond
((and
(not (vlax-erased-p
obj));存在
(vlax-read-enabled-p
obj);可读
(vlax-write-enabled-p
obj);可写
)
(vlax-invoke-method obj 'Delete)
(cond ((not
(vlax-object-released-p obj)) (vlax-release-object obj)))
;释放
)
(T
(princ "\nCannot delete object!"))
)
)
;;21.1 [功能] ename->vla对象
;; 示例: (MJ:MakeObject (car
(entsel)))
(defun MJ:MakeObject (e)
(cond
((=
(type e) 'ENAME) (vlax-ename->vla-object e))
((= (type
e) 'VLA-OBJECT) e)
)
)
;;21.2 [功能] vla对象->ename
(defun
MJ:MakeEname (obj)
(cond ((equal (type obj) 'vla-object)
(vlax-vla-object->ename obj))
(T obj)
)
)
;;22 [功能] 返回对象名称(见9)
;; 示例: (= "AcDbArc" (MJ:ObjectType
MJ:object))
(defun MJ:ObjectType (obj)
(vlax-get-property obj
'ObjectName)
)
;;23.1 编组开始;(command "_.undo" "be")
(defun _StartUndo (*DOC*)
(_EndUndo *DOC*)
(vla-StartUndoMark *DOC*)
)
;;23.2 结束编组;(if (=
8 (logand (getvar "undoctl") 8)) (command "_.undo" "_e"))
(defun
_EndUndo (*DOC*)
(cond((= 8 (logand 8 (getvar
'UNDOCTL)))(vla-EndUndoMark *DOC*)))
)
;;24 [功能] 用一个对象的属性等修改另一个对象的属性
;;示例(setq source (MJ:MakeObject(car
(entsel))) target (MJ:MakeObject(car (entsel))))
;; (MJ:CopyProp "Layer"
source target)用一个对象的图层等修改另一个对象的图层等
(defun MJ:CopyProp (propName source
target)
(cond
((member (strcase
propName)
'("LAYER"
"LINETYPE"
"COLOR"
"LINETYPESCALE"
"LINEWEIGHT"
"PLOTSTYLENAME"
"ELEVATION"
"THICKNESS"
)
)
(cond
((and
(not
(vlax-erased-p source));存在
(not (vlax-erased-p
target));存在
(vlax-read-enabled-p source);可读
(vlax-write-enabled-p
target);可写
)
(vlax-put-property
target
propName
(vlax-get-property source
propName);修改
)
)
(T (princ "\n
One or more objects inaccessible!"))
)
)
(T (princ "\n Invalid
property-key request!"))
)
)
;;24.1 [功能] 用一个对象的'(图层 线型...)修改另一个对象的图层 线型...等
;; 示例: (MJ:MapPropertyList
'("Layer" "Color") arc-object1 arc-object2
(defun MJ:MapPropertyList
(propList source target)
(foreach
prop propList
(MJ:CopyProp prop source
target)
)
)
;;25.1 [功能] 配置文件集合
(defun MJ:Profiles ()
(vla-get-Profiles
(MJ:AcadPrefs))
)
;;25.2 [功能] 设置配置文件
;; 示例: (MJ:SetProfile
"MJ:Profile")
(defun MJ:SetProfile (pname)
(vla-put-ActiveProfile
(vla-get-Profiles
(vla-get-Preferences *ACAD*))
pname
)
)
;;25.3 [功能] 重新装载配置文件
;; 示例: (MJ:ProfileReLoad "profile1"
"c:\\profiles\\profile1.arg")
(defun MJ:ProfileReLoad (name
ARGname)
(cond
((= (vlax-get-property
(MJ:Profiles) 'ActiveProfile) name)
;; or following
code.
;;(= (vla-get-ActiveProfile (MJ:Profiles))
name)
(princ "\nCannot delete a profile that is in
use.")
)
((and
(MJ:ProfileExists-p
name)
(findfile
ARGname)
)
(MJ:ProfileDelete name)
(MJ:ProfileImport name
ARGname)
(vla-put-ActiveProfile (MJ:Profiles)
name)
)
((and
(not (MJ:ProfileExists-p
name))
(findfile
ARGname)
)
(MJ:ProfileImport name ARGname)
(vla-put-ActiveProfile (MJ:Profiles) name)
)
((not (findfile ARGname))
(princ (strcat "\nCannot locate ARG source: " ARGname))
)
)
)
;;25.4 [功能] 重启默认配置文件
;; 示例: (MJ:ProfileReset
"profile1")
(defun MJ:ProfileReset (strName)
(if
(MJ:ProfileExists-p strName)
(vlax-Invoke-Method
(MJ:Profiles)
'ResetProfile
strName
)
(princ (strcat "\nProfile [" strName "] does not
exist."))
)
)
;;25.5 [功能] 输出配置文件
;; ARGS: arg-file(string),
profile-name(string), T(Boolean)
;; 示例: (MJ:ProfileExport "<<Unnamed
Profile>>" "D:/test.arg" T)
(defun MJ:ProfileExport (strName
strFilename BooleReplace)
(if (MJ:ProfileExists-p
strName)
(if (not (findfile
strFilename))
(progn
(vlax-Invoke-Method
(vlax-Get-Property
(MJ:AcadPrefs) "Profiles")
'ExportProfile
strName
strFilename
)
T
)
(if
BooleReplace
(progn
(vl-file-delete (findfile
strFilename))
(if (not (findfile
strFilename))
(progn
(vlax-Invoke-Method
(vlax-Get-Property (MJ:AcadPrefs)
"Profiles")
'ExportProfile
strName
strFilename
)
T
)
(princ "\nCannot replace ARG file, aborted.")
)
)
(princ (strcat "\n"
strFilename " already exists,
aborted.")
)
)
)
)
)
;;25.6
[功能] 输出配置文件
;; NOTES: Export an existing profile to a new external .ARG file
;; 示例: (MJ:ProfileExportX "<<Unnamed Profile>>"
"D:/test1.arg")
(defun MJ:ProfileExportX (pName ARGfile)
(cond
((MJ:ProfileExists-p
pName)
(vlax-invoke-method
(MJ:Profiles)
'ExportProfile
pName
ARGfile
(vlax-make-variant 1
:vlax-vbBoolean)
;; ==
TRUE
)
)
(T (princ "\nNo such profile exists to export."))
)
)
;;25.7
[功能] 输入配置文件
;; ARGS: profile-name(string), arg-file(string)
;; 示例:
(MJ:ProfileImport "MJ:Profile" "c:/test.arg")
;; VBA
equivalent:
;;
;;
ThisDrawing.Application.preferences._
;;
;; Profiles.ImportProfile
_
;;
;; strProfileToImport,
strARGFileSource, True
;;
(defun MJ:ProfileImport (pName ARGfile)
(cond
((findfile ARGfile)
(vlax-invoke-method
(vlax-get-property
(MJ:AcadPrefs) "Profiles")
'ImportProfile
pName
ARGfile
(vlax-make-variant 1
:vlax-vbBoolean)
;; ==
TRUE
)
) ;
(T (princ "\nARG file not
found to import!"))
)
)
;;25.8 [功能]
复制配置文件
;; 示例: (MJ:ProfileCopy pName newName)
(defun
MJ:ProfileCopy (Name1 Name2)
(cond
((and
(MJ:ProfileExists-p
Name1)
(not (MJ:ProfileExists-p
Name2))
)
(vlax-invoke-method
(MJ:Profiles)
'CopyProfile
Name1
Name2
)
) ;
((not (MJ:ProfileExists-p Name1))
(princ "\nError:
No such profile exists.")
) ;
((MJ:ProfileExists-p
Name2)
(princ "\nProfile already exists, copy
failed.")
)
)
)
;;25.9 [功能] 重命名配置文件
;;
示例: (MJ:ProfileRename oldName newName)
(defun MJ:ProfileRename (oldName
newName)
(cond
((and
(MJ:ProfileExists-p
oldName)
(not (MJ:ProfileExists-p
newName))
)
(vlax-invoke-method
(MJ:Profiles)
'RenameProfile
oldName
newName
)
)
(T (princ))
;; add
your error handling here?
)
)
;;25.10 [功能] 删除配置文件
;; 示例:
(MJ:ProfileDelete "MJ:Profile")
(defun MJ:ProfileDelete (pName)
(vlax-invoke-method
(vlax-get-property (MJ:AcadPrefs)
"Profiles")
'DeleteProfile
pName
)
)
;;25.11 [功能] 配置文件是否存在
;; 示例: (if
(MJ:ProfileExists-p "<<Unnamed Profile>>") ...)
(defun
MJ:ProfileExists-p (pName)
(member (strcase pName) (mapcar 'strcase
(MJ:ProfileList)))
)
;;25.12 [功能] 配置文件列表
;;返回示例("<<Unnamed
Profile>>" "yky_m2006")
(defun MJ:ProfileList (/ hold)
(vlax-invoke-method
(vlax-get-property (MJ:AcadPrefs)
"Profiles")
'GetAllProfileNames
'hold
)
(cond (hold (vlax-safearray->list
hold)))
)
;;26.1 [功能] 非当前文档,关闭(不保存)
;; Author: Frank
Whaley
(defun MJ:CloseAll (/ item cur)
(vlax-for item
*DOCS*
(if (= (vla-get-active item)
:vlax-false)
(vla-close item
:vlax-false)
(setq cur
item)
)
)
;;(vla-sendcommand
cur "_.CLOSE")
(command "vbastmt"
"AcadApplication.activeDocument.close false ");关闭当前文档
)
;;27.1 [功能] 保存所有文档
(defun MJ:SaveAllDocs (/ item)
(vlax-for
item *DOCS*
(vla-save item)
)
)
;;27.2 [功能] 活动文档是否已经保存?
(defun MJ:Saved-p ()
(= (vla-get-saved
*DOC*) :vlax-True)
)
;;acR12_DXF,AutoCAD Release12/LT2 DXF (*.dxf)
;;ac2000_dwg,AutoCAD 2000
DWG (*.dwg)
;;ac2000_dxf,AutoCAD 2000 DXF
(*.dxf)
;;ac2000_Template,AutoCAD 2000 Drawing Template File
(*.dwt)
;;ac2004_dwg,AutoCAD 2004 DWG (*.dwg)
;;ac2004_dxf,AutoCAD 2004
DXF (*.dxf)
;;ac2004_Template,AutoCAD 2004 Drawing Template File
(*.dwt)
;;acNative,A synonym for the current drawing release
format
;;AcUnknown,Read-only. The drawing type is unknown or
invalid.
;;27.3 [功能] 另存为2K格式
(defun MJ:SaveAs2000 (name)
(vla-saveas *DOC* name acR15_DWG)
)
;;27.4 [功能] 另存为R14格式
(defun
MJ:SaveAsR14 (name)
(vla-saveas *DOC* name acR14_DWG)
)
;;28.1 [功能] 清理打开文档
(defun MJ:PurgeAllDocs (/ item cur)
(vlax-for
item *DOCS*
(vla-PurgeAll item)
)
)
;;28.2
[功能] 删除未使用的图层,比purge彻底
(defun MJ:LayerDelete ()
(vl-Load-Com)
(vl-Catch-All-Apply
'(lambda
()
(vla-Remove
(vla-GetExtensionDictionary
(vla-Get-Layers
*DOC*
)
)
"ACAD_LAYERFILTERS"
)
)
)
(princ)
)
;;29.1 [功能] 取得选定块的指定属性
;; (MJ:GetTagTextStringByRef (*En2Obj* (car
(entsel))) "设计")
(defun MJ:GetTagTextStringByRef (br tagname / atts tag
str)
(if (and
(= (vla-get-hasattributes br)
:vlax-true)
(safearray-value
(setq atts
(vlax-variant-value
(vla-getattributes br)
)
)
)
)
(foreach
tag (vlax-safearray->list atts)
(if (=
(strcase tagname) (strcase (vla-get-tagstring tag)))
(setq str
(vla-get-TextString tag))
)
)
)
str
)
;;29.2 [功能] 取得块属性列表
;(MJ:GetAttributes (car (entsel)))取得属性列表(("比例" . "")
("材料" . "Q235"))
(defun MJ:GetAttributes (ent / blkref lst)
(if (=
(vla-Get-ObjectName
(setq blkref
(vlax-Ename->vla-Object ent))
)
"AcDbBlockReference"
)
(if (vla-Get-HasAttributes blkref)
(mapcar
'(lambda (x)
(setq
lst (cons
(cons (vla-Get-TagString x) (vla-Get-TextString x))
lst
)
)
)
(vlax-safearray->list
(vlax-variant-value
(vla-GetAttributes blkref))
)
)
)
)
(reverse lst)
)
;;29.3 [功能] [功能]
取得块属性列表
;; 示例: (MJ:GetAttributes (car (entsel))返回(("比例" ""
<Entity name: 7efd2ad0>)(...))
(defun MJ:GetAttributes (ent /
lst)
(if (safearray-value
(setq
lst
(vlax-variant-value
(vla-getattributes
(vlax-ename->vla-object
ent)
)
)
)
)
(mapcar
'(lambda (x)
(list
(vla-get-tagstring x)
(vla-get-textstring x)
(*Obj2En* x)
)
)
(vlax-safearray->list lst)
)
)
)
;;29.4
[功能] Returns a list of constant attributes tags and their values
;;
示例: (MJ:GetConstantAttributes (car (entsel)))
(defun
MJ:GetConstantAttributes (ent / atts)
(vl-load-com)
(cond
((and (safearray-value
(setq atts
(vlax-variant-value
(vla-getconstantattributes
(vlax-ename->vla-object ent)
)
)
)
)
)
(mapcar
'(lambda (x)
(cons (vla-get-tagstring x)
(vla-get-textstring x))
)
(vlax-safearray->list atts)
)
) ;
(T
(princ
(strcat
"\nThe block reference \""
(vla-get-Name
(vlax-ename->vla-object ent))
"\" doesn't include constant
attributes tags and their values"
)
)
)
)
)
;;30.1 [功能] 更改块指定属性
;; (MJ:PutTagTextString "块名" tagname "new
value")
(defun MJ:PutTagTextString
(bn
tagname textstring / layout i atts tag)
(vlax-for layout
*LOUTS*
(vlax-for i (vla-get-block
layout)
(if (and
(= (vla-get-objectname i) "AcDbBlockReference")
(=
(strcase (vla-get-name i)) (strcase bn))
)
(if
(and
(= (vla-get-hasattributes i)
:vlax-true)
(safearray-value
(setq
atts
(vlax-variant-value
(vla-getattributes
i)
)
)
)
)
(foreach tag
(vlax-safearray->list atts)
(if (= (strcase
tagname) (strcase (vla-get-tagstring
tag)))
(vla-put-TextString tag
textstring)
)
)
(vla-update i)
)
)
)
)
)
;;30.2 [功能] 块的属性值改为新值---纯lisp法 by
自贡黄明儒
;;示例(attchg (car (entsel)) "设计" "aaa")
(defun attchg (ent attname
new / EN ENTLIST)
(defun MJ:DXF (IT LST)
(cdr (assoc IT LST))
)
(if (and (setq en
ent)
(setq entlist (entget en))
(equal (MJ:DXF 0 entlist) "INSERT")
(equal (MJ:DXF 66
entlist) 1) ;=1则块有属性值
)
(while (and en
(setq en (entnext en))
(setq
entlist (entget en))
(equal (MJ:DXF 0 entlist)
"ATTRIB")
)
(if (=
(strcase (MJ:DXF 2 entlist)) (strcase attname))
(progn (entmod (subst
(cons 1 new) (assoc 1 entlist)
entlist))
(entupd
ent)
(setq en
nil)
)
)
)
)
(princ)
)
;;30.3 [功能] 更改选定块的指定属性
;;
(MJ:PutTagTextStringByRef (*En2Obj* (car (entsel))) "设计" "new value")
(defun
MJ:PutTagTextStringByRef (br tagname textstring / atts tag)
(if
(and
(= (vla-get-hasattributes br)
:vlax-true)
(safearray-value
(setq atts
(vlax-variant-value
(vla-getattributes br)
)
)
)
)
(foreach
tag (vlax-safearray->list atts)
(if (=
(strcase tagname) (strcase (vla-get-tagstring
tag)))
(vla-put-TextString tag
textstring)
)
)
(vla-update br)
)
)
;;30.4 [功能]
更改块多个属性
;;(setq blk (car (entsel)))
;;(MJ:ChangeAttributes (list blk (cons
"设计" "AA")(cons "名称" "BB")))
(defun MJ:ChangeAttributes (lst / blk itm
atts)
(setq blk (vlax-Ename->vla-Object (car
lst))
lst (cdr lst)
)
(if (= (vla-Get-HasAttributes
blk) :vlax-true) ;如果有属性
(progn
(setq atts
(vlax-SafeArray->list
(vlax-Variant-Value
(vla-GetAttributes blk))
)
)
(foreach item
lst
(mapcar
'(lambda
(x)
(if
(= (strcase (car item))
(strcase (vla-Get-TagString x)))
(vla-Put-TextString x (cdr
item))
)
)
atts
)
)
(vla-Update
blk)
)
)
)
;;30.5
[功能] 更改块多个属性
;; 示例: (MJ:ChangeAttribute (list ename '("MJ:Attribute" .
"NewValue")))
;; 示例 (MJ:ChangeAttribute (list (car (entsel)) '("设计" .
"NewValue")))
(defun MJ:ChangeAttribute (lst / item atts)
(vl-load-com)
(if (safearray-value
(setq
atts
(vlax-variant-value
(vla-getattributes
(vlax-ename->vla-object (car
lst)))
)
)
)
(progn
(foreach item (cdr
lst)
(mapcar
'(lambda
(x)
(if
(= (strcase (car item))
(strcase (vla-get-tagstring x)))
(vla-put-textstring x (cdr
item))
)
)
(vlax-safearray->list
atts)
)
)
(vla-update (vlax-ename->vla-object (car
lst)))
)
)
)
;;31.1 [功能] 返回指定(块名 标记 属性值)的块 选择集
;; 示例:
(MJ:SelectAttributedBlocks '("块名" "Tag" "value"))
(defun
MJ:SelectAttributedBlocks (lst / ss ss2 c ent att)
(if (setq ss
(ssget "X" (list (cons 0 "INSERT") (cons 2 (car lst)))))
(progn
(setq c
0)
(repeat (sslength ss)
(setq ent
(vlax-ename->vla-object (ssname ss c)))
(if (vla-get-hasattributes
ent)
(foreach att (vlax-safearray->list
(vlax-variant-value (vla-getattributes
ent))
)
(if
(=
(strcase (vla-get-tagstring att)) (strcase (cadr
lst)))
(if (= (strcase
(vla-get-textstring att))
(strcase
(caddr lst))
)
(progn
(vla-highlight ent
:vlax-true)
(if (not
ss2)
(setq ss2 (ssadd (ssname ss
c)))
(ssadd (ssname ss c)
ss2)
)
)
)
)
)
)
(setq c (1+
c))
)
)
)
ss2
)
;;31.2 [功能] 返回指定(块名 标记 属性值)的块 选择集
;;
(MJ:FindBlockTagValue "blockname" "tagname" "tagvalue")
(defun
MJ:FindBlockTagValue
(bn tagname value /
layout i atts tag sset c)
(vlax-for layout
*LOUTS*
(vlax-for i (vla-get-block
layout)
(if (and
(= (vla-get-objectname i) "AcDbBlockReference")
(=
(strcase (vla-get-name i)) (strcase bn))
)
(if
(and
(= (vla-get-hasattributes i)
:vlax-true)
(safearray-value
(setq
atts
(vlax-variant-value
(vla-getattributes
i)
)
)
)
)
(progn
(foreach tag (vlax-safearray->list
atts)
(if
(and
(= (strcase
tagname)
(strcase
(vla-get-TagString tag))
)
(= value (vla-get-TextString
tag))
)
(progn
(if
(not sset)
(setq sset (ssadd (*Obj2En*
i)))
(ssadd (*Obj2En* i)
sset)
)
)
)
)
)
)
)
)
)
(sssetfirst nil sset)
)
;;32.1 [功能] 更改属性位置
;; (MJ:ChangeTagIns "sheet-text" "a3-scale" '(703.4722
17.8350 0))
(defun MJ:ChangeTagIns (bn tagname ins / layout i atts
tag)
(defun list->variantArray (ptsList / arraySpace
sArray)
(setq arraySpace
(vlax-make-safearray
vlax-vbdouble
(cons 0 (- (length ptsList)
1))
)
)
(setq
sArray (vlax-safearray-fill arraySpace ptsList))
(vlax-make-variant sArray)
)
(vlax-for layout
*LOUTS*
(vlax-for i (vla-get-block
layout)
(if (and
(= (vla-get-objectname i) "AcDbBlockReference")
(=
(strcase (vla-get-name i)) (strcase bn))
)
(if
(and
(= (vla-get-hasattributes i)
:vlax-true)
(safearray-value
(setq
atts
(vlax-variant-value
(vla-getattributes
i)
)
)
)
)
(foreach tag
(vlax-safearray->list atts)
(if (= (strcase
tagname) (strcase (vla-get-tagstring
tag)))
(vla-put-InsertionPoint tag
(list->variantArray ins))
)
)
(vla-update i)
)
)
)
)
)
;;32.2 [功能] 更改块属性宽度
;; (MJ:ChangeTagWidth <block name> <tag
name> <tag height>)
;; (MJ:ChangeTagWidth "panel1" "drw-no"
0.97)
(defun MJ:ChangeTagWidth (bn tagname tagwidth / layout i atts
tag)
(vlax-for layout *LOUTS*
(vlax-for
i (vla-get-block layout)
(if
(and
(= (vla-get-objectname i)
"AcDbBlockReference")
(= (strcase (vla-get-name i))
(strcase bn))
)
(if
(and
(= (vla-get-hasattributes i)
:vlax-true)
(safearray-value
(setq
atts
(vlax-variant-value
(vla-getattributes
i)
)
)
)
)
(foreach tag
(vlax-safearray->list atts)
(if (= (strcase
tagname) (strcase (vla-get-tagstring
tag)))
(vla-put-scalefactor tag
tagwidth)
)
)
(vla-update i)
)
)
)
)
)
;;32.3 [功能] 更改块属性高度
;; (MJ:ChangeTagHeight <block name> <tag
name> <tag height>)
;; (MJ:ChangeTagHeight "sheet-text" "client-drw"
0.97)
(defun MJ:ChangeTagHeight
(bn tagname
tagheight / layout i atts tag)
(vlax-for layout
*LOUTS*
(vlax-for i (vla-get-block
layout)
(if (and
(= (vla-get-objectname i) "AcDbBlockReference")
(=
(strcase (vla-get-name i)) (strcase bn))
)
(if
(and
(= (vla-get-hasattributes i)
:vlax-true)
(safearray-value
(setq
atts
(vlax-variant-value
(vla-getattributes
i)
)
)
)
)
(foreach tag
(vlax-safearray->list atts)
(if (= (strcase
tagname) (strcase (vla-get-tagstring
tag)))
(vla-put-height tag
tagheight)
)
)
(vla-update i)
)
)
)
)
)
;;33 [功能] 列表块插入点(Y排序)
;; (MJ:ListBlockIns "BTL")
;; return value
example:
;; ((341.385 29.2937 0.0 #<VLA-OBJECT IAcadBlockReference
071b9e24>)
;; (341.385 34.2937 0.0 #<VLA-OBJECT
IAcadBlockReference 071b9e74>)
;; (341.385 39.2937 0.0
#<VLA-OBJECT IAcadBlockReference 071bd184>))
(defun MJ:ListBlockIns (bn
/ layout i pl)
(vlax-for layout *LOUTS*
(vlax-for i (vla-get-block layout)
(if
(and
(= (vla-get-objectname i)
"AcDbBlockReference")
(= (strcase (vla-get-name i))
(strcase bn))
)
(setq
pl
(cons
(append
(safearray-value
(vlax-variant-value
(vla-get-InsertionPoint i))
)
(list
i)
)
pl
)
)
)
)
)
; sort by y-value
(vl-sort pl
(function (lambda (e1
e2)
(< (cadr e1) (cadr
e2))
)
)
)
)
;;34 [功能] 块集的某一属性,显示块的x(or y z)值
;; Arguments: ss块集 attname属性
ordinate(0=X, 1=Y, 2=Z)
;; 示例: (MJ:LabelOrdinate ss "设计"
0)
(defun MJ:LabelOrdinate (ss attname ordinate / c block atts val
att)
(vl-load-com)
(setq c -1)
(repeat (sslength
ss)
(setq
block (vlax-ename->vla-object
(ssname ss (setq c
(1+ c)))
)
atts (vlax-safearray->list
(vlax-variant-value
(vla-getattributes
block)
)
)
val (rtos
(nth
ordinate
(vlax-safearray->list
(vlax-variant-value
(vla-get-insertionpoint
block)
)
)
)
2
0
)
)
(foreach att
atts
(if (= (strcase attname) (strcase
(vla-get-tagstring att)))
(vla-put-textstring att
val)
)
)
(vla-update block)
)
(princ)
)
;;35.1 [功能] 块中删除对象
;; 示例: (MJ:DeleteObjectFromBlock (car
(nentsel)))
;; Notes: 1. As shown, you can use the
NENTSEL function to obtain the name of an entity within a
block.
;;
2. Existing block reference will not show a change until you regen the
drawing.
(defun MJ:DeleteObjectFromBlock (ent / doc blk)
(setq ent (vlax-ename->vla-object ent)
blk
(vla-ObjectIdToObject *DOC* (vla-get-OwnerID ent))
)
(vla-Delete ent)
(vla-get-Count blk)
)
;;35.2 [功能] 块增加对象
;; 示例: (MJ:AddObjectsToBlock (car (entsel))
(ssget))
;; Notes: Existing block references will not
show a change until
you
;;
regen the drawing
(defun MJ:AddObjectsToBlock (blk ss / doc blkref blkdef
inspt refpt)
(setq blkref (vlax-ename->vla-object
blk)
blkdef (vla-Item (vla-get-Blocks *DOC*) (vla-get-Name
blkref))
inspt (vlax-variant-value (vla-get-InsertionPoint
blkref))
ssarray (SS->Array
ss)
refpt (vlax-3d-point '(0 0 0))
)
(foreach
ent (vlax-safearray->list ssarray)
(vla-Move ent inspt
refpt)
)
(vla-CopyObjects *DOC* ssarray blkdef)
(foreach ent (vlax-safearray->list ssarray)
(vla-Delete
ent)
)
(princ)
)
;;35.3 [功能] 返回指定块每一个引用实体名列表
;; 注:未能验证是否正确?(MJ:ListBLockRefs
"BTL")
(defun MJ:ListBLockRefs (blkName / lst)
(setq lst
(entget
(cdr
(assoc 330
(entget (tblobjname "block" blkName)))
)
)
)
(apply
'append
(mapcar '(lambda
(x)
(if (entget (cdr
x))
(list (cdr x))
)
)
(repeat
2
(setq lst (reverse (cdr (member (assoc
102 lst) lst))))
)
)
)
)
;;35.4 [功能] 块引用名列表Returns a list conaining the entity names of any block
definitions
that
;;
reference the specified block
;; 示例: (MJ:GetParentBlocks
"BTL")
(defun MJ:GetParentBlocks (blkName / doc)
(apply
'append
(mapcar
'(lambda (x)
(if
(= :vlax-false
(vla-get-IsLayout
(vla-ObjectIdToObject
*DOC*
(vla-get-OwnerId
(vlax-ename->vla-object x))
)
)
)
(list x)
)
)
(MJ:ListBLockRefs
blkName)
)
)
)
;;36 [功能] 删除指定名的所有块
;; (MJ:EraseBlock "BTL");删除名叫"BTL"的所有块
(defun
MJ:EraseBlock (bn / layout i)
(vlax-for layout
*LOUTS*
(vlax-for i (vla-get-block
layout)
(if (and
(= (vla-get-objectname i) "AcDbBlockReference")
(=
(strcase (vla-get-name i)) (strcase bn))
)
(vla-Delete
i)
)
)
)
)
;;37 [功能] 块名"BTL"是否存在
;; (MJ:ExistBlock "BTL"是)
(defun MJ:ExistBlock
(bn / layout i exist)
(vlax-for layout *LOUTS*
(vlax-for i *BLKS*
(if
(and
(= (vla-get-objectname i)
"AcDbBlockReference")
(= (strcase (vla-get-name i))
(strcase bn))
)
(setq exist
T)
)
)
)
exist
)
;;38.1 [功能] 块更名(块bn nn必须存在)
;; (MJ:RenameBlock "b1"
"b2")块"b1"更名为"b2"
(defun MJ:RenameBlock (bn nn / layout i)
(vlax-for layout *LOUTS*
(vlax-for i (vla-get-block
layout)
(if (and
(= (vla-get-objectname i) "AcDbBlockReference")
(=
(strcase (vla-get-name i)) (strcase bn))
)
(vla-put-name i nn)
)
)
)
)
;;38.2 [功能]
块更名
;;名为bn的块存在,名为nn的块不存在
;;(MJ:RenameBlock1 "ccd1" "ccd2")
(defun
MJ:RenameBlock1 (bn nn / BLOCK)
(vla-put-name (vla-item
(vla-get-blocks *DOC*) bn) nn)
)
;;39 [功能] 块名例表
;; 返回示例("*D5" "A$C263E5435" "b2" "b1")
(defun MJ:blocks
(/ b bn tl)
(vlax-for b (vla-get-blocks *DOC*)
(if (= (vla-get-islayout b) :vlax-false)
(setq tl (cons (vla-get-name b) tl))
)
)
(reverse tl)
)
;;40 [功能] XRef图块列表 a list of all xref names
;;返回示例 ("xref1"
"x2")
(defun MJ:xrefs (/ b bn tl)
(vlax-for b (vla-get-blocks
*DOC*)
(if (= (vla-get-isxref b)
:vlax-true)
(setq tl (cons (vla-get-name b)
tl))
)
)
(reverse tl)
)
;;41 [功能] 返回名为"bn"的XRef图块实体列表
;; 返回示例 (<Entity name: 2ea6290>
<Entity name: 2ea6288>)
(defun blockrefs (bn / lst ed)
(if
(setq ed (tblobjname "block" bn))
(setq
lst (entget
(cdr (assoc 330 (entget ed)))
)
)
)
(apply
'append
(mapcar '(lambda
(x)
(list (cdr
x))
)
(cdr
(reverse (cdr (member (assoc 102 lst) lst))))
)
)
)
;;42 [功能] 返回包容点集的最小点最大点列表
;; (MJ:Extents '((1 0 0) (2 2 0) (1 2
0)))
(defun MJ:Extents (plist /)
(list
(apply
'mapcar (cons 'min plist))
(apply 'mapcar (cons 'max
plist))
)
)
;;43.1 [功能] 两点中点
(defun MJ:Mid (P1 P2)
(mapcar '(lambda (X Y) (*
(+ X Y) 0.5)) P1 P2)
)
;;43.2 [功能]
<起点>,<中点>,<终点>列表 ;By 无痕
(DEFUN xl-3p (e / ps pe
pm)
(setq ps (vlax-curve-getstartparam e)
pe
(vlax-curve-getendparam e)
pm (/ (- pe ps) 2)
)
(mapcar 'vlax-curve-getpointatparam
(list e e e)
(list ps pm pe)
)
)
;;44 [功能] 求矩形中心
;;示例 (MJ:RectCenter (car (entsel)))
(defun
MJ:RectCenter (e)
(MJ:Mid (MJ:Extents (MJ:Massoc 10 (entget
e))))
)
;;45 [功能] 返回封闭曲线质心二维坐标
;; 示例: (MJ:Centroid (car
(entsel)))
(defun MJ:Centroid (poly / pl ms va reg cen)
(vl-load-com)
(setq pl (vlax-ename->vla-object
poly)
ms (vla-get-modelspace
*DOC*
)
va (vlax-make-safearray vlax-vbObject '(0
. 0))
)
(vlax-safearray-put-element va 0 pl)
(setq reg (car (vlax-safearray->list
(vlax-variant-value (vla-addregion ms va))
)
)
cen (vla-get-centroid reg)
)
(vla-delete reg)
(vlax-safearray->list
(vlax-variant-value cen))
)
;;46.1 [功能] 多段线各顶点(见99.3)
;;示例 (MJ:Massoc 10 (entget (car
(entsel))))
;; Notes:特别适合多段线各顶点
(defun MJ:Massoc (key alist)
(apply
'append
(mapcar '(lambda
(x)
(if (eq (car x)
key)
(list (cdr
x))
)
)
alist
)
)
)
;;46.2 [功能]
pline,lwpline点坐标表 By 无痕
;;示例(vxs (car (entsel))),返回三维点坐标
(defun vxs
(e / i v lst)
(setq i -1)
(while
(setq
v (vlax-curve-getpointatparam e (setq i (1+ i))))
(setq lst (cons v lst))
)
(reverse lst)
)
;;46.3 [功能]
返回包含每一出现在列表中的指定键的cdr(点对的后部分)的列表。
;;;示例 (MJ:massoc 10 (entget (car (entsel))))
;;注意 该函数特别适合用于找到细多义线上的所有顶点。
(defun MJ:massoc (key alist)
(mapcar 'cdr
(vl-remove-if-not '(lambda (x) (equal key (car x)))
alist)
)
)
;|
;;http://www.xdcad.net/forum/thread-669166-1-2.html By XDSoft
功能
对字符串进行正则表达式匹配测试.
pat = 正则表达式模式 ,对应vbs正则表达式的模式(expression)。说明:
\\号要用\\\\替代.
str = 字符串
key = \"i\" \"g\" \"m\" ,
\"i\"不区分大小写（Ignorecase）,\"g\"全局匹配（Global）.
\"m\"多行模式（Multiline），以上几个关键字可以组合使用，或用 \"\".
返回:
返回匹配的字符列表，或无一匹配返回nil
|;
;;47.1 [功能] 字符串分割(正则表达式)
(defun
XD::String:RegExpS (pat str key / end keys matches x)
(if (not
*xxvbsexp)
(setq *xxvbsexp (vlax-get-or-create-object
"VBScript.RegExp"))
)
(vlax-put *xxvbsexp 'Pattern
pat)
(if (not key)
(setq key "")
)
(setq key (strcase key))
(setq keys '(("I"
"IgnoreCase")
("G"
"Global")
("M"
"Multiline")
)
)
(mapcar
'(lambda
(x)
(if (wcmatch key (strcat "*" (car x)
"*"))
(vlax-put *xxvbsexp (read (cadr x)) 0)
(vlax-put
*xxvbsexp (read (cadr x)) -1)
)
)
keys
)
(setq matches (vlax-invoke *xxvbsexp 'Execute str))
(vlax-for x
matches (setq end (cons (vla-get-value x) end)))
(reverse
end)
)
;;47.2 [功能] 字符串查找与替换(正则表达式)
(defun XD::String:Replace (pat str
nstr key / end)
(if (not *xxvbsexp)
(setq
*xxvbsexp (vlax-get-or-create-object "VBScript.RegExp"))
)
(vlax-put *xxvbsexp 'Pattern pat)
(if (not key)
(setq key "")
)
(setq key (strcase key))
(setq
keys '(("I" "IgnoreCase") ("G" "Global") ("M" "Multiline")))
(mapcar
'(lambda (x)
(if (wcmatch key (strcat "*" (car
x) "*"))
(vlax-put *xxvbsexp (read
(cadr x)) 0)
(vlax-put *xxvbsexp
(read (cadr x)) -1)
)
)
keys
)
(vlax-invoke *xxvbsexp 'replace str
nstr)
)
;;47.3 [功能] 调用VBS的公用执行函数
(defun wscriptPublic (str)
(or *wscript*
(setq *wscript*
(vlax-create-object "ScriptControl"))
)
(vlax-put *wscript*
'language "vbs")
(vlax-invoke-method *wscript* 'ExecuteStatement
str)
(vlax-invoke-method *wscript* 'eval "ret")
)
;;48 [功能] 返回一个包涵经过pt点的多段线端点的列表
;; Returns a list containing the endpoints
of the selected lwpoly segment
;; 示例: (apply 'MJ:GetPolySegment (list (car
(entsel)) (getpoint)))返回((-1600.24 2403.92) (-1524.08 2403.92))
(defun
MJ:GetPolySegment (poly pt / pts i)
(setq pts (MJ:Massoc 10
(entget poly))
i (caddar (ssnamex (ssget pt)))
)
(list
(nth (1- i) pts)
(if
(and
(MJ:IsClosed
poly)
(= i (length pts))
)
(car
pts)
(nth i pts)
)
)
)
;;49 [功能] 把弧变成圆
(defun MJ:CloseArc (/ arcent arcobj trapobj
circ)
(while (setq arcent (entsel "\nSelect ARC object:
"))
(setq arcobj (MJ:MakeObject (car
arcent)))
(cond
((=
"AcDbArc" (MJ:ObjectType arcobj))
(_StartUndo *doc*)
(setq
circ
(vla-addCircle
*MS*
(vla-Get-center
arcobj)
(vla-Get-radius
arcobj)
)
)
(MJ:MapPropertyList
'("Layer" "Color" "Thickness" "Linetype" "LinetypeScale")
arcobj
circ
)
(MJ:DeleteObject
arcobj)
(vlax-Release-Object
circ)
(_EndUndo
*doc*)
) ;
(T (princ
"\nNot an ARC object, try again..."))
) ; cond
) ;
endwhile
(princ)
)
;;50.1 [功能] 线型是否存在?
;;示例: (MJ:Ltype-Exists-p "DASHED") (MJ:Ltype-Exists-p
"continuous")
(defun MJ:Ltype-Exists-p (strLtype)
(member
(strcase strLtype)
(mapcar
'strcase (MJ:ListLtypes))
)
)
;;50.2 [功能] 改变vla对象线型
;; 示例: (MJ:Apply-Ltype cirobj
"DASHED")改变对象线型
(defun MJ:Apply-Ltype (obj strLtype / entlist)
(cond
((MJ:Ltype-Exists-p
strLtype)
(cond
((and
(vlax-Read-Enabled-p obj)
(vlax-Write-Enabled-p
obj)
)
(vla-Put-Linetype obj
strLtype)
T
)
(T (princ "\n
Unable to modify object!"))
)
)
(T
(princ (strcat "\n Linetype ["
strLtype
"] not
loaded."
)
)
)
)
)
;;51.1 [功能] 角度->弧度
(defun MJ:D2R (a) (* pi (/ a 180.0)))
;;51.2 [功能]
弧度->角度
(defun MJ:R2D (a) (/ (* a 180.0) pi))
;;52.1 [功能] 3D点->2D点 By Caoyin
(defun
3dpoint->2dpoint (3dpt)
(if (apply 'and (mapcar 'numberp
3dpt))
(mapcar '+ 3dpt '(0. 0.))
)
)
;;52.2 [功能] 3D点->2D点
(defun 3d->2d (3dpt / 2dpt)
(setq 2dpt (list (car 3dpt) (cadr 3dpt)))
)
;;52.3 [功能]
3D点列表->2D点列表
(defun 3dpoint-list->2dpoint-list (3dplist /
2dplist)
(cond
((and 3dplist (listp 3dplist)
(listp (car 3dplist)))
(setq
2dplist
(mapcar '(lambda (pt) (list (car pt) (cadr
pt))) 3dplist)
)
)
(T
(princ
"\n3dpoint-list->2dpoint-list:
Invalid parameter list..."
)
)
)
)
;;52.4 [功能] 3D点列表->2D点列表
(defun 3dlist->2dlist
(3dplist)
(mapcar '3d->2d 3dplist)
)
;;52.5 [功能]
对表分段(见99.1)
;;(xl_div lst nom)表分段. -> 返回 分段的表. －－－－－－by
无痕.2004.1
; lst ＝ 表，nom = 分段的子表元素个数(从1开始计).
;;示例 (xl_div '(1 2 3 4 5 6 7 8
9) 3) -> ((1 2 3) (4 5 6) (7 8 9))
(defun xl-div (lst x / lst2)
(foreach n lst
(if (and lst2 (/= x (length (car
lst2))))
(setq lst2 (cons (append (car lst2)
(list n)) (cdr lst2)))
(setq lst2 (cons (list
n) lst2))
)
)
(reverse lst2)
)
;;53.1 [功能] 画线
;; 示例:(MJ:AddLine (getpoint) (getpoint) nil nil
nil)
(defun MJ:AddLine (StartPt EndPt strLayer intColor strLtype /
obj)
(cond
((and StartPt (listp StartPt) EndPt
(listp EndPt))
(setq obj
(vla-addLine
(vla-Get-ModelSpace
*DOC*
)
(vlax-3D-Point StartPt)
(vlax-3D-Point EndPt)
)
)
(cond
((vlax-Write-Enabled-p
obj)
(if strLayer
(vla-Put-Layer obj
strLayer)
)
(if intColor
(vla-Put-Color obj
intColor)
)
(if strLtype
(MJ:Apply-Ltype obj
strLtype)
)
(vla-Update obj)
(vlax-Release-Object
obj)
(entlast)
)
(T (princ
"\nUnable to modify object properties..."))
)
)
(T
(princ "\nMJ:AddLine: Invalid parameter list..."))
)
)
;;53.2
[功能] 根据点表画线
(defun MJ:AddLineC (ptlist Bclosed strLayer intColor strLtype /
*MJ:MODELSPACE* PT1 PTZ)
(setq *MJ:ModelSpace* *MS*)
(cond
((and ptlist (listp ptlist) (listp (car
ptlist)))
(setq pt1 (car
ptlist)
;; save first point
ptz
(last ptlist)
;; save last
point
)
(while (and
ptlist (>= (length ptlist) 2))
(MJ:AddLine
*MJ:ModelSpace*
(car ptlist)
(cadr
ptlist)
strLayer
intColor
strLtype
)
(setq ptlist (cdr
ptlist))
)
(if (=
Bclosed T)
(MJ:AddLine
*MJ:ModelSpace* pt1 ptz strLayer intColor strLtype)
)
)
(T (princ "\nMakeLineC: Invalid
parameter list..."))
)
)
;;54 [功能] 画弧
;; 示例: (MJ:AddArc pt1 0.5 0 90 "0" 3 "DASHED")
(defun
MJ:AddArc
(CenterPt Radius
StartAng EndAng
strLayer intColor strLtype
/
obj
)
(cond
((and CenterPt (listp CenterPt) Radius StartAng
EndAng)
(setq obj
(vla-addArc
(vla-Get-ModelSpace
*DOC*
)
(vlax-3D-Point
CenterPt)
Radius
(MJ:D2R
StartAng)
(MJ:D2R
EndAng)
)
)
(cond
((vlax-Write-Enabled-p obj)
(if strLayer
(vla-Put-Layer
obj strLayer)
)
(if intColor
(vla-Put-Color
obj intColor)
)
(if strLtype
(MJ:Apply-Ltype
obj strLtype)
)
(vla-Update obj)
(vlax-Release-Object
obj)
(entlast)
) ;
(T (princ
"\nUnable to modify object properties..."))
)
) ;
(T (princ "\nMJ:AddArc: Invalid parameter list..."))
)
)
;;55 [功能] 画圆
;; 示例: (MJ:AddCircle pt1 0.5 "0" 3 "DASHED")
(defun
MJ:AddCircle
(CenterPt Radius strLayer
intColor strLtype / obj)
(cond
((and CenterPt
(listp CenterPt) Radius)
(setq obj
(vla-addCircle
(vla-Get-ModelSpace
*DOC*
)
(vlax-3D-Point CenterPt)
Radius
)
)
(cond
((vlax-Write-Enabled-p
obj)
(if strLayer
(vla-Put-Layer obj
strLayer)
)
(if intColor
(vla-Put-Color obj
intColor)
)
(if strLtype
(MJ:Apply-Ltype obj
strLtype)
)
(vla-Update obj)
(vlax-Release-Object
obj)
(entlast)
)
(T (princ "\nUnable to modify object
properties..."))
)
)
(T (princ "\nMJ:AddCircle: Invalid parameter
list..."))
)
)
;;56 [功能] 画多段线
;; EXMAPLE: (MJ:AddPline ptlist "0" T 3 "DASHED"
0.125) ;;
(defun
MJ:AddPline
(ptlist strLayer
Bclosed intColor
strLtype
dblWidth / vrtcs
lst
plgen
plist plpoints
obj
)
(cond
((and ptlist (listp ptlist) (listp (car
ptlist)))
(setq plist (apply
'append (mapcar '3dpoint->2dpoint ptlist))
plpoints
(MJ:List->VariantArray plist)
obj
(vla-AddLightWeightPolyline
(vla-Get-ModelSpace
*DOC*
)
plpoints
)
)
(cond
((and
(vlax-Read-Enabled-p obj)
(vlax-Write-Enabled-p obj)
)
(if Bclosed
(vla-Put-Closed obj :vlax-True)
)
(if strLayer
(vla-Put-Layer obj strLayer)
)
(if intColor
(vla-Put-Color obj intColor)
)
(if dblWidth
(vla-Put-ConstantWidth obj dblWidth)
)
(if
strLtype
(progn
(MJ:Apply-Ltype obj
strLtype)
(vla-Put-LinetypeGeneration obj
:vlax-True)
)
)
(vla-Update
obj)
(vlax-Release-Object
obj)
(entlast)
)
(T (princ "\n Unable to modify
object!"))
)
)
(T (princ "\n Invalid parameter list...."))
)
)
;;56.1 [功能] 画椭圆
;; 示例: (MJ:AddEllipse l1 p2 45 "PARTS" nil
nil) ;;
(defun
MJ:AddEllipse
(ctr hmpt roll strLayer
intColor strLtype / lst obj)
(cond
((and ctr
(listp ctr) hmpt (listp hmpt) roll)
(setq
hmpt (list
(- (car hmpt) (car
ctr))
(- (cadr hmpt) (cadr
ctr))
)
obj (vla-addEllipse
*MS*
(vlax-3D-Point ctr)
(vlax-3D-Point
hmpt)
(cos (MJ:D2R
roll))
)
)
(cond
((vlax-Write-Enabled-p obj)
(if strLayer
(vla-Put-Layer
obj strLayer)
)
(if intColor
(vla-Put-Color
obj intColor)
)
(if strLtype
(MJ:Apply-Ltype
obj strLtype)
)
(vla-Update
obj)
)
(T (princ "\nUnable
to modify object properties..."))
)
(vlax-Release-Object
obj)
(entlast)
)
(T (princ "\nInvalid
paprameter list..."))
)
)
;;56.2
[功能] 画椭圆弧
(defun MJ:AddEllipseArc1
(ctr hmpt
roll StartAng
EndAng strLayer intColor
strLtype
/
obj rang
)
(cond
((and ctr (listp ctr) hmpt
roll)
(setq hmpt (list
(-
(car hmpt) (car ctr))
(- (cadr hmhp) (cadr
ctr))
)
obj (vla-addEllipse
*MS*
(vlax-3D-Point ctr)
(vlax-3D-Point
hmpt)
(MJ:Roll->Ratio
roll)
)
)
(cond
((vlax-Write-Enabled-p
obj)
(vla-Put-StartAngle obj (MJ:D2R
StartAng))
(vla-Put-EndAngle obj (MJ:D2R EndAng))
(if
strLayer
(vla-Put-Layer obj strLayer)
)
(if
intColor
(vla-Put-Color obj intColor)
)
(if
strLtype
(MJ:Apply-Ltype obj
strLtype)
)
(vla-Update obj)
(vlax-Release-Object
obj)
(entlast)
)
(T (princ "\nUnable
to modify object properties..."))
)
)
(T (princ "\nMakeArcEllipse1:
Invalid parameter list..."))
)
)
;;56.3 [功能] 画椭圆弧
(defun
MJ:AddEllipseArc2
(ctr hmpt
hmin StartAng
EndAng strLayer intColor
strLtype
/
obj rang
)
(cond
((and ctr (listp ctr) hmpt (listp hmpt)
hmin)
(setq hmpt (list
(-
(car hmpt) (car ctr))
(- (cadr hmpt) (cadr
ctr))
)
obj (vla-addEllipse
*MS*
(vlax-3D-Point ctr)
(vlax-3D-Point
hmpt)
hmin
)
)
(cond
((vlax-Write-Enabled-p obj)
(vla-Put-StartAngle obj (MJ:D2R
StartAng))
(vla-Put-EndAngle obj (MJ:D2R EndAng))
(if
strLayer
(vla-Put-Layer obj strLayer)
)
(if
intColor
(vla-Put-Color obj intColor)
)
(if
strLtype
(MJ:Apply-Ltype obj
strLtype)
)
(vla-Update obj)
(vlax-Release-Object
obj)
(entlast)
)
(T (princ
"\nUnable to modify object properties..."))
)
)
(T (princ
"\nMakeArcEllipse2: Invalid parameter list..."))
)
)
;;57 [功能] 生成一个点
;; 示例: (MJ:AddPoint p1 nil)
(defun MJ:AddPoint (pt
strLayer / obj)
(cond
((and pt (listp
pt))
(setq obj (vla-addPoint *MS* (vlax-3D-Point
pt)))
(if (vlax-Write-Enabled-p
obj)
(progn
(if
strLayer
(vla-Put-Layer obj strLayer)
)
(vla-Update obj)
(vlax-Release-Object obj)
(entlast)
)
(princ "\nMJ:AddPoint: Unable to
modify object!")
)
)
(T (princ "\nMJ:AddPoint:
Invalid parameter list..."))
)
)
;;58 [功能] 单行文字
;; 示例: (MJ:AddText "ABC" p1 "MC"
"STANDARD" 0.25 1.0 0 "TEXT" nil)
(defun
MJ:AddText
(strTxt
pt Just strStyle
dblHgt
dblWid
dblRot strLay intCol
/
txtobj
)
(cond
((setq txtobj
(vla-AddText
(MJ:ActiveSpace)
strTxt
(if (not (member (strcase Just)
'("A" "F")))
(vlax-3d-Point pt)
(vlax-3d-Point
(car pt))
) ;
endif
dblHgt
;; ignored if Just = "A"
(aligned)
)
)
(vla-put-StyleName txtobj
strStyle)
(vla-put-Layer txtobj
strLay)
(if
intCol
(vla-put-Color txtobj
intCol)
)
(setq Just
(strcase Just))
;; force to upper case for
comparisons...
;;
Left/Align/Fit/Center/Middle/Right/BL/BC/BR/ML/MC/MR/TL/TC/TR
;; Note that "Left" is not a normal
default.
;;
;; ALIGNMENT
TYPES...
;;
AcAlignmentLeft=0
;;
AcAlignmentCenter=1
;;
AcAlignmentRight=2
;;
AcAlignmentAligned=3
;;
AcAlignmentMiddle=4
;;
AcAlignmentFit=5
;;
AcAlignmentTopLeft=6
;;
AcAlignmentTopCenter=7
;;
AcAlignmentTopRight=8
;;
AcAlignmentMiddleLeft=9
;;
AcAlignmentMiddleCenter=10
;;
AcAlignmentMiddleRight=11
;;
AcAlignmentBottomLeft=12
;;
AcAlignmentBottomCenter=13
;;
AcAlignmentBottomRight=14
;;
;; HORIZONTAL
JUSTIFICATIONS...
;;
AcHorizontalAlignmentLeft=0
;;
AcHorizontalAlignmentCenter=1
;;
AcHorizontalAlignmentRight=2
;;
AcHorizontalAlignmentAligned=3
;;
AcHorizontalAlignmentMiddle=4
;;
AcHorizontalAlignmentFit=5
;;
;; VERTICAL
JUSTIFICATIONS...
;;
AcVerticalAlignmentBaseline=0
;;
AcVerticalAlignmentBottom=1
;;
AcVerticalAlignmentMiddle=2
;;
AcVerticalAlignmentTop=3
(cond
((=
Just "L")
;; Left
(vla-put-ScaleFactor txtobj
dblWid)
(vla-put-Rotation txtobj (DTR
dblRot))
)
((= Just "C")
;;
Center
(vla-put-Alignment txtobj
1)
(vla-put-TextAlignmentPoint txtobj (vlax-3d-point
pt))
(vla-put-ScaleFactor txtobj dblWid)
(vla-put-Rotation
txtobj (DTR dblRot))
)
((= Just "R")
;;
Right
(vla-put-Alignment txtobj 2)
(vla-put-TextAlignmentPoint
txtobj (vlax-3d-point pt))
(vla-put-ScaleFactor txtobj
dblWid)
(vla-put-Rotation txtobj (DTR
dblRot))
)
((= Just "A")
;;
Alignment
(vla-put-Alignment txtobj
3)
(vla-put-TextAlignmentPoint txtobj (vlax-3d-point
pt))
)
((= Just "M")
;;
Middle
(vla-put-Alignment txtobj
4)
(vla-put-TextAlignmentPoint txtobj (vlax-3d-point
pt))
(vla-put-ScaleFactor txtobj dblWid)
(vla-put-Rotation
txtobj (DTR dblRot))
)
((= Just "F")
;;
Fit
(vla-put-Alignment txtobj 5)
(vla-put-TextAlignmentPoint
txtobj (vlax-3d-point pt))
)
((= Just "TL")
;;
Top-Left
(vla-put-Alignment txtobj
6)
(vla-put-TextAlignmentPoint txtobj (vlax-3d-point
pt))
(vla-put-ScaleFactor txtobj dblWid)
(vla-put-Rotation
txtobj (DTR dblRot))
)
((= Just "TC")
;;
Top-Center
(vla-put-Alignment txtobj
7)
(vla-put-TextAlignmentPoint txtobj (vlax-3d-point
pt))
(vla-put-ScaleFactor txtobj dblWid)
(vla-put-Rotation
txtobj (DTR dblRot))
)
((= Just "TR")
;;
Top-Right
(vla-put-Alignment txtobj
8)
(vla-put-TextAlignmentPoint txtobj (vlax-3d-point
pt))
(vla-put-ScaleFactor txtobj dblWid)
(vla-put-Rotation
txtobj (DTR dblRot))
)
((= Just "ML")
;;
Middle-Left
(vla-put-Alignment txtobj
9)
(vla-put-TextAlignmentPoint txtobj (vlax-3d-point
pt))
(vla-put-ScaleFactor txtobj dblWid)
(vla-put-Rotation
txtobj (DTR dblRot))
)
((= Just "MC")
;;
Middle-Center
(vla-put-Alignment txtobj
10)
(vla-put-TextAlignmentPoint txtobj (vlax-3d-point
pt))
(vla-put-ScaleFactor txtobj dblWid)
(vla-put-Rotation
txtobj (DTR dblRot))
)
((= Just "MR")
;;
Middle-Right
(vla-put-Alignment txtobj
11)
(vla-put-TextAlignmentPoint txtobj (vlax-3d-point
pt))
(vla-put-ScaleFactor txtobj dblWid)
(vla-put-Rotation
txtobj (DTR dblRot))
)
((= Just "BL")
;;
Bottom-Left
(vla-put-Alignment txtobj
12)
(vla-put-TextAlignmentPoint txtobj (vlax-3d-point
pt))
(vla-put-ScaleFactor txtobj dblWid)
(vla-put-Rotation
txtobj (DTR dblRot))
)
((= Just "BC")
;;
Bottom-Center
(vla-put-Alignment txtobj
13)
(vla-put-TextAlignmentPoint txtobj (vlax-3d-point
pt))
(vla-put-ScaleFactor txtobj dblWid)
(vla-put-Rotation
txtobj (DTR dblRot))
)
((= Just "BR")
;;
Bottom-Right
(vla-put-Alignment txtobj
14)
(vla-put-TextAlignmentPoint txtobj (vlax-3d-point
pt))
(vla-put-ScaleFactor txtobj dblWid)
(vla-put-Rotation
txtobj (DTR dblRot))
)
)
(vla-Update
txtobj)
(vlax-Release-Object
txtobj)
(entlast)
)
)
)
;;59 [功能] 画多边形
;; (MJ:AddPolygon center, radius, sides, flag, width,
layer, color, ltype)
;; 示例: (MJ:AddPolygon pt1 1.0 6 nil 0 "0" nil
"DASHED")
(defun
MJ:AddPolygon
(ctrpt
dblRad intSides strType
dblWid
strLay intCol strLtype
/ pa
dg ptlist
deg
)
(setq pa (polar ctrpt 0 dblRad)
dg (/ 360.0
intSides)
;; get angles between faces
deg dg
)
(repeat intSides
(setq
ptlist
(if ptlist
(append ptlist (list (polar ctrpt (MJ:D2R deg)
dblRad)))
(list (polar ctrpt (MJ:D2R deg)
dblRad))
)
)
(setq deg (+ dg deg))
) ;
repeat
(MJ:AddPline ptlist strLay T intCol strLtype dblWid)
)
;;60 [功能] 画矩形
;; (MJ:AddRectangle p1(lower left), p3(upper right), layer,
color, linetype, width)
;; 示例: (MJ:AddRectangle p1 p3 "0" nil "DASHED"
0.25)
(defun MJ:AddRectangle
(p1 p3
strLayer intColor strLtype dblWid / p2 p4 obj)
(setq p2 (list
(car p1) (cadr p3))
p4 (list (car p3) (cadr p1))
)
(cond
((setq obj (MJ:AddPline
(list p1 p2
p3 p4)
strLayer
T
intColor
strLtype
dblWidth
)
)
obj
;; raise object (entity
name)
)
)
)
;;61 [功能] 画长方体
;; (MJ:AddSolid points-list, layer(string),
color(integer))
;; 示例: (MJ:AddSolid ptlist "0" nil)
(defun MJ:AddSolid
(ptlist strLayer intColor / plist obj)
(cond
((and ptlist (listp ptlist) (listp (car ptlist)))
(if (= (length ptlist) 3)
(setq plist
(append ptlist (list (last ptlist))))
(setq plist ptlist)
)
(cond
((setq obj (vla-addSolid
(MJ:ActiveSpace)
(vlax-3D-Point (car
plist))
(vlax-3D-Point (cadr
plist))
(vlax-3D-Point (caddr
plist))
(vlax-3D-Point (cadddr
plist))
)
)
(if strLayer
(vla-Put-Layer obj strLayer)
)
(if intColor
(vla-Put-Color obj intColor)
)
(vla-Update
obj)
(vlax-release-object
obj)
(entlast)
) ;
(T (princ
"\nUnable to create object..."))
) ; cond
) ;
(T (princ "\nMJ:AddSolid:
Invalid parameter list..."))
)
)
;;62 [功能] 多行文字MText
(defun myMText (txtString coner Width)
(vla-addText *MS* (vlax-3d-point pt) Width txtString)
)
;;63 [功能] 面域Region
(defun myRegion (curveObjList nColor / CN CURVES
REGIONOBJ)
(setq cn (length curveObjList))
(setq curves
(vlax-make-safearray vlax-vbObject (cons 0 (1- cn))))
(vlax-safearray-fill curves curveObjList)
(setq RegionObj
(vla-AddRegion *MS* curves))
(vla-put-color
(vla-safearray-get-element (vla-Variant-value RegionObj)
0)
nColor
)
)
;;64 [功能] 对象外画一矩形
;;
示例: (MJ:DrawVpBorder (car
(entsel)))
;;
;; Notes: 1. The return value is the entity name
of the newly created lwpolyline
;;
;; 2.
The layout containing the viewport to be drawn must be active
;;
(defun MJ:DrawVpBorder (vp / ll ur coords pl)
(vl-load-com)
(setq vp (vlax-ename->vla-object
vp))
(vla-GetBoundingBox vp 'll 'ur)
(setq ll
(vlax-safearray->list ll)
ur (vlax-safearray->list ur)
)
(setq coords (vlax-safearray-fill
(vlax-make-safearray vlax-vbDouble (cons 0 7))
(list (nth 0
ll);x
(nth 1
ll);y
(nth 0
ur);x
(nth 1
ll);y
(nth 0
ur)
(nth 1
ur)
(nth 0
ll)
(nth 1
ur)
)
)
)
(vla-put-closed
(setq pl
(vla-AddLightWeightPolyline
(vla-get-ModelSpace (vla-get-Document
vp))
coords
)
)
:vlax-true
)
(*Obj2En* pl)
)
;;65.1 [功能] 创建图层(成功返回层名)
;;(MJ:DefineLayer strName intColor strLtype
booleCur)
;; 示例: (MJ:DefineLayer "MJ:Layer1" 3 "DASHED" T)
(defun
MJ:DefineLayer
(strName intColor
strLtype booleCur / iloc obj out)
(cond
((not
(tblsearch "layer" strName))
(setq obj (vla-add
(*LAYS*) strName))
(setq iloc (vl-position strName
(MJ:ListLayers)))
(cond
((vlax-Write-Enabled-p
obj)
(if intColor
(vla-put-Color obj
intColor)
)
(if strLtype
(MJ:Apply-Ltype obj
strLtype)
)
)
(T (princ "\nUnable to modify object
properties..."))
)
(if
booleCur
(vla-put-ActiveLayer
*DOC*
(vla-Item (*LAYS*) iloc)
)
)
(setq out
strName)
)
(T
(princ (strcat "\nLayer already exists: "
strName))
)
)
out
)
;;65.2 [功能]
创建一个图层(新建层不为当前层)
;; 示例: (MJ:MakeLayer "A-Wall")
(defun
MJ:MakeLayer (lName / oLayer)
(if
(vl-catch-all-error-p
(setq
oLayer
(vl-catch-all-apply
'vla-add
(list
*LAYS*
lName
)
)
)
)
nil
oLayer
)
)
;;66.1 [功能] 表->变体数组类型
(defun MJ:DblList->VariantArray (nList /
ArraySpace sArray)
;; allocate space for an array of 2d points stored
as doubles
(setq ArraySpace
(vlax-Make-SafeArray
vlax-vbDouble
(cons 0
(- (length nList) 1)
)
)
)
(setq sArray (vlax-SafeArray-Fill ArraySpace
nList))
(vlax-Make-Variant sArray)
)
;;66.2 [功能]
表->整数数组
(defun MJ:IntList->VarArray (aList)
(vlax-SafeArray-Fill
(vlax-Make-SafeArray
vlax-vbInteger ; (2) Integer
(cons 0 (- (length aList) 1))
)
aList
)
)
;;66.3 [功能] 表->变体数组
(defun
MJ:VarList->VarArray (aList)
(vlax-SafeArray-Fill
(vlax-Make-SafeArray
vlax-vbVariant ;(12) Variant
(cons 0 (- (length aList) 1))
)
aList
)
)
;;66.4 [功能] 选择集->数组
(defun SS->Array (ss / N R)
(repeat (setq n (sslength ss))
(setq r (cons
(ssname ss (setq n (1- n))) r))
)
(vlax-safearray-fill
(vlax-make-safearray
vlax-vbObject;根据需要使用其类型
(cons 0 (1- (length
r)))
)
(mapcar
'vlax-ename->vla-object r)
)
)
;;66.5 [功能] 列表->变体数组
;;
示例: (setq ptlist (list "1" 2 (list 1.0 2.0
3.0)))
;;(MJ:list->VariantArray (apply 'append ptlist)
vlax-vbDouble)
;; Notes: 1. If your list includes
various data types, pass vlax-vbVariant for
the
;;
varType argument
;; 2. Entity names
are converted to ObjectIDs
;; 3. To
convert a point list to ActiveX coordinates:
(defun MJ:list->VariantArray
(lst varType)
(vlax-make-variant
(vlax-safearray-fill
(vlax-make-safearray
varType
(cons 0 (1- (length
lst)))
)
(mapcar
'(lambda (x)
(cond
((= (type x)
'list)
(vlax-safearray-fill
(vlax-make-safearray
(if (apply '= (mapcar 'type x))
(cond
((= (type (car x)) 'REAL)
vlax-vbDouble)
((= (type (car x))
'INT) vlax-vbInteger)
((= (type
(car x)) 'STR) vlax-vbString)
)
vlax-vbVariant
)
(cons 0 (1- (length
x)))
)
x
)
)
((=
(type x) 'ename)
(vla-get-objectid
(*En2Obj* x))
)
(t x)
)
)
lst
)
)
)
)
;;67 [功能] 对象端点列表
;; 示例:(MJ:GetEllipseArcPoints (car
(entsel)))返回两端点
(defun
MJ:GetEllipseArcPoints
(ellent / OUT
P-END P-START VLAOBJECT-ELLIPSE)
(setq vlaObject-Ellipse
(MJ:MakeObject ellent)
;; convert ename to
object
p-start (vla-Get-StartPoint
vlaObject-Ellipse)
p-end (vla-Get-EndPoint
vlaObject-Ellipse)
out
(list
(vlax-SafeArray->List
(vlax-Variant-Value p-start))
(vlax-SafeArray->List (vlax-Variant-Value p-end))
)
)
out
)
;;68 [功能] 更改Vla对象线型比例
;; 示例: (MJ:Apply-LtScale objLine 24.0)
(defun
MJ:Apply-LtScale (obj dblLtScale)
(cond
((and
(vlax-Read-Enabled-p
obj)
(vlax-Write-Enabled-p
obj)
)
(vla-Put-Linetype
dblLtScale)
T
)
(T (princ
"\n Unable to modify object!"))
)
)
;;69 [功能] 将图层集合中的第一个图层设置为当前层
(defun MJ:LayZero ()
(vla-put-ActiveLayer
*DOC*
(vla-Item
(*LAYS*) 0)
)
)
;;70 [功能] 设置指定层为当前层
;; (MJ:LayActive "DIM")相当于(command "clayer"
"DIM")
(defun MJ:LayActive (name / iloc out)
(cond
((and
(tblsearch "layer" name)
(setq iloc
(vl-Position name (MJ:ListLayers)))
)
(vla-put-ActiveLayer *DOC* (vla-Item (*LAYS*)
iloc))
(setq out name)
)
(T (princ (strcat "\n
Layer not defined: " name)))
)
out
)
;;71.1图层列表 开
(defun MJ:LayerOn (LayList)
(vlax-for each
(vla-get-layers *DOC*)
(if (member (strcase
(vla-get-name each)) LayList)
(if
(vlax-write-enabled-p each)
(vla-put-LayerOn each
:vlax-True)
)
)
(vlax-release-object each)
)
)
;;71.2 [功能] 图层列表 关
(defun MJ:LayerOff (LayList)
(vlax-for each
(*LAYS*)
(if (member (strcase (vla-get-name each))
LayList)
(if (vlax-write-enabled-p
each)
(vla-put-LayerOn each
:vlax-False)
)
)
(vlax-release-object each)
)
)
;;71.3 [功能] 图层列表 冻结
(defun MJ:LayerFreeze (LayList)
(vlax-for each (*LAYS*)
(if (member (strcase
(vla-get-name each)) LayList)
(if
(vlax-write-enabled-p each)
(vla-put-Freeze each
:vlax-True)
)
)
(vlax-release-object each)
)
)
;;71.4 [功能] 图层列表 解冻
(defun MJ:LayerThaw (LayList)
(vlax-for each
(*LAYS*)
(if (member (strcase (vla-get-name each))
LayList)
(if (vlax-write-enabled-p
each)
(vla-put-Freeze each
:vlax-False)
)
)
(vlax-release-object each)
)
)
;;71.5 [功能] 图层列表[打印/不打印]
;; 示例: (MJ:LayerNoPlot '("DOORS" "WINDOWS")
T)设置图层不打印
;; 示例: (MJ:LayerNoPlot '("DOORS" "WINDOWS") nil) 设置图层打印
(defun
MJ:LayerNoPlot (LayList On-Off)
(vlax-for each
(*LAYS*)
(if (member (strcase (vla-get-name each))
LayList)
(if (vlax-write-enabled-p
each)
(if On-Off
(vla-put-Plottable each
:vlax-True)
(vla-put-Plottable each
:vlax-False)
)
)
)
(vlax-release-object
each)
)
)
;;71.6 [功能] 图层列表 锁
(defun MJ:LayerLock (LayList)
(vlax-for each
(*LAYS*)
(if (member (strcase (vla-get-name each))
LayList)
(if (vlax-write-enabled-p
each)
(vla-put-Lock each :vlax-True)
)
)
(vlax-release-object
each)
)
)
;;71.7 [功能] 图层列表 解锁
(defun MJ:LayerUnLock (LayList)
(vlax-for each (*LAYS*)
(if (member (strcase
(vla-get-name each)) LayList)
(if
(vlax-write-enabled-p each)
(vla-put-Lock each
:vlax-False)
)
)
(vlax-release-object each)
)
)
;;71.8 [功能] 锁定图层列表
(defun MJ:ListLayers-Locked (/ each out)
(vlax-for each (*LAYS*)
(if (= (vlax-get-property
each "Lock") :vlax-true)
(setq out (cons
(vla-get-name each) out))
)
)
out
)
;;71.9 [功能] 返回冻结图层列表
(defun MJ:ListLayers-Frozen (/ each out)
(vlax-for each (*LAYS*)
(if (= (vlax-get-property
each "Freeze") :vlax-true)
(setq out (cons
(vla-get-name each) out))
)
)
out
)
;;71.10 [功能] 返回关闭图层列表
(defun MJ:ListLayers-Off (/ each out)
(vlax-for each (*LAYS*)
(if (= (vlax-get-property
each "LayerOn") :vlax-false)
(setq out (cons
(vla-get-name each) out))
)
)
out
)
;;71.11 [功能] 可打印图层列表
(defun MJ:ListLayers-Plottable (/ each out)
(vlax-for each (*LAYS*)
(if (= (vlax-get-property
each "Plottable") :vlax-true)
(setq out (cons
(vla-get-name each) out))
)
)
out
)
;;71.12 [功能] 非打印图层列表
(defun MJ:ListLayers-Plottalbe-Not (/ each
out)
(vlax-for each (*LAYS*)
(if (=
(vlax-get-property each "Plottable")
:vlax-false)
(setq out (cons (vla-get-name
each) out))
)
)
out
)
;;71.13 [功能] 层是否冻结？
;;(MJ:Layer-Frozen-p "DIM")
(defun
MJ:Layer-Frozen-p (lname / each)
(if
(and
(setq fl
(MJ:ListLayers-Frozen))
;; any frozen
layers?
(member (strcase lname) (mapcar
'strcase fl))
)
T
)
)
;;71.14 [功能] 解冻 解锁 开 所有图层
(defun MJ:Mylayer ()
(acet-layerp-mark
nil)
(acet-layerp-mode T)
(acet-layerp-mark T)
(command "_.Layer" "Thaw" "*" "U" "*" "ON" "*" "")
)
;;71.15 [功能] 恢复图层状态 By coaying
(defun
MJ:layer-restore ()
(acet-layerp-mark nil)
(command
"_.layerp")
)
;;71.16 [功能] 得到图层状态highflybird
(defun Get_Layer_Status (/ V_LIST
L_LIST C_LIST T_LIST W_LIST *DOC)
(setq *Doc (vla-get-ActiveDocument
*acad*))
(vlax-for n (vla-get-layers *DOC)
(setq
V_List (cons (cons n (vla-get-LayerOn n)) V_List)
L_List (cons
(cons n (vla-get-Lock n)) L_List)
C_List (cons (cons n
(vla-get-TrueColor n)) C_List)
T_List (cons (cons n
(vla-get-Linetype n)) T_List)
W_List (cons (cons n
(vla-get-LineWeight n)) W_List)
F_List (cons (cons n
(vla-get-Freeze n)) F_List)
)
)
(List
V_List L_List C_List T_List W_List F_List)
)
;;71.17 [功能] 恢复图层状态highflybird
(defun Restore_Layer_status
(LayLst)
(mapcar (function
(lambda (x
y)
(foreach n X
(if
(/= (strcase (setq name (vla-get-name (car
n))))
(strcase (getvar
"clayer"))
) ;
非当前层
(vlax-put-property (car n) y (cdr
n))
;;对于当前层
(if (/= y
"Freeze") ; 排除冻结操作，以防出错
(vlax-put-property (car n) y (cdr n))
)
)
)
)
)
LayLst
(list "Layeron"
"Lock"
"TrueColor"
"LineType"
"LineWeight" "Freeze"
)
)
;;(vl-cmdf "regen")
)
;;71.18 [功能] 图层是否锁定?
;;(b_layer_locked "0"),0层锁后返回T
(defun
b_layer_locked (la / na e1)
(setq na (tblobjname "layer"
la)
e1 (entget na)
)
(equal 4 (logand 4 (cdr (assoc
70 e1))))
)
;;71.19 [功能] 保存图层状态
;;(_layerSave "#GxlLayerSave"
nil)
;|acLsAll All layer properties
acLsColor Color
acLsFrozen Frozen
or thawed
acLsLineType Linetype
acLsLineWeight Lineweight
acLsLocked
Locked or unlocked
acLsNewViewport New viewport layers frozen or thawed
acLsNone None
acLsOn On or off
acLsPlot Plotting on or off
acLsPlotStyle Plot style
|;
(defun _layerSave (name Mask /
LM)
(vl-load-com)
(or *ACAD* (setq *ACAD*
(vlax-get-acad-object)))
(or *DOC* (setq *DOC* (vla-get-ActiveDocument
*ACAD*)))
(cond ((null Mask) (setq Mask aclsall)))
(setq lm
(vla-GetInterfaceObject
*ACAD*
(strcat
"AutoCAD.AcadLayerStateManager."
(substr (getvar
'acadver) 1 2)
)
)
)
(vla-SetDatabase lm (vla-get-Database *Doc*))
(if
(VL-CATCH-ALL-ERROR-P
(VL-CATCH-ALL-APPLY 'vla-save (list lm name
mask))
)
(progn
(VL-CATCH-ALL-APPLY 'vla-delete (list
lm name))
(VL-CATCH-ALL-APPLY 'vla-save (list
lm name mask))
)
t
)
)
;;71.20 [功能] 恢复图层状态
;;(_LAYERRESTORE "#GxlLayerSave" t)
(defun
_LayerRestore (name Flag / LM RTN)
(vl-load-com)
(or *ACAD*
(setq *ACAD* (vlax-get-acad-object)))
(or *DOC* (setq *DOC*
(vla-get-ActiveDocument *ACAD*)))
(setq lm
(vla-GetInterfaceObject
*ACAD*
(strcat "AutoCAD.AcadLayerStateManager."
(substr
(getvar 'acadver) 1 2)
)
)
)
(vla-SetDatabase lm (vla-get-Database *Doc*))
(setq rtn
(not
(VL-CATCH-ALL-ERROR-P
(VL-CATCH-ALL-APPLY
'vla-Restore (list lm name))
)
)
)
(cond (Flag (VL-CATCH-ALL-APPLY 'vla-delete (list lm
name))))
rtn
)
;;72 [功能] 设置vla对象线宽
;; NOTES:
;; "ByLwDefault" =
-3
;; "ByBlock" = -2
;; "ByLayer" =
-1
;; Other values are 0, 5, 9, 13, 15, 18, 20, 25, 30, 35, 40,
50, 53, 60,
;; 70, 80, 90, 100, 106, 120, 140, 158, 200,
211
(defun MJ:SetLweight (obj intLwt)
(cond
((member intLwt
'(0 5
9 13 15 18 20
25 30 35
40
50 60
70 80 90 100 106 120 140
158 200
211
)
)
(vla-put-LineWeight obj
ineLwt)
T
)
)
)
;;73 [功能] vla选择集是否存在
(defun MJ:SSetExists-p (Name)
(not
(vl-Catch-All-Error-p
(vl-Catch-All-Apply
'vla-Item
(list (vla-Get-SelectionSets
*DOC*) Name)
)
)
)
)
;;74.1 [功能] 返回指定类型的选择集
;; 示例: (setq MJ:set (MJ:SelectByType
"CIRCLE"))
;;(MJ:MapCollection MJ:set 'MJ:DeleteObject)圆全部删除
(defun
MJ:SelectByType (objtype / ss)
(if (MJ:SSetExists-p
"%TEMP_SET")
(vla-Delete
(vla-Item
(vla-get-SelectionSets
*DOC*)
"%TEMP_SET"
)
)
)
(setq ss
(vla-Add
(vla-get-SelectionSets
*DOC*)
"%TEMP_SET"
)
)
(vla-Select
ss
ACSelectionSetAll
nil
nil
(MJ:IntList->VarArray (list
0))
(MJ:VarList->VarArray (list objtype))
)
ss
)
;;74.2 [功能] 返回指定类型的选择集
;; MODULE: (MJ:SelectOnScreen-Filter GroupCodes
FilterLists)
;;示例见下
(defun MJ:SelectOnScreen-Filter (GroupCodes
FilterLists / ss)
(if (MJ:SSetExists-p
"%TEMP_SET")
(vla-Delete
(vla-Item
(vla-get-SelectionSets
*DOC*)
"%TEMP_SET"
)
)
)
(setq ss
(vla-Add
(vla-get-SelectionSets
*DOC*)
"%TEMP_SET"
)
)
(vla-Select
ss
ACSelectionSetAll
nil
nil
(MJ:IntList->VarArray
GroupCodes)
(MJ:VarList->VarArray
FilterLists)
)
ss
)
;;74.3 [功能] 返回0层上的圆选择集
(defun MJ:PICKCIRCLES (/ SS)
(if
(setq ss (MJ:SelectOnScreen-Filter '(0 8) '("CIRCLE"
"0")))
(vlax-For item
ss
(princ (vla-get-ObjectName
item))
(terpri)
)
)
(terpri)
ss
)
;;74.4 [功能] 返回圆选择集(并打印名称)
(defun C:GETCIRCLES ()
(if (setq ss
(MJ:SelectByType "CIRCLE"))
(vlax-For item
ss
(princ (vla-get-ObjectName
item))
(terpri)
)
)
ss
)
;;75.1 [功能] 返回CAD窗口状态
;; acEnum 1=Min 2=Normal 3=Max
;; 示例:
(MJ:GetWindowState) return 1, 2 or 3
(defun MJ:GetWindowState ()
(vla-get-WindowState *ACAD*)
)
;;75.2 [功能] 设置CAD窗口状态
;; 示例:
(MJ:SetWindowState 3) maximizes the window display
(defun MJ:SetWindowState
(acEnum)
(vla-put-WindowState *ACAD* acEnum)
)
;;76.1 [功能] 隐藏CAD
;; 示例: (MJ:HideAutoCAD)
(defun
MJ:HideAutoCAD ()
(vla-put-Visible *ACAD*
:vlax-False)
)
;;76.2 [功能] 显示CAD
;; 示例: (MJ:ShowAutoCAD)
(defun
MJ:ShowAutoCAD ()
(vla-put-Visible *ACAD*
:vlax-True)
)
;;76.3 [功能] 隐藏CAD一段时间
;; 示例: (MJ:HideShowTest 500)
隐藏CAD，时间500毫秒
(defun MJ:HideShowTest (delay-time)
(MJ:HideAutoCAD)
(vl-cmdf "delay" delay-time)
(MJ:ShowAutoCAD)
)
;;77.1 [功能] CAD参数选择
(defun MJ:DocPrefs ()
(vla-get-Preferences *DOC*)
)
;;77.2 [功能] 线宽显示
(defun
MJ:LWdisplayON ()
(vla-put-LineWeightDisplay (MJ:DocPrefs)
:vlax-True)
)
;;77.3 [功能] 隐藏线宽
(defun MJ:LWdisplayOFF ()
(vla-put-LineWeightDisplay (MJ:DocPrefs) :vlax-False)
)
;;77.4 [功能]
对象捕捉开
(defun MJ:ObjectSortBySnapON ()
(vla-put-ObjectSortBySnap
(MJ:DocPrefs) :vlax-True)
)
;;77.5 [功能] 对象捕捉关闭
(defun
MJ:ObjectSortBySnapOFF ()
(vla-put-ObjectSortBySnap (MJ:DocPrefs)
:vlax-False)
)
;;77.6[功能] 图形被其它用户参照时仍可以立即编辑
(defun MJ:XrefEditON
()
(vla-put-XrefEdit (MJ:DocPrefs) :vlax-True)
)
;;77.7[功能]
图形被其它用户参照时不可以立即编辑
(defun MJ:XrefEditOFF ()
(vla-put-XrefEdit
(MJ:DocPrefs) :vlax-False)
)
;;78.1 [功能] CAD菜单集合
(defun MJ:MenuGroups ()
(vla-get-menugroups
*ACAD*)
)
;;78.2 [功能] 菜单列表
;;示例("ACAD" "CXinZhi")
(defun
MJ:MenuGroups-ListAll (/ out)
(vlax-for each
(MJ:MenuGroups)
(setq out (cons (vla-get-name each)
out))
)
(reverse out)
)
;;78.3 [功能]
菜单是否存在
;;示例(MJ:MenuGroup-Exists-p "CXinZhi")返回 1
(defun
MJ:MenuGroup-Exists-p (name)
(if
(member
(strcase
name)
(mapcar 'strcase
(MJ:MenuGroups-ListAll))
)
(vl-position name (MJ:MenuGroups-ListAll))
)
)
;;78.4 [功能]
工具条Vla集合
(defun MJ:Toolbars (mgroup)
(if (MJ:MenuGroup-Exists-p
mgroup)
(vla-get-toolbars
(vla-item
(MJ:MenuGroups)
(vl-position
(strcase mgroup)
(mapcar 'strcase
(MJ:MenuGroups-ListAll))
)
)
)
)
)
;;78.5 [功能]
工具条列表
;;(MJ:ToolbarsList "CXinZhi")返回("附加图层工具" "附加文字工具" "附加标准工具")
(defun
MJ:ToolbarsList (mgroup / tb out)
(if (setq tb (MJ:Toolbars
mgroup))
(vlax-for each
tb
(setq out (cons (vla-get-name each)
out))
)
)
(reverse out)
)
;;78.6
[功能] 工具条列表
;; Arguments: 菜单名称
;; 示例: (ListToolbars
"acad")(ListToolbars "CXinZhi")
(defun MJ:ListToolbars (groupName / mGroups
mGroup lst)
(if (not
(vl-catch-all-error-p
(setq
mGroup
(vl-catch-all-apply
'vla-item
(list (vla-get-menugroups
*ACAD*)
groupName
)
)
)
)
)
(vlax-for tBar (vla-get-toolbars
mGroup)
(setq lst (cons (vla-get-name tBar)
lst))
)
)
)
;;78.7 [功能]
工具条是否存在
;;(MJ:Toolbar-Exists-p "CXinZhi" "附加图层工具");返回0
(defun
MJ:Toolbar-Exists-p (mgroup tbname)
(if
(and
(MJ:MenuGroup-Exists-p
mgroup)
(member
(strcase
tbname)
(mapcar 'strcase (MJ:Toolbars-ListAll
mgroup))
)
)
(vl-position tbname (MJ:Toolbars-ListAll
mgroup))
)
)
;;78.8 [功能] 指定工具条(Vla)
(defun MJ:Toolbar (mgroup
tbname / loc)
(if (setq loc (MJ:Toolbar-Exists-p mgroup
tbname))
(vla-item (MJ:Toolbars mgroup) loc)
)
)
;;78.9 [功能] 显示指定工具条
;;(MJ:Toolbar-Show "ACAD"
"UCS")将显示UCS工具条
;;(MJ:Toolbar-Show "CXinZhi" "附加图层工具")
(defun
MJ:Toolbar-Show (mgroup tbname / tb)
(if (setq tb (MJ:Toolbar mgroup
tbname))
(if (= (vla-get-visible tb)
:vlax-false)
(progn
(vla-put-visible
tb :vlax-true)
T
)
)
)
)
;;78.10 [功能] 隐藏工具条
(defun
MJ:Toolbar-Hide (mgroup tbname / tb)
(if (setq tb (MJ:Toolbar mgroup
tbname))
(if (= (vla-get-visible tb)
:vlax-true)
(progn
(vla-put-visible
tb :vlax-false)
T
)
)
)
)
;;78.11 [功能] 工具条放置位置
;; NOTES: Allowable <dock> values are 0(top),
1(bottom),
2(left),
;;
;; and 3(right). Returns 1 if
successful, -1 if toolbar is not
;;
;; visible, -2 if parameter is
invalid, or 0 if toolbar not found. ;;
(defun
MJ:Toolbar-Dock (mgroup tbname dock / tb)
(if (setq tb (MJ:Toolbar
mgroup tbname))
(if (= (vla-get-visible tb)
:vlax-true)
(if (member dock '(0 1 2
3))
(progn
(vlax-invoke-method tb 'Dock
dock)
1
)
-2; invalid dockstatus
parameter
)
-1; toolbar not visible
)
0; toolbar
not found
)
)
;;78.12 [功能] Float a given toolbar at specified
position(top and left)
;; and display with specified number of
rows. Returns 1 if successful,
;; -1 if toolbar is not visible, 0
if toolbar is not found.
(defun MJ:Toolbar-Folat (mgroup tbname top left
rows)
(if (setq tb (MJ:Toolbar mgroup tbname))
(if (= (vla-get-visible tb) :vlax-true)
(progn
(vlax-invoke-method tb 'Float top left
rows)
1
)
-1; toolbar not
visible
)
0; toolbar not
found
)
)
;;78.13 [功能] 改变工具条按钮位图
;; 示例:
(MJ:ChangeBitmap "acad" "dimension" "linear dimension" "test.bmp")
;;
Notes: 1. If the bitmap is not in the AutoCAD search
path, you must specify
;;
;;
the full path to file ;;
(defun
MJ:ChangeBitmap (mnuGroup tbrName btnName bitmap)
(vl-load-com)
(vla-setbitmaps
(vla-item
(vla-item
(vla-get-toolbars
(vla-item
(vla-get-menugroups *ACAD*)
mnuGroup
)
)
tbrName
)
btnName
)
bitmap
bitmap
)
(princ)
)
;;79 [功能] 2D点转成vla 2D
;;(MJ:2DPoint (getpoint));(vlax-3d-point (getpoint))
3d点
(defun MJ:2DPoint (pt)
(vlax-make-variant
(vlax-safearray-fill
(vlax-make-safearray
vlax-vbdouble '(0 . 1))
(list (car pt) (cadr
pt))
)
)
)
;;80.1 [功能]
激活最左边一个布局
;;下面程序使用vla-activate有问题,看起来没有错误
;;模型和布局之间自由切换(setvar "CTAB"
"layout2")
(defun MJ:ActivateLastLayout (/ CNT I)
(vlax-for
layout *LOUTS*
(if (= (vla-get-taborder layout)
1);取得布局的tab顺序,图纸空间的标签（tab）顺序必须是1或大于1
(vla-put-ActiveLayout *DOC* layout) ; (vla-activate
layout)运行有问题
)
)
)
;;80.2 [功能] 激活第二个图形[Ctrl+Tab] 见10
(defun MJ:ActivateDrawing
()
(vla-activate (vla-item *docs* 1))
)
;;81 [功能] VLA选择集过滤条件Returns a list containing a pair of variants for use
as
;;
ActiveX selection set filters
;; 示例: (MJ:BuildFilter '((0 .
"LWPOLYLINE") (8 . "WALLS")))
(defun MJ:BuildFilter (filter)
(mapcar '(lambda (lst typ)
(vlax-make-variant
(vlax-safearray-fill
(vlax-make-safearray
typ
(cons 0
(1- (length lst))
)
)
lst
)
)
)
(list (mapcar 'car filter) (mapcar 'cdr filter))
(list
vlax-vbInteger vlax-vbVariant)
)
)
;;81 [功能] 类型库智能化加载
;;用法: (vlax-load-type-libeary ProgID[STRING]
UniquePrefix[STR] )
;;
(vlax-load-type-libeary ProgID[STRING] PrefixList[STR] )
;; 参数1:
与vlax-get-create-object 函数相同的ProgID 字符串
;; 参数2:
前缀，可以是字符串或表
;; 表的顺序
(:methods-prefix :properties-prefix :constants-prefix)
;;说明: 此函数读取 Windows
REGISTRY 并且侦测合适的 DLL/OCX/EXE 类型库并自动加载
;;返回值: T 或者 nil
(Defun
vlax-load-type-library
(File Prefix /
FileX Host N KeyX Val OSVar rtn)
(setq Host
"HKEY_LOCAL_MACHINE\\SOFTWARE\\Classes\\CLSID"
N
-1
KeyX (vl-registry-descendents Host)
)
(while
(< (setq N (1+ N))
(length KeyX)
)
(if (and (setq Val
(vl-registry-read
(strcat Host "\\" (nth N KeyX) "\\ProgID")
)
)
(vl-string-search (strcase File) (strcase
Val))
)
(setq FileX
(vl-registry-read
(strcat Host "\\" (nth N
KeyX) "\\InProcServer32")
)
N (length
KeyX)
)
)
)
(if (= (type Prefix) 'STR)
(setq Prefix (list
Prefix Prefix (strcat ":" Prefix)))
)
(if (= (type FileX)
'LIST)
(setq FileX (cdr FileX))
)
(if
(= (type FileX) 'STR)
(progn
(setq FileX (strcase
FileX))
(foreach OSVar (list
"SYSTEMROOT"
"WINDIR"
"WINBOOTDIR"
"SYSTEMDRIVE"
"USERNAME"
"COMPUTERNAME"
"HOMEDRIVE"
"HOMEPATH"
"PROGRAMFILES"
)
(if (vl-string-search
(strcat "%" OSVar "%") FileX)
(setq FileX
(vl-string-subst
(strcase (getenv
OSVar))
(strcat "%" OSVar
"%")
FileX
)
)
)
)
(if (setq rtn (findfile
FileX))
(setq rtn
(vlax-import-type-library
:tlb-filename
FileX
:methods-prefix
(nth 0
Prefix)
:properties-prefix
(nth 1
Prefix)
:constants-prefix
(nth 2
Prefix)
)
)
)
)
)
rtn
)
;;82 [功能] 转换路径中字符 "/" 为 "\\" 并返回大写值
;;用法: (vldos-formatpath
PathStringToFormat[STRING] )
;;参数1: 路径字符串
;;返回值:转换后的字符串 或者
None
(Defun vldos-formatpath (string)
(while (vl-string-search
"/" string)
(setq string (vl-string-subst "\\" "/"
string))
)
(while (vl-string-search "\\\\"
string)
(setq string (vl-string-subst "\\" "\\\\"
string))
)
(strcase string)
)
;;83 [功能] 通过IE 显示一个 HTML 字符串
;;用法: (vldos-text->ie
ContentString[STRING] )
;; 参数1: 要显示的字符串或字符串表
;;说明:
传送数据至新打开的IE窗口
;;返回值: 包括字符串的新打开的IE窗口 OR NIL
(Defun vldos-text->ie (TXT /
list->string ie ln doc)
(if (= (type TXT)
'STR)
(setq TXT (list TXT))
)
(if
(setq ie (vlax-create-object
"InternetExplorer.Application"))
(progn
(vlax-put-property ie 'menubar
0)
(vlax-put-property ie 'toolbar
0)
(vla-put-visible ie
t)
(vlax-invoke-method ie 'navigate "about
:blank")
(setq doc (vlax-get-property ie
'document))
(foreach ln
TXT
(vlax-invoke-method doc 'writeln ln
"")
)
(vlax-invoke-method doc 'close)
(vlax-release-object doc)
(vlax-release-object
ie)
)
)
)
;;84.1 [功能] 显示时间/日期对话框
;;用法: (vldos-time)
;;返回值: 显示时间/日期对话框 OR
NIL
(Defun vldos-time (/ sys)
(if (setq sys (vlax-create-object
"Shell.Application"))
(progn
(vlax-invoke-method sys
'settime)
(vlax-release-object
sys)
)
)
)
;;84.2 [功能] Returns the logical
drive letter to which a network share is mapped
;; Arguments: A UNC
path
;; 示例: (MJ:MappedShare
"\\\\MJ:Server\\MJ:Share")
;; Notes: 1.
Be sure to substitute two backslashes for every one in the UNC path
;; 2. This
routine requires the use SCRRUN.DLL. Visite
the
;;
Microsoft scripting web site if you do not have it.
(defun MJ:MappedShare
(share / drives drive letter)
(vlax-for drive (setq drives
(vlax-get-property *FSO* 'Drives))
(if (= (strcase
(vlax-get-property drive 'ShareName))
(strcase
share)
)
(setq letter
(vlax-get-property drive 'DriveLetter))
)
)
(vlax-release-object drives)
letter
)
;;84.3 [功能]
返回驱动器类型
;; 示例: (mapcar 'MJ:DriveType (MJ:ListDrives))
;;
Notes: 1. This routine requires the use
SCRRUN.DLL.
;;
Visit the Microsoft scripting web site if you do not have it.
;;方法:
BuildPath (2),CopyFile (3),CopyFolder (3),CreateFolder (1),CreateTextFile
(3),DeleteFile (2),DeleteFolder (2)
;;DriveExists (1),FileExists
(1),FolderExists (1),GetAbsolutePathName (1),GetBaseName (1),GetDrive
(1),GetDriveName (1)
;;GetExtensionName (1),GetFile (1),GetFileName
(1),GetFileVersion (1),GetFolder (1),GetParentFolderName
(1)
;;GetSpecialFolder (1),GetStandardStream (2),GetTempName (),MoveFile
(2),MoveFolder (2),penTextFile (4)
(defun MJ:DriveType (drv / drives drive
typ)
(if (vlax-invoke-method *FSO* 'DriveExists
drv)
(progn
(setq drives
(vlax-get-property *FSO* 'Drives)
drive
(vlax-get-property drives 'Item drv)
typ (vlax-get-property drive
'DriveType)
)
(vlax-release-object
drive)
(vlax-release-object
drives)
(nth typ
'("UNKNOWN" "REMOVABLE" "FIXED" "REMODTE" "CDROM"
"RAMDISK")
)
)
)
)
;;84.4 [功能] 返回驱动器列表
(defun MJ:ListDrives (/ drive drives
lst)
(vlax-for drive (setq drives (vlax-get-property*FSO*
'Drives))
(setq lst (cons (vlax-get-property drive
'DriveLetter) lst))
)
(vlax-release-object drives)
(reverse lst)
)
;;84.5 [功能] 修改本地磁盘的卷标
;;用法: (vldos-label
DriveLetter[STRING] NewVolumnName[STRING] )
;; 参数1: 盘符 例如: "C" 或
"C:"
;; 参数2: 新卷标, 如果长度超过11个字符,
自动裁掉
;; <<<
本函数不检查字符串是否符合命名规则 >>>
;;返回值: 新卷标 or NIL
(Defun vldos-Label
(DRV NEW / Fil DDD ERR)
(if (> (strlen NEW)
11)
(setq NEW (substr New 1 11))
)
(if
(setq Fil (vlax-get-or-create-object
"Scripting.FileSystemObject"))
(progn
(setq DDD (vlax-invoke-method Fil
'GetDrive DRV))
(vlax-put-property DDD
"VolumeName" NEW)
(if (not (eq (setq NEW
(strcase NEW))
(strcase (vlax-get-property DDD
"VolumeName"))
)
)
(setq NEW nil)
)
(vlax-release-object
DDD)
(vlax-release-object
FIL)
)
(setq New nil)
)
NEW
)
;;84.6 [功能] 执行 DOS DELTREE 命令
;;用法: (vldos-deltree
DirectoryToDelete[STRING] )
;; 参数1: 要被删除的目录名称.
此函数不显示确认过程，删除文件夹和所有的子文件夹
;; 如果参数是根目录，江删除所有的子目录.
;;返回值: T or
NIL
(Defun vldos-Deltree (Folder / sf subf FIL Rtn)
(cond ((vl-file-directory-p Folder)
(if (null (setq
Fil
(vlax-get-or-create-object
"Scripting.FileSystemObject")
)
)
(setq Rtn
nil)
(progn
(cond
((<= (strlen Folder)
3)
(if (= (strlen folder) 2)
(setq folder
(strcat folder "\\"))
)
(setq subf
(vl-directory-files Folder nil -1)
subf (vl-remove "." subf)
subf
(vl-remove ".." subf)
subf
(vl-remove "Recycled" subf)
)
(foreach sf
subf
(vlax-invoke-method
Fil
'DeleteFolder
(strcat folder
sf)
T
)
)
)
(t (vlax-invoke-method Fil
'DeleteFolder Folder T))
)
(vlax-release-object
FIL)
(setq Rtn (not (vl-file-directory-p
Folder)))
)
)
)
((findfile
Folder)
(vl-file-delete folder)
(setq Rtn (not (findfile
Folder)))
)
)
Rtn
)
;;84.7 [功能] 创建目录
;;用法:
(vldos-mkdir DirectoryToCreate[STRING] )
;;参数1: 目录的全路径名.
此函数会自动创建参数中所有不存在的目录.
;;返回值: 创建目录的全路径名 or NIL
(Defun vldos-MkDir
(Folder / FolderX Fil FFF Pos DIR DRV)
(if
(null
(setq
Fil (vlax-get-or-create-object
"Scripting.FileSystemObject")
)
)
(setq Folder nil)
(progn
(while (vl-string-search "/"
Folder)
(setq Folder (vl-string-subst "\\" "/"
Folder))
)
(if (wcmatch Folder "*\\")
(setq Folder (substr Folder 1 (1- (strlen
Folder))))
)
(setq FolderX Folder)
(while (setq Pos
(vl-string-search "\\" Folder))
(setq FFF (cons
(substr Folder 1 Pos) FFF)
Folder
(substr Folder (+ Pos 2))
)
)
(setq FFF (reverse (cons Folder
FFF))
DRV (car FFF)
FFF (cdr FFF)
)
(foreach DIR
FFF
(if
(null (vl-file-directory-p (setq DRV
(strcat DRV "\\" DIR)))
)
(vlax-invoke-method
Fil
'createfolder
DRV
)
)
)
(vlax-release-object
Fil)
(if (setq Folder (vl-file-directory-p
FolderX))
(setq Folder (vldos-formatpath
FolderX))
)
)
)
Folder
)
;;84.8 [功能] 复制文件或目录
;;用法: (vldos-copy
SourceFile/Directory[STRING] TargetFile/Directory[STRING] )
;; 参数1:
源文件或目录
;; 参数2: 目标目录. 如果包含 "*\\" or "*/", 此函数将在此路径下创建相同的子目录.
;; 返回值:
复制的文件或目录字符串 or NIL
(Defun vldos-copy (from to / sys folder)
(setq from (vldos-formatpath from)
to
(vldos-formatpath to)
)
(if (null (vl-file-directory-p
to))
(setq to (vldos-mkdir to))
)
(if
(setq sys (vlax-get-or-create-object "Shell.Application"))
(progn
(if (setq folder (vlax-invoke-method
sys 'namespace to))
(progn
(princ
(strcat "\n Copying file(s) from
\042"
FROM "\042 to
\042"
to
"\042..."
)
)
(vlax-invoke-method folder 'copyhere from (+ 4 16))
(vlax-release-object folder)
(princ
"...Done!")
)
)
(vlax-release-object
sys)
)
)
(princ)
)
;;84.9 [功能]
复制目录下所有文件和目录
;;示例 (vldos-copy2 (getvar "dwgprefix")
"C:\\mtool\\SUPPORT")
(Defun vldos-copy2 (From to / rtn)
(cond
((vl-file-directory-p
From)
(if (< (strlen to)
3)
(setq to (strcat to
"\\"))
(if (not (vl-file-directory-p
to))
(vldos-mkdir to)
)
)
(if
(setq
Rtn (vlax-get-or-create-object
"Scripting.FileSystemObject")
)
(progn
(vlax-invoke-method
Rtn 'CopyFolder From to T)
(vlax-release-object Rtn)
(if
(vl-file-directory-p to)
(setq Rtn (vldos-formatpath
to))
)
)
)
)
((findfile From)
(vl-file-copy From
to)
(if (setq rtn (findfile
to))
(setq rtn (vldos-formatpath
rtn))
)
)
)
rtn
)
;;84.10 [功能] 移动文件或目录
;;用法: (vldos-move
SourceFile/Directory[STRING] TargetFile/Directory[STRING] )
;; 参数1:
源文件或目录.
;; 参数2: 目标目录. 如果包含 "*\\" or "*/", 此函数将在此路径下创建相同的子目录.
;;返回值:
移动后的文件或目录字符串 or NIL
(Defun vldos-move (from to / sys folder)
(if (setq sys (vlax-get-or-create-object
"Shell.Application"))
(progn
(setq from
(vldos-formatpath from)
to
(vldos-formatpath to)
folder (vlax-invoke-method sys
'namespace to)
)
(if folder
(progn
(princ
(strcat "\n Moving file(s) from
\042"
FROM "\042 to
\042"
to
"\042..."
)
)
(vlax-invoke-method folder 'movehere from (+ 4 16))
(vlax-release-object folder)
(princ
"...Done!")
)
)
(vlax-release-object
sys)
)
)
(princ)
)
;;84.11 [功能]
重命名文件或目录
;;用法: (vldos-rename SourceFile/Directory[STRING] NewName[STRING]
)
;; 参数1: 源文件或目录.
;; 参数2: 新名称.
;;返回值: 重命名后的文件或目录 or
NIL
(Defun vldos-rename (From to / Fil folder new parent rtn)
(cond
((vl-file-directory-p
From)
(setq parent (vl-filename-directory
From)
new (strcat parent
to)
)
(if (and
(setq
Fil
(vlax-get-or-create-object
"Scripting.FileSystemObject")
)
(> (strlen From)
3)
;; Can not rename root
folder
(null (vl-file-directory-p
new))
;; not an existing folder
name
)
(progn
(setq
folder (vlax-invoke-method Fil 'GetFolder From))
(vlax-put-property
folder "Name" To)
(vlax-release-object folder)
(vlax-release-object Fil)
)
(setq parent
nil)
)
)
((findfile From)
(setq parent (vl-filename-directory
from))
(vl-file-rename From
to)
)
)
(if (and
parent
(vl-file-directory-p
(setq to (strcat parent
to))
)
)
(setq rtn (vldos-formatpath to))
)
rtn
)
;;84.12 [功能] 返回磁盘的类型
;;用法: (vldos-drivetype DriveLetter[STRING]
)
;; 参数1: 盘符 例如: "C:"
;;返回值: 磁盘的类型 or NIL
(Defun vldos-drivetype
(drv / Fil drives drive typ rtn)
(setq rtn "INVALID")
(if
(and (setq
Fil
(vlax-get-or-create-object "Scripting.FileSystemObject")
)
(equal :vlax-true (vlax-invoke-method Fil 'DriveExists
drv))
)
(progn
(setq drives (vlax-get-property
Fil 'Drives)
drive (vlax-get-property
drives 'Item drv)
typ
(vlax-get-property drive 'DriveType)
rtn (nth typ
(list
"UNKNOWN"
"REMOVABLE"
"FIXED"
"REMOTE"
"CDROM"
"RAMDISK"
)
)
)
(vlax-release-object
drive)
(vlax-release-object
drives)
(vlax-release-object
Fil)
)
)
rtn
)
;;84.13
[功能] 返回当前的磁盘表
;;用法: (vldos-alldrive)
;;返回值: 返回当前的磁盘表 or NIL
(Defun
vldos-alldrive (/ fil drive drives lst)
(if (setq Fil
(vlax-get-or-create-object "Scripting.FileSystemObject"))
(progn
(vlax-for drive (setq drives
(vlax-get-property Fil 'Drives))
(setq lst (cons (vlax-get-property
drive 'DriveLetter) lst))
)
(vlax-release-object
drives)
(vlax-release-object
Fil)
(setq lst (reverse
lst))
)
)
lst
)
;;[功能]
返回磁盘的特定信息
;;用法: (vldos-driveinfo DriveLetter[STRING] key[STRING]
)
;; 参数1: 盘符 例如: "C:"
;; 参数2: 所需磁盘信息的字符串
;;返回值: 磁盘的特定信息 or
NIL
;|
"TOTALSIZE"
磁盘总空间
"FREESPACE" 磁盘可用空间
"DRIVETYPE"
磁盘类型
"FILESYSTEM" 文件系统类型
"SERIALNUMBER"
磁盘序列号
"SHARENAME" 共享名称
"VOLUMENAME"
磁盘卷标
|;
(Defun vldos-driveinfo (Drv Key / pos rtn)
(if (/= (type
key) 'STR)
(setq rtn (vldos-alldriveinfo
drv))
(if (setq pos
(vl-position
(setq key (strcase
key))
(list
"TOTALSIZE" "FREESPACE"
"DRIVETYPE" "FILESYSTEM"
"SERIALNUMBER" "SHARENAME"
"VOLUMENAME"
)
)
)
(setq rtn (nth pos
(vldos-alldriveinfo drv)))
)
)
rtn
)
;;84.14 [功能] 返回磁盘的所有信息
;;用法: (vldos-alldriveinfo DriveLetter[STRING]
)
;; 参数1: 盘符 例如: "C:"
;;返回值 磁盘的所有信息 or NIL
(Defun
vldos-alldriveinfo (Drv / DrvObj FilSys RetVal)
(if
(setq
FilSys (vlax-get-or-create-object
"Scripting.FileSystemObject")
)
(progn
(setq
RetVal
(cond
((= (vlax-invoke FilSys
"DriveExists" Drv) 0) 0)
((setq
DrvObj (vlax-invoke FilSys "GetDrive"
Drv))
(cond
((= (vlax-get DrvObj "IsReady")
0) -1)
((list
(/
(vlax-get-property DrvObj "TotalSize")
1000.0)
(/ (vlax-get-property DrvObj
"FreeSpace") 1000.0)
(vlax-get-property
DrvObj "DriveType")
(vlax-get-property
DrvObj "FileSystem")
(vlax-get-property
DrvObj "SerialNumber")
(vlax-get-property DrvObj "ShareName")
(vlax-get-property DrvObj "VolumeName")
)
)
)
)
)
)
(if (EQUAL (TYPE DrvObj)
'vla-object)
(vlax-release-object
DrvObj)
)
(vlax-release-object FilSys)
)
)
RetVal
)
;;84.15 [功能] 返回文件的特定信息
;;用法: (vldos-fileinfo Filename[STRING]
key[STRING] )
;; 参数1: 文件全路径名
;; 参数2: 所需文件信息的字符串
;;返回值:
文件的特定信息 or
NIL
;|
"DATECREATED"
创建日期
"DATELASTMODIFIED"
修改日期
"DATELASTACCESSED"
最后一次访问时间
"TYPE"
文件类型
"SIZE"
文件大小
"ATTRIBUTES"
文件属性
|;
(Defun vldos-fileinfo (Drv Key / pos rtn)
(if (/= (type
key) 'STR)
(setq rtn (vldos-allfileinfo
drv))
(if (setq pos
(vl-position
(setq key (strcase
key))
(list
"DATECREATED"
"DATELASTMODIFIED"
"DATELASTACCESSED"
"TYPE"
"SIZE"
"ATTRIBUTES"
)
)
)
(setq rtn (nth pos
(vldos-allfileinfo drv)))
)
)
rtn
)
;;84.16 [功能] 返回磁盤的所有信息
;;用法: (vldos-alldriveinfo
DriveLetter[STRING] )
;; 參數1: 盤符 例如: "C:"
;;返回值: 磁盤的所有信息 or
NIL
(defun VLDOS-ALLDRIVEINFO (DRV / DRVOBJ FILSYS RETVAL)
(if
(setq
FILSYS (vlax-get-or-create-object
"Scripting.FileSystemObject")
)
(progn
(setq
RETVAL
(cond
((= (vlax-invoke FILSYS
"DriveExists" DRV) 0) 0)
((setq
DRVOBJ (vlax-invoke FILSYS "GetDrive"
DRV))
(cond
((= (vlax-get DRVOBJ "IsReady")
0) -1)
((list
(/
(vlax-get DRVOBJ "TotalSize") 1000.0)
(/
(vlax-get DRVOBJ "FreeSpace") 1000.0)
(vlax-get DRVOBJ "DriveType")
(vlax-get
DRVOBJ "FileSystem")
(vlax-get DRVOBJ
"SerialNumber")
(vlax-get DRVOBJ
"ShareName")
(vlax-get DRVOBJ
"VolumeName")
)
)
)
)
)
)
(if (equal (type DRVOBJ)
'VLA-OBJECT)
(vlax-release-object
DRVOBJ)
)
(vlax-release-object FILSYS)
)
)
RETVAL
)
;;84.17 [功能] 读文本文件到表 (快于 AutoLISP read-line函数)
;;用法:
(vldos-readfile FilenameToRead[STRING] )
;; 参数1: 文本文件全路径名.
(包括后缀名)
;;
只有文本文件才能返回正确结果.
;;返回值: 返回包括文件内容的表 or NIL
(Defun
vldos-readfile
(Fil / string->list
FilObj FilPth FilSys OpnFil All)
(Defun string->list (String / ID
Rtn)
(if (null (setq ID (vl-string-search "\r\n"
String)))
(setq Rtn (list
String))
(progn
(while
ID
(setq Rtn (cons (substr String 1 ID)
Rtn)
String (substr String (+ 3
ID))
ID (vl-string-search "\r\n"
String)
)
)
(setq Rtn (reverse (cons String
Rtn)))
)
)
Rtn
)
(if (AND (setq FilPth
(findfile Fil))
(setq FilSys (vlax-create-object
"Scripting.FileSystemObject"))
)
(progn
(setq FilObj
(vlax-invoke FilSys "GetFile" FilPth)
OpnFil
(vlax-invoke FilObj "OpenAsTextStream" 1 0)
All (string->list (vlax-invoke OpnFil
"readall"))
)
(vlax-invoke OpnFil
"Close")
(vlax-release-object
OpnFil)
(vlax-release-object
FilObj)
(vlax-release-object
FilSys)
)
)
All
)
;;84.18 [功能]
将字符串或表写入文件 (快于 AutoLISP write-line函数)
;;用法: (vldos-writefile
FileNameString[STRING] ContentStringList[LIST] ModeFlag[BOOLEAN]
)
;; (vldos-writefile
FileNameString[STRING] ContentString[STRING] ModeFlag[BOOLEAN] )
;;
参数1: 文本文件全路径名. (包括后缀名)
;; 参数2: 要写入文件的字符串或表
;; 参数3: 最加或覆盖标志.
nil 最加, T 覆盖
;;返回值: 文本文件全路径名 or NIL
(Defun
vldos-writefile
(Fil TXT Mode
/
list->string
FilObj FilPth
FilSys
OpnFil
Line
)
(Defun
list->string (slist / line rtn)
(if (= (type
slist) 'str)
(setq rtn
slist)
(progn
(setq rtn
"")
(foreach line slist
(if (= rtn
"")
(setq rtn line)
(setq rtn (strcat rtn "\r\n" line))
)
)
)
)
rtn
)
(if TXT
(progn
(if (and Mode (findfile
Fil))
(vl-file-delete Fil)
)
(if (setq FilSys (vlax-create-object
"Scripting.FileSystemObject"))
(progn
(if (null (setq
FilPth (findfile Fil)))
(setq OpnFil
(vlax-invoke-method
FilSys "CreateTextFile"
Fil 0 0)
)
(setq FilObj
(vlax-invoke FilSys "GetFile" FilPth)
OpnFil (vlax-invoke
FilObj "OpenAsTextStream" 8 0)
)
)
(if OpnFil
(progn
;; VBA WinScript data forReading
= 1, forWriting = 2, forAppending = 8;
;; TristateUseDefault, TristateTrue, TristateFalse (-2, -1,
0)
;;TristateUseDefault (-2) Opens the
file using the system default.
;;TristateTrue (-1) Open the file as Unicode.
;;TristateFalse (0) Open the file as
ASCII.
(vlax-invoke OpnFil "Write"
(list->string TXT))
(vlax-invoke
OpnFil "Close")
(vlax-release-object
OpnFil)
(if (= (type FilObj)
'vla-object)
(vlax-release-object
FilObj)
)
(vlax-release-object
FilSys)
)
)
)
)
(if (setq Filpth (findfile
Fil))
(setq FilPth (vldos-formatpath
filpth))
)
)
)
filpth
)
;;84.19 [功能] 目录浏览对话框
;;用法: (vldos-browsedir
PromptString[STRING] )
;;
(vldos-writefile NIL)
;; 参数1: 提示字符串, 如果是 nil, 缺省为 "Select
Folder"
;;返回值: 返回所选目录路径 OR NIL
(Defun vldos-browsedir (msg / WinShell
shFolder path catchit rtn)
(if (null MSG)
(setq
MSG "Select folder")
)
(if (setq winshell
(vlax-create-object "Shell.Application"))
(progn
(setq
shFolder
(vlax-invoke-method WinShell
'BrowseForFolder 0 msg 1)
catchit
(vl-catch-all-apply
'(lambda ()
(setq shFolder (vlax-get-property
shFolder 'self))
(setq path (vlax-get-property
shFolder 'path))
)
)
)
(vlax-release-object shFolder)
(vlax-release-object winshell)
(if
(vl-catch-all-error-p catchit)
(setq rtn nil)
(setq rtn
(vldos-formatpath path))
)
)
)
rtn
)
;;84.20 [功能] 显示
windows 的确认对话框包括图标和可选按钮
;;用法: (vldos-msgbox TitleString[STRING]
IconType[STRING/REAL] MessageString[STRING] ButtonType[INT] )
;; 参数1:
标题字符串, 如果是 nil, 缺省为 "Message"
;; 参数2: 图标类型字符串或整数值. 如果是字符串,
只有第一个字符串有效.
;; 参数3: 消息字符串, 如果是 nil, 缺省为 "Message HERE"
;; 参数4:
按钮类型整数值.
;;返回值: 所选按钮的值 OR NIL
;|;;按钮
;;0 OK
;;1 OK and
Cancel
;;2 Abort, Retry, and Ignore
;;3 Yes, No,
Cancel
;;4 Yes and No
;;5 Retry and Cancel
;;图标类型
;;16
[X] Stop Mark icon
;;32 [?] Question Mark icon
;;48 [!] Exclamation Mark
icon
;;64 [i] Information Mark icon
;; 返回值所代表的按钮
;;1 OK
button
;;2 Cancel button
;;3 Abort button
;;4 Retry
button
;;5 Ignore button
;;6 Yes button
;;7 No
button
|;
(Defun vldos-msgbox (TITLE ICON MSG BTNS / IDT sys
BTN)
(if (setq sys (vlax-get-or-create-object
"WScript.Shell"))
(progn
(if (not (equal (type TITLE) 'STR))
(setq TITLE
"Message")
)
(cond ((null ICON) (setq ICON 64))
((= (type ICON)
'STR)
(setq ICON (substr (strcase ICON) 1
1)
IDT (list (cons "X"
16)
(cons "?"
32)
(cons "!"
48)
(cons "i"
64)
)
ICON (cdr (assoc
ICON IDT))
)
(if (null ICON)
(setq ICON
64)
)
)
((= (type ICON)
'INT)
(if (null (member ICON (list 16 32 48
64)))
(setq ICON
64)
)
(t
(setq ICON 64))
)
)
(if (not (equal (type MSG)
'STR))
(setq MSG "Message HERE")
)
(cond ((null BTNS) (setq BTNS
0))
((= (type BTNS)
'INT)
(if (or (< BTNS 0) (> BTNS
5))
(setq BTNS
0)
)
)
(t (setq BTNS
0))
)
(setq
BTN (vlax-invoke-method sys 'popup MSG 0 TITLE (+ ICON
BTNS))
)
(vlax-release-object sys)
)
)
BTN
)
;;84.21 [功能] 当前目录文件搜索. 类似于 DIR /S 命令.
;;用法: (vldos-findfile
FilenameFullPathString[STRING] )
;;
(vldos-writefile NIL)
;; 参数1: 文件名. 可以包括扩展符 ("*" and
"?").
;; 如果文件名描述符为 nil
,返回所有的文件包括子目录。
;;返回值: 包括所有符合条件的文件名 OR NIL
(Defun vldos-findfile
(Filename /
string->list
getallfiles allfiles
path
)
(Defun
string->list (String / ID Rtn)
(if (null (setq ID
(vl-string-search ";" String)))
(setq Rtn
(list String))
(progn
(while
ID
(setq Rtn (cons (substr String 1 ID)
Rtn)
String (substr String (+ 2
ID))
ID (vl-string-search ";"
String)
)
)
(setq Rtn (reverse (cons String
Rtn)))
)
)
Rtn
)
(Defun getallfiles (loc ext /
path files rtn)
(cond
((= loc "")
(foreach path
(string->list (getvar "acadprefix"))
(setq rtn (append rtn
(getallfiles path ext)))
)
)
((vl-file-directory-p loc)
(if (null
(wcmatch loc "*\\"))
(setq loc (strcat loc
"\\"))
)
(foreach files
(vl-directory-files loc ext)
(setq rtn (cons (vldos-formatpath (strcat
loc files)) rtn))
)
(foreach path (vl-directory-files
loc nil -1)
(if (and (/= path ".")
(/= path
"..")
)
(setq rtn
(append rtn (getallfiles (strcat loc path) ext)))
)
)
)
)
rtn
)
(setq path (vldos-formatpath (vl-filename-directory
Filename))
Filename (substr Filename (1+ (strlen
path)))
allfiles (acad_strlsort (getallfiles path filename))
)
allfiles
)
;;84.22 [功能] 合并两个文本文件
;;用法: (vldos-merge
MergeBaseFilenameString[STRING] MergeFilenameString[STRING]
EraseMergefileFlag[BOOLEAN] )
;; 参数1: 基文件名
;; 参数2:
将被合并的文件名
;; 参数3: 是否删除被合并文件的标志.
;;返回值: 合并后的文件名 OR NIL
(Defun
vldos-merge (file1 File2 Erase / rtn)
(if (and (setq file1 (findfile
file1))
(setq file2 (findfile
file2))
)
(progn
(vldos-writefile file1 (vldos-readfile
file2) nil)
(if Erase
(vl-file-delete
File2)
)
(setq rtn (findfile file1))
)
)
rtn
)
;;85.1 [功能] 字符串分割
;;http://www.mjtd.com/function/info-129-216.html,有修改 黄明儒
2013年8月9日
;;(parse1 "aa 10 b10x20.2" ".")返回("aa 10 b10x20"
"2")
;;(parse1 "aa 10 b10x20.2" " "),("aa" "10"
"b10x20.2")
;;(parse1 "aa 10 b10x20.2" ""),死循环
(defun parse1 (str
delim / LST POS)
(while (setq pos (vl-string-search delim
str))
(setq lst (cons (substr str 1 pos)
lst)
str (substr str (+ pos 2))
)
)
(if (> (strlen str) 0)
(setq
lst (cons str lst))
)
(vl-remove "" (reverse
lst))
)
;;85.2 [功能]
字符串分割
;;http://www.mjtd.com/function/info-129-444.html，修改xl:read->biao
黄明儒 2013年8月9日
;;(parse2 "aa 10 b10x20.2" " "),("aa" "10"
"b10x20.2")
;;(parse2 "aa 10 b10x20.2" ""),死循环
(defun parse2 (str
delim / LST POS)
(while (setq pos (vl-string-search delim
str))
(setq lst (append lst (list (substr str 1
pos))))
(setq str (substr str (+ 2 pos)))
)
(if (> (strlen str) 0)
(vl-remove ""
(append lst (list str)))
(vl-remove "" lst)
)
)
;;85.3 [功能] 字符串分割 By
st788796
;;这是一个很万能的分割法，只不过delim写法复杂
;;示例:,分割(parse3 "A 3.2测,试5.66D"
"[^,]+");;("A 3.2测" "试5.66D")
;;空格分割(parse3 "A 3.2测,试5.66D" "[^\\s]+");;("A"
"3.2测,试5.66D")
;;中英文空格(parse3 "A 3.2测,试5.66D"
"[\\u4E00-\\u9FA5]+|[^\\u4E00-\\u9FA5/ ]+|[\\s]+");;("A" " " "3.2" "测" "," "试"
"5.66D")
;;中文(parse3 "A 3.2测,试5.66D" "[\\u4E00-\\u9FA5]+");;("测"
"试")
;;英文(parse3 "A 3.2测,试5.66D" "[^\\u4E00-\\u9FA5]+");;("A 3.2" ","
"5.66D")
(defun parse3 (str delim)
(xd::string:regexps delim str
"")
)
;;85.4 [功能] 字符串分割
;;这是一个很牛的分割法(基本同parse8 parse12
parse14)，容易理解
;;delim是一个字符串集合，其中的每一个字符都会被当作是分割符号 by qjchen@gmail.com
;;如 (parse4 "符号25 35 45 ;
55, 66 " " ;")=> ("符号25" "35" "45" "55," "66")
;;(parse4 "aa ,10
b.10x20,.2" ",.")("aa " "10 b" "10x20" "2")
;;(parse4 "aa 10 b10x20.2"
" ")("aa" "10" "b10x20.2")
;;(parse4 "aa 10 b10x20.2" "")("aa 10
b10x20.2")
(defun parse4 (str delim / L1 L2)
(setq str (vl-string->list str)
delim
(vl-string->list delim)
)
(while
str
(if (not (member (car str)
delim))
(setq l1 (cons (car str)
l1))
(if l1
(setq l2 (cons
(vl-list->string (reverse l1)) l2)
l1
nil
)
)
)
(setq str (cdr str))
)
(if
l1
(setq l2 (cons (vl-list->string (reverse l1))
l2))
)
(reverse l2)
)
;;85.5 [功能]
字符串分割(这highflybird回答我的求助,简洁)
;;(parse5 "aa 10 b10x20.2" "")返回("AA" "10"
"B10X20")
;;(parse5 "aa 10 b10x20.2" ".")返回("AA" "10" "B10X20" "2")
(defun
parse5 (Str delim / str lst)
;;替换成空格，为后面转化作准备，问题是如果字符中原来就有空格
(setq str (VL-STRING-TRANSLATE delim " " Str))
(setq str (strcat "("
str ")")) ;加括号
(setq lst (read
str)) ;读
(mapcar 'VL-PRINC-TO-STRING
lst) ;转化
)
;;85.6 [功能] 用分隔符解释字符串成表 ;by fsxm
;;空格"
"，不能用"" ，一个空格就转成一个字符
;;(parse6 "aa 10 b10x20.2" " ")返回("aa" "10"
"b10x20.2")
;;(parse6 "aa 10 b10x20.2" "")死循环
(defun parse6
(Str delim / PO STRLST XLEN)
(setq xlen (1+ (strlen delim)))
(while (setq po (vl-string-search delim Str))
(setq strlst
(cons (substr Str 1 po) strlst))
(setq Str (substr Str (+
po xlen)))
)
(vl-remove "" (reverse (cons Str
strlst)))
)
;;85.7 [功能] 字符串分割 黄明儒
2013年8月9日
;;改自梁雄啸str2lst1;同parse5,也parse6一样，空格不能有""替代
;;(parse7
"aa 10 b10x20.2" " ");("aa" "10" "b10x20.2")
;;(parse7
"aa 10 b10x20.2" "")死循环
;;(parse7 "aa 10 b10x20.2" " ")("aa" "10"
"b10x20.2")与parse5不同，不会去掉.2
;;(parse7 "aa 10 b10x20.2" "x")("aa
10 b10" "20.2")
(defun parse7 (str delim / I)
(while (setq i
(vl-string-search
delim
str
(if i
(+
2 i)
0
)
)
)
(setq str (vl-string-subst
"\"\"" delim str i))
)
(vl-remove "" (read (strcat "(\"" str
"\")")))
)
;;85.8 [功能] 字符串分割(基本同parse4 parse12 parse14)
;;改自梁雄啸str2lst2
黄明儒 2013年8月9日
;;(parse8 "aa ,10 b.10x20,.2" ",.")("aa " "10 b" "10x20"
"2")
;;(parse8 "aa 10 b10x20.2" " ")("aa" "10" "b10x20.2")
;;(parse8
"aa 10 b10x20.2" "")("aa 10 b10x20.2")
;;(vl-list->string
'(40));"("
;;(vl-list->string '(34)),"\""
;;(vl-list->string
'(32))," "
(defun parse8 (str delim / DELIM STRLST X)
(setq delim
(vl-string->list delim))
(setq strlst
(apply
'append
(mapcar '(lambda
(x)
(if (member x
delim)
(list 34 32 34)
(list
x)
)
)
(append (list
40 34) (vl-string->list str) (list 34 41))
)
)
)
(vl-remove "" (read (vl-list->string
strlst)))
)
;;85.9 [功能] 字符串分割 (纯lisp法)
;;改自梁雄啸str2lst3 黄明儒
2013年8月9日
;;(parse9 "aa 10 b10x20.2" " ");("aa" "" "" "10"
"b10x20.2")
;;(parse9 "aa 10 b10x20.2" ""),没作用，但不进入死循环
(defun
parse9 (str delim / I S STR1 STRLST)
(defun remove (lst
ele) ; by Serge Volkov
(apply
'append (subst nil (list ele) (mapcar 'list lst)))
)
(setq i 0
str1 ""
)
(while (/= "" (setq s
(substr str (setq i (1+ i)) 1)))
(cond ((/= delim s) (setq
str1 (strcat str1 s)))
(T
(setq
strlst (append strlst (list str1))
str1 ""
)
)
)
)
(if (/= str1 "")
(remove (append
strlst (list str1)) "")
(remove strlst "")
)
)
;;85.10 [功能] 字符串分割(纯lisp法)
;;改自梁雄啸str2lst 黄明儒
2013年8月9日
;;(parse10 "aa 10 b10x20.2" " ");("aa" "10"
"b10x20.2")
;;(parse10 "aa 10 b10x20.2" ""),("aa 10
b10x20.2")
(defun parse10 (str delim / I S STR1)
(defun
remove (lst ele) ; by Serge
Volkov
(apply 'append (subst nil (list ele) (mapcar 'list
lst)))
)
(setq i 0
str1 ""
)
(while (/= "" (setq s (substr str (setq i (1+ i))
1)))
(setq str1 (strcat
str1
(if (= delim
s)
"\" \""
s
)
)
)
)
(remove (read (strcat "(\"" str1 "\")"))
"")
)
;;85.11 [功能] 字符串分割 By wowan1314
;;(parse11 "aa 10
b10x20.2" " ");("aa" "10" "b10x20.2")
;;(parse11 "aa 10 b10x20.2"
""),死循环
(defun parse11 (str delim / LST POS)
(while
(setq pos (vl-string-search delim
str))
(setq lst (cons (substr str 1 pos)
lst)
str (substr
str
(+ 1 pos (strlen
delim))
)
)
)
(vl-remove "" (reverse
(cons str lst)))
)
;;85.12 [功能] 字符串分割 By st788796
;;基本同上parse4 parse8
parse14
;;(parse12 "aa ,10 b.10x20,.2" ",."),("aa ,10 b.10x20"
"2")
;;(parse12 "aa ,10 b.10x20,.2" "")死循环
(defun parse12 (str delim /
POST STRL STRLST)
(setq strl (strlen delim))
(while
(vl-string-search delim str)
(setq post (vl-string-search
delim str))
(setq strlst (append strlst (list (substr str
1 post))))
(setq str (substr str (+ post (1+
strl))))
)
(vl-remove "" (append strlst (list
str)))
)
;;85.13 [功能] 字符串分割 By st788796
;;(parse13 "aa ,10 b.10x20,.2"
"")("aa ,10 b.10x20,.2")
;;(parse13 "aa ,10 b.10x20,.2" " ")("aa"
",10" "b.10x20,.2")
(defun parse13 (str delim / vbs ret)
(if
(or
**ScriptControl**
(setq **ScriptControl**
(vlax-create-object "ScriptControl"))
)
(progn
(vlax-put
**ScriptControl** "Language" "VBS")
(setq
vbs
(strcat "Dim ret\n" "s =
\"" str
"\"\nsn =
\"" delim "\"\nret =
Split(s,sn)"
)
)
(vlax-invoke **ScriptControl** 'ExecuteStatement
vbs)
(setq ret (vlax-invoke **ScriptControl**
'eval "ret"))
)
)
(vl-remove ""
ret)
)
;;;;;;;;;指定字母后的数字 By 自贡黄明儒 2016.4.7
;;(parse14 "100D200 DE 1050
SF-1" "DE")＝>1050.0
;;(parse14 "100D200 自贡105 自贡-1"
"自贡")＝>105.0
(defun parse14 (str delim / DE)
(setq de
delim)
(setq str (vl-string->list str)
de
(vl-string->list de)
)
(while (not (vl-every '= de
str))
(setq str (cdr str))
)
(setq str (vl-list->string str))
(atof (VL-STRING-LEFT-TRIM delim
str))
)
;;;;;;;;;指定字母后的数字 By 自贡黄明儒 2016.4.7
;;85.15 [功能] 从后面取
指定字符后的字符
;;示例(HH:GetBehindStr1 "5.4自贡2.3自贡4.3" "自贡")=>"A4.3"
(defun
HH:GetBehindstr1 (str st) ;区分大小写
(car (xd::string:regexps (strcat
"[^" st "]+$") str "I"))
)
;;(HH:GetBehindStr2 "5.4a2.3aA4.3"
"a");返回"4.3"
(defun HH:GetBehindstr2 (str st)
(car (parse3 str
(strcat "[^" st "]+$")))
)
;;85.16 [功能] 从前面取 指定字符前的字符
;;(HH:GetBeforeStr1 "5.4自贡2.3自贡4.3"
"自贡")=>"5.4"
(defun HH:GetBeforeStr1 (str st);区分大小写
(car
(xd::string:regexps (strcat "[^" st "]+") str
"I"))
)
;;示例(HH:GetBeforeStr2 "5.4a2.3aA4.3" "A");返回"5.4"
(defun
HH:GetBeforeStr2 (str st)
(car (parse3 str (strcat "[^" st
"]+")))
)
;;85.17 [功能] 取文字末尾的数字和小数点 By
自贡黄明儒
;;http://bbs.mjtd.com/thread-107150-1-1.html中定义xd::string:regexps
;;示例(HH:EndNumber1+
"5.4aAa2.3")，返回"2.3"
(defun HH:EndNumber1+ (str)
(car
(xd::string:regexps "(\\d+)?[.]?(\\d+)+$" str
""))
)
;;示例(HH:EndNumber2+ "5.4aAa2.3")，返回"2.3"
(defun HH:EndNumber2+
(str)
(car (parse3 str "(\\d+)?[.]?(\\d+)+$"))
)
;;85.18 [功能] 取文字末尾的数字 By
自贡黄明儒
;;http://bbs.mjtd.com/thread-107150-1-1.html中定义xd::string:regexps
;;示例(HH:EndNumber1
"5.4a2.32")，返回"32"
(defun HH:EndNumber1 (str)
(car
(xd::string:regexps "\\d+$" str
""))
)
;;示例(HH:EndNumber2 "5.4a2.32")，返回"32"
(defun HH:EndNumber2
(str)
(car (parse3 str "\\d+$"))
)
;;85.19 [功能] 取文字前的数字和小数点 By
自贡黄明儒
;;http://bbs.mjtd.com/thread-107150-1-1.html中定义xd::string:regexps
;;示例(HH:StartNumber+
"5.42a2.3")，返回"5.42"
(defun HH:StartNumber+ (str)
(car
(xd::string:regexps "^(\\d+)?[.]?(\\d+)+"
str ""))
)
;;85.20 [功能] 取文字前的数字 By
自贡黄明儒
;;http://bbs.mjtd.com/thread-107150-1-1.html中定义xd::string:regexps
;;示例(HH:StartNumber1
"5.4a2.32")，返回"5"
(defun HH:StartNumber1 (str)
(car
(xd::string:regexps "^\\d+" str ""))
)
;;示例(HH:StartNumber2
"5.4a2.32")，返回"5"
(defun HH:StartNumber2 (str)
(car (parse3 str
"^\\d+"))
)
;;85.21 [功能] 取文字中的数字 By
自贡黄明儒
;;http://bbs.mjtd.com/thread-107150-1-1.html中定义xd::string:regexps
;;示例(HH:GetStrNumber1
"5.4a2.32c")，返回("5.4" "2.32")
(defun HH:GetStrNumber1 (str)
(xd::string:regexps "(\\d+)?[.]?(\\d+)+" str
"");(parse3 str "(\\d+)?[.]?(\\d+)+")
)
;;85.22 [功能] 字符串内容是否是数字 By 自贡黄明儒
;;示例(HH:StrIsNumber
"5.4")，返回5.4
;;(HH:StrIsNumber (HH:EndNumber+ "5.4a2.3")),返回2.3
(defun
HH:StrIsNumber (str)
(distof str)
)
;;85.23 [功能]
字符串末尾数字+1
;;http://bbs.mjtd.com/thread-107150-1-1.html中定义xd::string:regexps
;;http://bbs.mjtd.com/forum.php?mod=post&action=edit&fid=3&tid=107420&pid=608841&page=2中定义XD::String:Replace
;;示例(HH:EndNumberAdd
"a3.02");返回"a3.03"
(defun HH:EndNumberAdd (str / I STR1 STR2)
(if
(setq str1 (car (xd::string:regexps "\\d+$" str
"")))
(progn (setq str2 (itoa (1+ (atoi
str1)))) ;提取的尾数+1
(setq i (- (strlen str1)
(strlen str2)))
(if (> i
0)
(repeat i (setq str2 (strcat "0"
str2)))
)
(XD::String:Replace "\\d+$" str str2 "")
)
(strcat str "1")
)
)
;;85.24 [功能] 特殊字符处理
;;示例(ACET-STR-ESC-WILDCARDS1 "#a@b");"`#a`@b"
;;http://bbs.mjtd.com/forum.php?mod=post&action=edit&fid=3&tid=107420&pid=608841&page=2中定义XD::String:Replace
(defun
ACET-STR-ESC-WILDCARDS1 (A / X LST)
;;(ACET-STR-REPLACE "B" "2"
"ssABCsBs");"ssA2Cs2s"
(defun ACET-STR-REPLACE1 (o n
s)
(XD::String:Replace (strcat "[" o "]") s n
"I")
)
(SETQ LST '("#" "@" "." "*" "?" "~" "[" "]"
","))
(foreach X LST
(SETQ A (ACET-STR-REPLACE1
X (STRCAT "`" X) A))
)
A
)
;;85.25 [功能] 字符查找替换
;;示例(ACET-STR-REPLACE1 "B" "2"
"ssABCsBs");"ssA2Cs2s"
;;ET安装后函数是(ACET-STR-REPLACE "B" "2"
"ssABCsBs")
(defun ACET-STR-REPLACE1 (o n s)
(XD::String:Replace
(strcat "[" o "]") s n "I")
)
;;85.26 [功能] 字符分割(见85.3,不区分大小写)
;;示例(ACET-STR-TO-LIST1 "B"
"ssABCsBs");("ssA" "Cs" "s")
;;ET安装后函数是(ACET-STR-TO-LIST "B"
"ssABCsBs")
(defun ACET-STR-TO-LIST1 (d str)
(XD::String:RegExpS
(strcat "[^" d "]+") str "I")
)
;;85.27 [功能] 字符串内是否包含指定的字符
;;示例(ACET-STR-WCMATCH "ssABCsBs"
"*c*");T
(defun ACET-STR-WCMATCH1 (str f)
(if (XD::String:RegExpS
(strcat "[" f "]+") str "")
T
)
)
;;85.28 [功能] 倒置字符串
;;示例(HH:StrReverse1 "明经cad");返回"dac经明"
(defun
HH:StrReverse1 (stri / STR)
(setq str(VL-PRIN1-TO-STRING
stri))
(wscriptPublic (strcat "Dim ret \n ret=StrReverse(" str ")
"))
)
;;示例(HH:StrReverse2 "明经cad");返回"dac经明"
(defun HH:StrReverse2 (str /
STR1)
(setq str1 (xd::string:regexps
"[\\u4E00-\\u9FA5]|[^\\u4E00-\\u9FA5/ ]|[\\s]+" str ""))
(apply
'strcat (REVERSE str1))
)
;;85.29 [功能] 中英文分割
;;示例(HH:ChineseAndEn "明经cad");返回("明经" "cad")
(defun
HH:ChineseAndEn (str)
(parse3 str
"[\\u4E00-\\u9FA5]+|[^\\u4E00-\\u9FA5/ ]+|[\\s]+")
)
;;85.30 [功能] 提取中文
;;示例(HH:GetChinese "明经cad");返回("明经")
(defun
HH:GetChinese (str)
(parse3 str "[\\u4E00-\\u9FA5]+")
)
;;85.31 [功能] 提取英文
;;示例(HH:GetEnglish "明经cad");返回("cad")
(defun
HH:GetEnglish (str)
(parse3 str "[^\\u4E00-\\u9FA5/
]+")
)
;;85.32 [功能] 输入对话框
;;示例(HH:InputBox "显示重量,便于拷贝" "重量显示" "5.3")
(defun
HH:InputBox (promptstr title default)
;;(setq str (VL-PRIN1-TO-STRING
default))
(wscriptPublic (strcat "dim ret \n ret=InputBox(\""
promptstr "\", \"" title "\", \"" default "\")"))
)
;;85.33 [功能] 自定义计算器
;;05以上(cal "(2+3)*5")(c:cal
"(2+3)*5")可以运行。04可以不加载(ARXLOAD "GEOMCAL")而自定义
;;示例(MyCal
"(2+3)^2*5");返回125.0
(defun MyCal (express)
(wscriptPublic
(strcat "dim ret \n ret=" express))
)
;;85.34 [功能] 打开对话框
;;(HH:getfiled1)返回文件名(全路径)
(defun HH:getfiled1 (/
str)
(setq str
"Function
GetTargetFileName
Set
objDialog =
CreateObject(\"UserAccounts.CommonDialog\")
objDialog.Filter =
\"DwgFile(*.dwg)|*.dwg\"
objDialog.InitialDir = \".\"
If objDialog.ShowOpen <> 0
Then
GetTargetFileName =
objDialog.FileName
End
If
Set objDialog =
Nothing
End Function
ret = GetTargetFileName
"
)
(wscriptPublic str)
)
;;85.35 [功能] 打开对话框
;;(HH:getfiled2)
(defun
HH:getfiled2 (/ DIALOG FILE)
(setq Dialog (vlax-create-object
"UserAccounts.CommonDialog"))
(vlax-put-property Dialog 'Filter
"DwgFile(*.dwg)|*.dwg")
(vlax-put-property Dialog 'InitialDir
".")
(vl-catch-all-apply
'(lambda
()
(vlax-invoke-method Dialog
'ShowOpen)
(setq file (vlax-get Dialog
'filename))
)
)
(vlax-release-object Dialog)
file
)
;;85.36 [功能]
打开对话框
;;(LM:Open "C:\\My Folder\\My SubFolder")
;;(LM:Open "C:\\My
Folder\\File.dwg")
(defun LM:Open ( target / shell result
)
(if
(and
(or
(eq 'INT (type
target))
(setq target (findfile
target))
)
(setq
shell (vla-getInterfaceObject (vlax-get-acad-object)
"Shell.Application"))
)
(progn
(setq result (vl-catch-all-apply 'vlax-invoke (list shell 'open
target)))
(vlax-release-object
shell)
(not (vl-catch-all-error-p
result))
)
)
)
;;85.37 [功能]取末尾的数字
;;(_GetBehindNum
"32.1字23.12")=>"12"
(defun _GetBehindNum (str / CODE)
(setq code
(reverse (vl-string->list str)))
(setq code (atoi
(VL-LIST->STRING code)))
(setq code (VL-PRINC-TO-STRING
code))
(VL-LIST->STRING (reverse (vl-string->list
code)))
)
;;(_GetBehindNum "32.1字23.020")=>"020"
(defun
_GetBehindNum (str / CODE L)
(setq L "")
(while (setq code
(_TailIsNum str))
(setq str (VL-STRING-RIGHT-TRIM code
str))
(setq L (strcat code L))
)
)
;;85.38
[功能] 字符串末尾是否是数字
;;(_TailIsNum "32.1字23.9")=>"9"
;;(_TailIsNum
"32.1字")=>nil
(defun _TailIsNum (str / CODE)
(setq code (last
(vl-string->list str)))
(cond ((< 47 code 58) (chr
code)))
)
;;85.39 [功能] 末尾的数字+1
;;(BehindNumAdd
"32.1字")=>"32.1字1"
;;(BehindNumAdd
"32.1字23.009")=>"32.1字23.010"
(defun BehindNumAdd (str / HEAD I STR1
STR2)
(if (_TailIsNum str)
(progn (setq str1
(_GetBehindNum str))
(setq Head (vl-string-right-trim str1
str))
(setq str2 (VL-PRINC-TO-STRING (1+ (atoi
str1))))
(setq i (- (strlen str1) (strlen
str2)))
(if (> i 0)
(repeat i (setq str2 (strcat "0" str2)))
)
(strcat Head
str2)
)
(strcat str "1")
)
)
;;85.40 [功能] 所有数字+1
;;(_AllNumAdd
"5.04a2.320c")=>"6.04a3.32c"
;;(_AllNumAdd "kkkkc")=>nil
(defun
_AllNumAdd (str / LST NSTR OSTR)
(setq lst (HH:GetStrNumber1
str))
(repeat (length lst)
(setq Ostr (car
lst))
(setq Nstr(VL-PRINC-TO-STRING (1+ (distof
Ostr))))
(setq lst (cdr lst))
(setq
str (vl-string-subst Nstr Ostr str))
)
)
;;86.1 [功能] Exports the specified project to
disk
;;
;; Arguments: The name of a project and the full path to a
file ;;
;; 示例: (MJ:ExportProject "Johnson"
"c:\\temp\\project.txt")
;;
(defun MJ:ExportProject (pName fName / fh prj)
(vl-load-com)
(setq fh (open fName "w"))
(if (setq
prj (vl-registry-read
(strcat
"HKEY_CURRENT_USER\\"
(vlax-product-key)
"\\Profiles\\"
(getvar
"CPROFILE")
"\\Project Settings\\"
pName
)
"RefSearchPath"
)
)
(progn
(write-line
(strcat "[" pName "] ") fh)
(foreach
folder
(MJ:Parse prj
";")
(write-line folder fh)
)
)
(princ "\nThe specified windows
registry key is not exists."
)
)
(close fh)
(princ)
)
;;86.2 [功能] Imports a project exported by
MJ:ExportProject
;;
;; Arguments: The full path to a file containing an exported
project ;;
;; 示例: (MJ:ImportProject
"c:\\temp\\project.txt")
;;
(defun MJ:ImportProject (fName / pName fh l lst)
(vl-load-com)
(if (setq fh (open fName "r"))
(progn
(setq pName (read-line
fh)
pName (substr pName 2 (- (strlen pName)
2))
lst
""
)
(while
(setq l (read-line fh))
(setq lst (strcat lst l
";"))
)
(vl-registry-write
(strcat "HKEY_CURRENT_USER\\"
(vlax-product-key)
"\\Profiles\\"
(getvar
"CPROFILE")
"\\Project
Settings\\"
pName
)
"RefSearchPath"
(substr
lst 1 (1- (strlen lst)))
)
(close fh)
)
)
(princ)
)
;;87.1 [功能] 包围对象最小最大点列表
;; 示例: (Entity:Box (car (entsel)))返回
((左下角点)(右上角点))
(defun Entity:Box (e / BP UP)
(cond ((equal (type e)
'ENAME) (setq e (vlax-ename->vla-object e))))
(vla-getboundingbox e
'bp 'up)
(list (safearray-value bp) (safearray-value
up))
)
;;87.2 [功能] 选择集的实体外矩形框 by gxl
(defun MJ:GetssBox (ss / i l1 l2
ll ur)
(repeat (setq i (sslength ss))
(vla-getboundingbox
(vlax-ename->vla-object
(ssname ss (setq i (1- i))))
'll
'ur
)
(setq l1 (cons (vlax-safearray->list ll)
l1)
l2 (cons (vlax-safearray->list ur)
l2)
)
)
(mapcar '(lambda (a b) (apply
'mapcar (cons a b)))
'(min max)
(list l1
l2)
)
)
;;87.3 [功能] 选择集的包围盒 By highflybird
(defun
SC:SSBox (objs / MinPt MaxPt MinPts MaxPts w2u u2W)
(if (zerop
(getvar "WORLDUCS"))(MAT:Trans 0 1)
(setq w2u (MAT:Trans 0
1)
u2w (MAT:Trans 1 0)
)
)
(foreach obj objs
(and IsUCS (vla-TransformBy
obj (vlax-tmatrix w2u)))
(vla-GetBoundingBox obj 'MinPt
'MaxPt)
(setq MinPt (vlax-safearray->list
MinPt))
(setq MaxPt (vlax-safearray->list
MaxPt))
(setq MinPts (cons MinPt
MinPts))
(setq MaxPts (cons MaxPt
MaxPts))
(and IsUCS (vla-TransformBy obj (vlax-tmatrix
u2w)))
)
(list
(apply 'mapcar (cons
'min minpts))
(apply 'mapcar (cons 'max MaxPts))
)
)
;;88 [功能] 返回曲线长度(包括块内曲线)
;; 示例: (MJ:GetCurveLength (car
(nentsel)))
(defun MJ:GetCurveLength (curve)
(vlax-curve-getDistAtParam
curve
(vlax-curve-getEndParam curve)
)
)
;;89 [功能] Returns the size of the specified file in bytes
;;
示例: (MJ:GetFileSize "c:\\autoexec.bat")
;;
Notes: 1. There are reports of VL-FILE-SIZE and
ACET-FILE-SIZE malfunction
on
;;
Win2K systems. Use this as a substitute. It requires
SCRRUN.DLL.
;; Visit the Microsoft scripting web site if
you do not have it.
(defun MJ:GetFileSize (fileName / fso file
size)
(cond ((findfile fileName)
(setq file
(vlax-invoke-method *FSO* 'GetFile
fileName)
size (vlax-variant-value
(vlax-get-property file 'Size))
)
(vlax-release-object
file)
)
)
size
)
;;90.1 [功能] 返回文字样式字体高度
;; 示例: (MJ:GetLastHeight
"standard")
(defun MJ:GetLastHeight (style)
(vla-get-LastHeight (vla-Item (vla-get-TextStyles *DOC*) style))
)
;;90.2 [功能] 设置文字样式字体高度
;; 示例: (MJ:SetLastHeight "standard"
2.5)
(defun MJ:SetLastHeight (style height)
(vla-put-LastHeight (vla-Item (vla-get-TextStyles *DOC*) style) height)
)
;;91 [功能] Returns the LISP value of an ActiveX
variant.
;;
;; Arguments: An ActiveX variant or
safearray.
;;
;; 示例: (MJ:lisp-value MJ:Variant)
;;
;; Notes: This function
will recursively dig into a safearray and convert all
;;
;;
values, including nested safearray's, into a LISP value.
;;
(defun MJ:lisp-value (v)
(cond
((= (type
v) 'variant) (MJ:lisp-value (variant-value v)))
((= (type
v) 'safearray) (mapcar 'MJ:lisp-value (safearray-value
v)))
(T v)
)
)
;;92.1 [功能] Attach Extended Entity Data to an AutoCAD
object. ;;
;;
Arguments: An ActiveX object and an Extended Entity Data list in the same format
as
;;
;;
returned by GetXData. ;;
;;
示例: (MJ:PutXData MJ:VlaObj '((1001 . "ACADX") (1000 .
"MJ:StringData"))) ;;
;; Notes: The Extended
Entity Data application names as noted in the 1001 group
;;
;; code
must be registered with the AutoLISP function REGAPP prior
to
;;
;;
attaching data to an object. See the AutoCAD help files for valid
Extended;;
;;
Entity Data codes and
values.
;;
(defun MJ:PutXData (vlaObj XData)
(setq XData
(MJ:BuildFilter
(mapcar
'(lambda (item / key)
(setq key (car item))
(if
(<= 1010 key 1033)
(cons key
(vlax-variant-value
(vlax-3d-point
(cdr
item)
)
)
)
item
)
)
XData
)
)
)
(vla-setXData vlaObj (car XData) (cadr XData))
)
;;92.2 [功能] Get Extended Entity Data attached to an AutoCAD object.
;;
Arguments: An ActiveX object and an application name that has been registed
with
;;
;; the
AutoLISP function REGAPP. ;;
;;
示例: (MJ:GetXData MJ:VlaObj "ACADX")
;;
;; Notes: Returns a list
of Extended Entity Data attached to the object. ;;
(defun
MJ:GetXData (vlaObj AppID / xType XData)
(vla-getxdata vlaObj AppID
'xType 'xData)
(mapcar '(lambda (key val) (cons key (MJ:lisp-value
val)))
(vlax-safearray->list xType)
(vlax-safearray->list xData)
)
)
;;93.1 [功能] 面积标注
;;
;; Arguments: The entity name of any object that supports the Area
property
;;
;; (Arc,
Circle, Ellipse, LWPolyline, Polyline, Region or Spline) ;;
;;
示例: (MJ:LabelArea (car (entsel)))
;;
;; Notes: 1. The first
time an entity is labeled, the text will appear at
the
;;
;;
entity's start point or center point
;;
;; 2.
Call MJ:LabelArea again to update a label. The label will update
;;
;; regardless of its current
position
;;
;; 3.
The are is formatted in the current units ;;
(defun
MJ:LabelArea (ent / elist xdata text start area)
(regapp
"LABELAREA")
(setq elist (entget ent
'("LABELAREA"))
xdata (assoc -3 elist)
text (if
xdata
(entget (handent (cdr (cadadr
xdata))))
)
start (if (not
text)
(cdr (assoc 10
elist))
)
area
(vla-get-area (setq ent (*En2Obj* ent)))
)
(if (not
text)
(progn
(setq
text (vla-addtext
(vla-get-block
(vla-item
*LOUTS*
(cdr (assoc 410 elist))
)
)
(rtos
area)
(vlax-3d-point
start)
0.25
)
)
)
(vla-put-textstring
(setq text (*En2Obj* (cdr
(assoc -1 text))))
(rtos
area)
)
)
(vla-setxdata
ent
(vlax-make-variant
(vlax-safearray-fill
(vlax-make-safearray vlax-vbInteger '(0 .
1))
'(1001 1005)
)
)
(vlax-make-variant
(vlax-safearray-fill
(vlax-make-safearray vlax-vbVariant '(0 .
1))
(list "LABELAREA" (vla-get-handle
text))
)
)
)
(princ)
)
;;93.2 [功能]
面积求和
;;highflybird写的那个程序,长度、面积、惯性矩...什么都能
(defun ToTAreah (/ EN N SS
TOT_AREA)
(if (setq ss (ssget '((-4 .
"<OR")
(0 . "POLYLINE")
(0 .
"LWPOLYLINE")
(0 . "CIRCLE")
(0 .
"ELLIPSE")
(0 . "SPLINE")
(0 .
"REGION")
(-4 .
"OR>")
)
)
)
(progn
(setq n
-1)
(setq tot_area
0)
(repeat
(sslength ss)
(setq en (ssname ss (setq n (1+ n))))
(command
"._area" "_O" en)
(setq tot_area (+ tot_area (getvar
"area")))
)
)
)
tot_area
)
;;94 [功能] 重命名布局
;; 示例: (MJ:RenameLayout "Layout1"
"MJ:Layout")
(defun MJ:RenameLayout (oldName newName)
(vla-put-name (vla-item *LOUTS* oldName) newName)
)
;;95 [功能] 返回打开文件列表(见10.1)
;; 示例: (MJ:ListDocuments)返回 ("Drawing1.dwg"
"Drawing2.dwg")
(defun MJ:ListDocuments (/ fname lst)
(vlax-for doc *DOCS*
(setq
lst (cons (if (/= (setq fname
(vla-get-fullname doc)) "")
fname
(vla-get-name doc)
)
lst
)
)
)
(reverse lst)
)
;;96 [功能] 返回布局列表
;; 示例:(MJ:ListLayouts)返回 ("Model" "MJ:Layout"
"Layout2")
(defun MJ:ListLayouts (/ layouts c lst lay)
(setq
layouts (vla-get-layouts *DOC*))
;;(vlax-for lay layouts (setq lst
(cons (vla-get-name lay) lst)))
(repeat (setq c (vla-get-count
layouts))
(setq lst (cons (setq c (1- c)) lst))
) ;(2 1 0)
(vlax-for lay layouts
(setq lst
(subst
(vla-get-name
lay)
(vla-get-taborder
lay)
lst
)
)
)
lst
)
;;97 [功能] 窗口左下角空间切换是否显示
(defun MJ:ToggleLayouts (/ prefDisplay)
(setq prefDisplay (vla-get-Display (vla-get-Preferences
*ACAD*)))
(vla-put-DisplayLayoutTabs
prefDisplay
(if (= (vla-get-DisplayLayoutTabs
prefDisplay) :vlax-true)
:vlax-false
:vlax-true
)
)
(princ)
)
;;98.1 [功能] 模型空间背景色在空白之间切换
(defun MJ:ToggleMSBackground (/
prefDisplay)
(vl-load-com)
(setq prefDisplay
(vla-get-Display
(vla-get-Preferences *ACAD*)
)
color
(vlax-variant-value
(vlax-variant-change-type
(vla-get-GraphicsWinModelBackgrndColor
prefDisplay)
vlax-vbLong
)
)
)
(vla-put-GraphicsWinModelBackgrndColor
prefDisplay
(vlax-make-variant
(if (= color
0)
16777215
0
)
vlax-vbLong
)
)
(princ)
)
;;98.2[功能] 布局空间背景色在空白之间切换
(defun MJ:TogglePSBackground (/
prefDisplay)
(vl-load-com)
(setq prefDisplay
(vla-get-Display
(vla-get-Preferences *ACAD*)
)
color
(vlax-variant-value
(vlax-variant-change-type
(vla-get-GraphicsWinLayoutBackgrndColor
prefDisplay)
vlax-vbLong
)
)
)
(vla-put-GraphicsWinLayoutBackgrndColor
prefDisplay
(vlax-make-variant
(if (= color
0)
16777215
0
)
vlax-vbLong
)
)
(princ)
)
;;99.1 [功能] 表->二维表(见52.5)
;;示例(list->2pair (list
(getpoint)(getpoint)(getpoint)(getpoint)))
;;示例(list->2pair '(1 2 3 4 5
6)),返回((1 2) (3 4) (5 6))
(defun list->2pair (old / new)
(while
(setq new (cons (list (car old) (cadr old))
new)
old (cddr old)
)
)
(reverse new)
)
;;99.2 [功能]
表->三维表
;;示例(list->3pair '(1 2 3 4 5 6)),返回((1 2 3) (4 5 6))
(defun
list->3pair (old / new)
(while (setq new (cons (list (car old)
(cadr old) (caddr old)) new)
old
(cdddr old)
)
)
(reverse new)
)
;;99.3 [功能]
获取多段线顶点列表(见46)
;;多段线顶点((-1736.57 2913.7) (-1618.83 2795.96) (-1413.66
2795.96))
;;vla-Get-Coordinates不能取得高程
(defun LwpolinePoints (/
temp)
(setq temp (vla-Get-Coordinates (*En2Obj* (car
(entsel)))))
(list->2pair (vlax-safearray->list
(vlax-variant-value temp)))
)
;;99.4 [功能] 两对象交点
;;
mode:acExtendNone,acExtendThisEntity,acExtendOtherEntity,acExtendBoth
(defun
All-intersectwith (obj1 obj2 mode / INT IPLIST)
(defun list->3pair
(old / new)
(while (setq new (cons (list (car old) (cadr
old) (caddr old)) new)
old (cdddr old)
)
)
(reverse new)
)
(setq int (vla-IntersectWith obj1 obj2 mode))
(setq iplist (vl-catch-all-apply
'vlax-safearray->list
(list (vlax-variant-value
int))
)
)
(if
(vl-catch-all-error-p iplist)
nil
(list->3pair iplist)
)
)
;;100.1 [功能] 判断是否val对象?
(defun Is-Vla-Object (obj) (equal (type obj)
'vla-object))
;;100.2 [功能] 判断是否字符串
(defun Is-String (arg) (equal (type
arg) 'str))
;;100.3 [功能] 判断是否实数?
(defun Is-Real (arg) (equal (type arg)
'real))
;;100.4 [功能] 判断是否ename对象?
(defun Is-Ename (arg) (equal (type arg)
'ename))
;;100.5 [功能] 判断是否变体?
(defun Is-Variant (arg) (equal (type arg)
'variant))
;;100.6 [功能] 判断 X 是否是选择集且长度不为 0
(defun MJ:ssP (x)
(and (= (type X) 'PICKSET) (> (sslength X) 0))
)
;;100.7 [功能]
是否为点对表
;;示例(MJ:ConsP lst)
(defun MJ:ConsP (lst)
(and (vl-consp
lst)
(not (vl-list-length
lst))
)
)
;;100.8 [功能] 是否为点
(defun Is_pt(P)
((and
(vl-consp P)
(null
(vl-catch-all-error-p (vl-catch-all-apply 'vlax-3d-point
P)))
)
)
;;101 [功能] 多段线顶点的连续样式产生线型
;;示例 (MJ:ApplyLtypeGen (car (entsel)))
(defun
MJ:ApplyLtypeGen (object / obj)
(setq object (MJ:MakeObject
object)) ;不是Vla对象,则转换成vla对象
(vla-put-LinetypeGeneration object
:vlax-True)
)
;;示例 (MJ:Put-ByLayer (vlax-ename->vla-object (car (entsel))))
;;102.1
[功能] 使对象颜色随层
(defun MJ:Put-ByLayer (obj)
(if (vlax-write-enabled-p
obj)
(progn
(vla-put-Color obj 255)
;(vla-put-Linetype obj
...);; <-- I need to figure this out!!!
)
);
endif
)
;;102.2 [功能] 设置当前颜色(setvar 'CECOLOR "1")
;;acColor 颜色值字符串："1"
"2" "3" ... "bylayer"
(defun MJ:myColor (acColor)
(vla-setVariable
*DOC* "cecolor" acColor)
)
;;103 [功能] 打印配置
(defun MJ:PlotConfigs (/ ITEMNAME OUT)
(defun MJ:Name (obj)
(if (vlax-property-available-p
obj 'Name)
(vlax-get-property obj
'Name)
"<NONE_NAME>"
)
)
(vlax-for each
(vlax-get-property
*DOC*
'PlotConfigurations
)
(if (vlax-property-available-p each
'GetPlotDeviceNames)
(setq out (cons
(vlax-get-property each 'GetPlotDeviceNames) out))
)
(setq itemname (MJ:Name each)
out (cons itemname out)
)
)
out
)
;;104 [功能] 打印设备列表
(defun MJ:GetPlotDevices ()
(vlax-safearray->list
(vlax-variant-value
(vla-getplotdevicenames
(vla-item
(vla-get-layouts
*DOC*
)
"Model"
)
)
)
)
)
;;105.1 [功能] 清除所有捕捉，与按F3有不同处(参见77.4)
(defun MJ:SnapOff ()
(vla-put-ObjectSnapMode *DOC* :vlax-false)
)
;;105.2 [功能]
MJ:SnapOn之后下面函数只启用端点捕捉
(defun MJ:SnapOn ()
(vla-put-ObjectSnapMode
*DOC* :vlax-true)
)
;;106.1 [功能] 打开一个文件
;;示例: (MJ:OpenDwg "D:\\紫金防雨.dwg")(MJ:OpenDwg
"D:\\DrawingA.dxf")
(defun MJ:OpenDwg (fullname)
(command
"vbastmt"
(strcat "AcadApplication.Documents.Open
"
(chr 34) fullname (chr 34)
)
)
)
;;106.2 [功能] 打开一个文件
;;示例(MJ:OpenDwg1
"D:\\紫金防雨.dwg")(MJ:OpenDwg1 "D:\\DrawingA.dxf")
(defun MJ:OpenDwg1 (fullname
/ *DOC*)
(setq *DOCS* (vla-get-Documents *acad*))
(vla-open
*DOCS* fullname)
)
;;106.3 [功能] 将一文件输入到当前文件中
;;示例(MJ:OpenDwg2
"D:\\DrawingA.dxf")不知同vla-InsertBlock有什么区别
(defun MJ:OpenDwg2 (fullname /
*DOC*)
(setq *DOC* (vla-get-ActiveDocument *acad*))
(vla-import *DOC* fullname (vlax-3d-point '(0 0)) 1)
)
;; [功能] 原地Ccopy属性块
;;107.1 command co法(by woman1314)
;;(command
"_.copy" e "" "0,0" "@")
;;原地Ccopy属性块
;;107.2 entmake法(by ll_j)
;;(w2
(car(entsel)))
(defun w2 (e / EN)
(while
(and
(entmake (setq en (entget
e)))
(cond ((not (equal (cdr (assoc 0 en))
"SEQEND")) (setq e (entnext e))))
)
)
)
;;
[功能] 原地Ccopy属性块
;;107.3 vlax法(by woman1314)
(vlax-invoke-method
(vlax-ename->vla-object e) 'Copy)
;; [功能] 原地Ccopy属性块
;;107.4 vla法(by
free-Lancer)
(vla-copy (vlax-ename->vla-object e))
;; [功能]
原地Ccopy属性块
;;107.5 vla-InsertBlock法(by Lispboy)
(defun w3 (en / IP MSPACE
NAME ROT UTIL VLA-EN XSCALE YSCALE ZSCAL)
(setq mspace
(vla-get-modelspace
(vla-get-activedocument
*acad*)
)
)
(setq vla-en (vlax-ename->vla-object en))
(setq Name (vla-get-Name
vla-en)
ip (vla-get-InsertionPoint
vla-en)
xscale (vla-get-XScaleFactor vla-en)
yscale
(vla-get-YScaleFactor vla-en)
zscale (vla-get-ZScaleFactor
vla-en)
rot (vla-get-Rotation vla-en)
)
(vla-InsertBlock mspace ip Name xscale yscale zscale
rot)
)
;; [功能] 原地Ccopy属性块
;;107.6 选择集法(by Gu_xl)
(defun w4
(ss)
(command "_.select" ss "")
(vlax-map-Collection
(vla-get-ActiveSelectionSet
(vla-get-ActiveDocument *acad*)
)
'vla-copy
)
)
;;107.7 [功能] 块内原地复制 By xshrimp
(defun
MJ:BlockNentselX (/ BLOCKREFOBJ I NENT OBJ OBJENT)
;;生成无名块
(defun make*ublock (obj / blockobj)
(setq blockObj (vla-add (vla-get-Blocks
*DOC*)
(vlax-3d-point (list 0 0
0))
"*U"
)
)
(vla-CopyObjects
*DOC*
(vlax-safearray-fill
(vlax-make-safearray vlax-vbObject (cons 0
0))
(list obj)
)
blockObj
)
(vla-delete obj)
(vla-get-name
blockObj)
)
;; 主程序
(if (= (length (setq nent
(nentsel))) 4)
(progn (entmake (entget (car
nent)))
(setq objent (*En2Obj*
(entlast))
i 0
)
(foreach n (last nent)
(setq obj (*En2Obj* n))
(setq
blockRefObj
(vla-InsertBlock
*MS*
(vla-get-InsertionPoint
obj)
(make*ublock
objent)
(vla-get-xScaleFactor
obj)
(vla-get-yScaleFactor
obj)
(vla-get-zScaleFactor
obj)
(vla-get-Rotation
obj)
)
)
(setq i (1+
i))
(if (> i
1)
(command "_.explode"
(entlast))
)
(setq objent (*En2Obj* (entlast)))
)
(command "_.explode"
(entlast))
(sssetfirst nil (ssget
"p"))
)
)
(prin1)
)
;;107.8 [功能]
块内原地复制 by highflybird
(defun MJ:BlockNentselH (/ *SPACE BLK ENT LX LY LZ MAT
NEW OBJ Q REF RET SCLMAT SX SY SZ TRSMAT V VV VX VY VZ)
;;
匿名块程序
(defun make-anonymous-block (obj / BLKOBJ origin bkName
*space)
(setq origin (vlax-3d-point '(0.0 0.0
0.0)))
(setq blkobj (vla-add (vla-get-blocks *doc*) origin
"*U"))
(setq bkName (vla-get-name
blkobj))
(vlax-invoke *doc* 'copyobjects (list obj)
blkobj)
(if (zerop (vla-get-ActiveSpace
*DOC*))
(setq *space (vla-get-PaperSpace
*doc*))
(setq *space (vla-get-modelspace
*doc*))
)
(vla-insertblock *space
origin bkName 1 1 1 0)
(vla-put-Explodable blkobj
:vlax-true)
blkobj
)
;; 矩阵转置
;; MAT:trp Transpose a matrix -Doug Wilson-
(defun MAT:trp (m)
(apply 'mapcar (cons 'list
m))
)
;; 向量的矩阵变换(向量乘矩阵)
;; Matrix x Vector - Vladimir Nesterovsky
;; Args: m - nxn matrix, v - vector in R^n
(defun MAT:mxv
(m v)
(mapcar (function (lambda (r) (apply '+ (mapcar '* r
v))))
m
)
)
;; 矩阵相乘
;; MAT:mxm Multiply two matrices -Vladimir
Nesterovsky-
(defun MAT:mxm (m q)
(mapcar
(function (lambda (r) (MAT:mxv (MAT:trp q) r))) m)
)
;; 主程序
(setq ret (nentselp))
(if (null
ret)
(exit)
)
(setq mat (caddr
ret)) ;这个是变换矩阵
(setq vv (reverse (cdr (reverse mat))))
;去掉第四行(0 0 0 1)
(setq vX (mapcar 'car vv)) ;X 向量
(setq vY (mapcar
'cadr vv)) ;Y 向量
(setq vZ (mapcar 'caddr vv)) ;Z
向量
(setq lX (distance vX '(0 0 0))) ;X 比例因子
(setq lY
(distance vY '(0 0 0))) ;Y 比例因子
(setq lZ (distance vZ '(0 0
0))) ;Z 比例因子
(setq ent (car ret))
(setq obj (*En2Obj* ent))
(if (and (equal lX lY 1e-8) (equal lY lZ 1e-8))
;如果是均匀缩放
(progn
(if
(zerop (vla-get-ActiveSpace *DOC*))
(setq *space (vla-get-PaperSpace
*doc*))
(setq *space (vla-get-modelspace
*doc*))
)
(vlax-invoke *doc* 'copyobjects (list obj)
*space)
;则仅仅是copyObjects方式添加到空间中
(setq new (*En2Obj* (entlast)))
(vla-transformby new (vlax-tmatrix mat)) ;然后再矩阵变换
)
(progn
(setq blk
(make-anonymous-block obj)) ;先做一个匿名图块
(setq
ref (*En2Obj* (entlast))) ;插入块参照
(setq sX (/ 1
lx)) ;非均匀缩放则要取得各个比例值
(setq sY (/ 1
lY))
(setq sZ (/ 1
lZ))
(setq sclMat (list (list sX 0 0
1);乘以一个比例缩放矩阵使得比例均匀
(list 0 sY 0 1)
(list 0 0 sZ 1)
(list 0 0 0 1)
)
)
(setq trsmat (MAT:mxm mat sclMat))
;得到一个均匀缩放的变换矩阵
(vla-transformby ref
(vlax-tmatrix trsmat)) ;变换参照
;;最后需要变换回去
(vla-put-xscalefactor ref (* (vla-get-xscalefactor ref)
lX))
(vla-put-yscalefactor ref (*
(vla-get-yscalefactor ref) lY))
(vla-put-zscalefactor ref (* (vla-get-zscalefactor ref)
lZ))
(vlax-put ref 'insertionpoint (mapcar
'last vv))
;;(vla-Explode
ref)
(command "explode"
"L") ;炸开匿名块参照
;;(vla-delete
ref)
(vla-delete
blk) ;删除匿名块定义
)
)
(princ)
)
;;107.9 [功能] 块内原地复制 by GSLS(SS)
;; 示例 : (MJ:BlockNentsel "My
God:")
(defun MJ:BlockNentsel (msg / EN EN1 ENT INS MAT OBJ PT X Y)
(setq en (Nentsel msg))
(if (= (length en) 4)
(progn
(setq en1 (car
en)
pt (cadr en)
mat (caddr en)
ins (last
mat)
mat (reverse (cdr (reverse
mat)))
mat (append
(mapcar '(lambda (x y)
(append x
(list y))
)
mat
ins
)
'((0. 0. 0.
1.))
)
ent (entget en1
'("*"))
ent (vl-remove (assoc -1 ent)
ent)
en1 (entmakex
ent)
)
(if
en1
(progn
(setq obj (*En2Obj* en1))
(vla-TransformBy obj (vlax-tmatrix mat))
(setq en1 (*Obj2En*
obj))
)
)
(list en1 pt T)
)
(append en (list nil))
)
)
;;107.10 [功能]
块内原地复制 By eachy
;;nentselp 對ployline & 屬性 會有問題
(defun c:bcopy (/ e
el)
(while (and (setq e (nentselp "\n选择块内实体:
"))
(= (length e) 4)
)
(setq el (entget (car e)))
(entmake el)
(vla-transformby
(vlax-ename->vla-object
(entlast))
(vlax-tmatrix (caddr
e))
)
)
(princ)
)
;;108 [功能] 输出 WMF SAT EPS DXF BMP格式文件
;;fileName
输出文件名
;;Extension 输出文件格式：WMF SAT EPS DXF BMP 之一
;;SelectonSet
选择集对象，如果Extension=EPS/DXF，则忽略（但必须有效！），而输出整个图形
(defun myExport (fileName
Extension SelectonSet /)
(vla-export *DOC* fileName Extension
SelectonSet)
)
;;109 [功能] 移动Move
(defun myMove (moveEnt fromPt toPt / moveType point1
point2)
(setq point1 (vlax-3d-point fromPt)
point2
(vlax-3d-point toPt)
)
(setq moveType (type
moveEnt))
(cond
((= moveType
'ENAME)
(setq obj (*En2Obj*
moveEnt))
(vla-move obj point1
point2)
1
)
((= moveType 'PICKSET)
(setq
sn (sslength moveEnt)
i
0
)
(while (< i
sn)
(setq si (ssname moveEnt
i))
(setq obj (*En2Obj*
si))
(vla-move obj point1
point2)
(setq i (1+
i))
)
)
)
)
;;110 [功能] 偏移
;;对逆时针方向的图形 dis >0 向外偏移，<0 为向内偏移
(defun
myOffset (obj dis / wObj offsetObj)
(setq wObj obj)
(if
(= (type obj) 'ENAME)
(setq wObj (*En2Obj* obj))
)
(setq offsetObj (vla-Offset wObj dis))
)
;;111 [功能] 退出Acad
(defun myQuit ()
(vla-Quit *ACAD*)
)
;;112 [功能] 重生成
(defun myRegen ()
(vla-Regen *ACAD*
:vlax-true)
)
;;113 [功能] 旋转(见133.1)
(defun myRotate (obj basePoint RotateAngle /
wObj bPoint rAngle)
(setq wObj obj)
(if (= (type obj)
'ENAME)
(setq wObj (*En2Obj* obj))
)
(setq bPoint (vlax-3d-point basePoint))
(setq rAngle (/ (* RotateAngle
pi) 180.0))
(vla-Rotate wObj bPoint rAngle)
)
;;114.1 [功能] 多段线添加节点Vertex
;;pt节点;index序号
(defun
MJ:AddVertex (PLineObj index pt / newVertex)
(setq newVertex
(vlax-make-safearray vlax-vbDouble (cons 0 1)))
(vlax-safearray-fill
newVertex pt)
(vla-AddVertex PLineObj index newVertex)
)
;;114.2
[功能] 多段线修改节点Vertex
;;示例 (MJ:ChangeVertex (car(entsel)) (trans (getpoint) 0 1)
1)
(defun MJ:ChangeVertex (pl pt index)
(if (= 'ename (type
pl))
(setq pl (*En2Obj* pl))
)
(if (=
"AcDbPolyline" (vla-get-ObjectName pl))
(setq pt (list
(car pt) (cadr pt)))
)
(VL-CATCH-ALL-APPLY
'vla-put-coordinate
(list
pl
index
(vlax-make-variant
(vlax-safearray-fill
(vlax-make-safearray
vlax-vbdouble
(cons 0 (1- (length
pt)))
)
pt
)
)
)
)
)
;;114.3 [功能] 多段线端点与前后点是否在同一直线上
;;(OverPtsPL
(car(entsel)))=>(T T nil nil nil T nil T T)
(defun OverPtsPL (e / LST LST0
LST1 LST2 X Y Z)
(setq lst0 (HH:PtLists e))
(cond
((equal (vlax-curve-getstartpoint
e)
(vlax-curve-getendpoint
e)
1e-5
)
(vla-put-closed (vlax-ename->vla-object e)
:vlax-true)
(setq lst1 (append (cdr lst0) (list (car
lst0))))
(setq lst2 (cons (last lst0)
lst0))
(mapcar '(lambda (x y z) (PtIn2Pts1 x y z
0.001)) lst0 lst2 lst1)
)
(T
(setq lst1 (cdr
lst0))
(setq lst2 (cdr
lst1))
(setq lst (mapcar '(lambda (x y z) (PtIn2Pts1
x y z 0.001)) lst1 lst0 lst2))
(setq lst (append
(cons nil lst) (list nil)))
)
)
)
;;114.4 [功能] p是否在p1p2之间 自贡黄明儒
;;(PtIn2Pts1 (getpoint) (getpoint)
(getpoint) 0.01)
(defun PtIn2Pts1 (p p1 p2 fuzz)
(equal (+
(distance p p1) (distance p p2)) (distance p1 p2) fuzz)
)
;;114.5 [功能] 多段线除重点(见164.9)
;;(HH:Remove1 (ssname (ssget "_+.:E:S" '((0 .
"LWPOLYLINE"))) 0))
(defun HH:Remove1 (e / FLAG LST PTS)
(setq pts
(OverPtsPL e))
(foreach x (entget e)
(cond
((= 10 (car
x))
(setq Flag (car
pts))
(setq pts (cdr
pts))
(cond ((not Flag) (setq Lst (cons
x Lst))))
)
(T (setq Lst (cons x Lst)))
)
)
(entmod (reverse Lst))
(princ)
)
;;114.6 [功能] 动态绘制指引标注框符号 By
Gu_xl 2012.07.17
(defun c:zybz (/ P1 P2 EN OBJ EL GR PT PA NEW FILLETFlag R
kd *error*)
(defun *error* (s)
(princ
s)
(if obj
(vla-delete obj)
)
(if new
(vla-delete
new)
)
(princ)
)
(if (and (setq p1 (getpoint "\n左下角点: "))
(setq p2
(GETCORNER p1 "\n右上角点: "))
)
(progn
(command
"_.rectang" p1 p2)
(setq
en (entlast)
obj (vlax-ename->vla-object en)
)
(setq r (getvar
'FILLETRAD))
(initget "Yes No
Set")
(setq
kd
(cond
((setq
kd
(getkword
(strcat
"\n矩形是否圆角(R="
(rtos r 2
3)
")[圆角Yes/不圆角No/设置圆角半径Set]<No>"
)
)
)
)
("No")
)
)
(if (= kd "Set")
(setq r (getdist
(strcat "\n输入圆角半径<" (rtos r 2 3) ">")))
)
(if (null r)
(setq r (getvar
'FILLETRAD))
)
(if (and (or (= kd "Set") (= kd "Yes")) (not
(equal r 0 1e-6)))
(progn (setvar 'FILLETRAD
r)
(command "_.FILLET" "p"
en)
(setq FILLETFlag
t)
)
)
(while (= 5 (car (setq gr (grread t
15))))
(redraw en 2)
(if new
(vla-delete
new)
)
(setq pt (cadr gr))
(setq pa
(vlax-curve-getParamAtPoint
en
(vlax-curve-getclosestpointto en
pt)
)
)
(cond
((equal pa (fix
pa) 1e-6) (setq pa (1- (fix pa))))
(t (setq pa (fix
pa)))
)
(if (MINUSP pa)
(setq pa
0)
)
(if (and FILLETFlag (member pa '(1 3 5
7)))
(setq pa (1- pa))
)
(setq p1
(vlax-curve-getPointAtParam en (+ pa
0.35))
p2 (vlax-curve-getPointAtParam en
(+ pa 0.65))
)
(vla-copy obj)
(setq new
(vlax-ename->vla-object (entlast)))
(vla-AddVertex
new
(+ 1 pa)
(vlax-make-variant
(vlax-safearray-fill
(vlax-make-safearray
vlax-vbdouble
'(0 .
1)
)
(list (car p1) (cadr
p1))
)
)
)
(vla-AddVertex
new
(+ 2
pa)
(vlax-make-variant
(vlax-safearray-fill
(vlax-make-safearray
vlax-vbdouble
'(0 .
1)
)
(list
(car
(trans pt 1
0)
)
(cadr
(trans pt 1
0)
)
)
)
)
)
(vla-AddVertex
new
(+ 3
pa)
(vlax-make-variant
(vlax-safearray-fill
(vlax-make-safearray
vlax-vbdouble
'(0 .
1)
)
(list (car p2) (cadr
p2))
)
)
)
)
(entdel en)
)
)
(princ)
)
;;115 [功能] 文件名已经保存，返回T；新建一文件，未命名保存过，返回 nil
(defun MJ:DwgNamed-p ()
(= 1 (getvar "dwgtitled"))
)
;;116.1 [功能] 缩放整个图形
(defun MJ:ZoomAll()
(vla-ZoomAll
*ACAD*)
)
;;116.2 [功能] 缩放到实际范围
(defun MJ:ZoomExtents()
(vla-ZoomExtents *ACAD*)
)
;;116.3 [功能] pt中心点缩放1
(defun MJ:ZoomCenter1
(pt)
(vla-ZoomCenter *ACAD* (vlax-3d-point pt) 1.0)
)
;;116.4
[功能] pt中心点缩放2
(defun MJ:ZoomCenter2 (centerPoint zoomHeight)
(vla-ZoomCenter
*ACAD*
(vlax-3d-point centerPoint)
zoomHeight
)
)
;;116.5 [功能] 两点窗口缩放
(defun MJ:ZoomWindow (p1 p2)
(vla-ZoomWindow *ACAD*
(vlax-3d-point p1) (vlax-3d-point
p2)
)
)
;;116.6 [功能] 视口比例缩放-放大2倍
(defun MJ:ZoomScale
()
(vla-ZoomScaled *ACAD* 2.0 1)
)
;;116.7 [功能] 视口比例缩放
(defun
MJ:ZoomScaled (scaleFactor scaleType / AcadObject sType)
(setq sType
scaleType)
(if (or (not scaleType) (= scaleType
""))
(setq sType
acZoomScaledRelative) ;和视图相关，或acZoomScaledAbsolute与图形范围
)
(vla-ZoomScaled
*ACAD*
scaleFactor
scaleType
)
)
;;116.8 [功能]
返回上一视图
(defun MJ:ZoomPrevious ()
(vla-ZoomPrevious *ACAD*)
)
;;117.1 [功能] 在当前视图状况下将图形单位转换为像素(见169)
(defun MJ:U2P (UN)
(* UN
(/ (cadr (getvar 'SCREENSIZE)) (getvar 'VIEWSIZE)))
)
;;117.2 [功能]
在当前视图状况下将像素转换为图形单位
(defun PIX2UNITS (pix)
(* pix (/ (getvar
"VIEWSIZE") (cadr (getvar "SCREENSIZE"))))
)
;;117.3 [功能] 返回当前视窗左下角和右上角
坐标
(defun viewpnts (/ A B C D X)
(setq d (getvar
"screensize")) ;屏像素
(setq b (* (getvar
"viewsize") 0.5) ;viewsize屏竖长
a (*
b (/ (car d) (cadr d))) ;屏横长
x
(trans (getvar "viewctr") 1 2)
;屏中点viewctr
c (list (- (car x) a) (- (cadr x) b) 0.0)
d (list
(+ (car x) a) (+ (cadr x) b) 0.0)
)
(list (trans c 2 1)
(trans d 2 1))
)
;;117.4 [功能] pickbox大小
(defun MJ:pickboxsize
()
(* (/ (getvar "pickbox") (cadr (getvar
"screensize")))
(getvar "viewsize")
)
)
;;118.1 [功能] 获取 0~1 之间的随机数 (by zml84)
(defun MJ:RAD ()
(/ (rem
(getvar "CPUTICKS") 1984) 1983)
)
;;118.2 [功能] 获取 0~7 之间的随机数
(defun
ZL-RAND ()
(fix (* 7 (/ (rem (getvar "CPUTICKS") 1984) 1983)))
)
;;119.1 [功能] 将 ACI 索引颜色转换成 RGB 配色系统
(defun MJ:ACI->RGB (ACI /
COL)
(setq COL (vla-get-truecolor (vla-get-ActiveLayer
*DOC*)))
(if (not (vl-catch-all-apply 'vla-put-ColorIndex (list COL
ACI))
)
(list
(vla-get-red COL)
(vla-get-green COL)
(vla-get-blue COL)
)
)
)
;;119.2 [功能] 将
RGB 配色系统转换成 ACI 索引颜色
(defun MJ:RGB->ACI (R G B / COL ACI)
(setq
COL (vla-get-truecolor (vla-get-ActiveLayer *DOC*)))
(vl-catch-all-apply
'(lambda
()
(vla-SetRGB COL R G
B)
(setq ACI (vla-get-ColorIndex
COL))
)
)
ACI
)
;;120.1 [功能] 选择集->图元列表
(defun MJ:SS->LIST (SS)
(vl-remove-if-not 'Is-Ename (mapcar 'cadr (ssnamex SS)))
)
;;120.2 [功能]
选择集->图元列表 By caiqs
(defun ss->lst (ss / retu)
(setq retu
(apply 'append (ssnamex ss)))
(setq retu (vl-remove-if-not '(lambda
(x) (= (type x) 'ENAME)) retu))
)
;;120.3 [功能] Vla集合->图元列表
(defun
VlaSS (VlaSS / lst)
(vlax-for x VlaSS
(setq lst
(cons (vlax-vla-object->ename x) lst))
)
)
;;120.4 [功能]
图元列表->选择集
(defun MJ:Sel-List->SS (Lst / SS)
(setq ss
(ssadd))
(foreach en Lst (ssadd en ss))
ss
)
;;120.5
[功能] 图元列表->选择集 By caiqs
(defun lst->ss (lst / ss)
(setq ss
(ssadd))
(last (mapcar '(lambda (x) (ssadd x ss)) lst))
)
;;121 [功能] 根据当前文档的图形单位精度将实数转换为字符串(见162.1)
;; [参数] REL----实数
(defun
MJ:RTOS (REL / DZIN)
(setq DZIN (getvar 'DIMZIN))
(setvar
'DIMZIN 0)
(setq REL (rtos REL 2 (getvar 'LUPREC)))
(setvar
'DIMZIN DZIN)
REL
)
;;122.1 [功能] 遍历选择集对所包含的图元进行指定函数操作
;; [参数]
SS----选择集
;; FUN---函数名
;; [返回]
包含每个图元的操作结果的表
(defun MJ:SS-MAP (SS FUN / N LST)
(repeat (setq N
(sslength SS))
(setq LST (cons (apply FUN (list (ssname SS
(setq N (1- N))))) LST))
)
LST
)
;;122.2 [功能]
遍历选择集对所包含的图元进行指定函数操作
;; [参数]
SS----选择集
;; FUN---函数名
;; [返回]
最后一个图元的操作结果
(defun MJ:SS-FOR (SS FUN / N)
(repeat (setq N (sslength
SS))
(apply FUN (list (ssname SS (setq N (1-
N)))))
)
)
;;123 [功能] 获取当前 AutoCAD 的版本
(defun MJ:ACAD-VAR () (atof (getvar
"ACADVER")))
;;124 [功能] 获取 DXF 组码值
(defun MJ:DXF (IT LST)
(cdr (assoc IT
LST))
)
;;125.1 [功能] 获取在图元 en 之后产生的图元列表
(defun MJ:EntNextAll (EN / LST)
(if EN
(while (setq EN (entnext
EN))
(if (not (member (cdr (assoc 0 (entget
EN)))
'("ATTRIB" "VERTEX"
"SEQEND")
)
)
(setq LST (cons EN LST))
)
)
)
(reverse
LST)
)
;;125.2 [功能] 获取在图元 en 之后产生的图元的选择集
(defun lt:ss-entnext (en /
ss)
(if en
(progn
(setq ss
(ssadd))
(while (setq en (entnext
en))
(if (not (member (cdr (assoc 0 (entget en)))
'("ATTRIB"
"VERTEX"
"SEQEND"
)
)
)
(ssadd en
ss)
)
)
(cond((zerop (sslength ss)) (setq ss
nil)))
ss
)
(ssget "_x")
)
)
;;126 [功能] 打印列表中的数据
(defun MJ:Print-List (LST) (mapcar 'princ LST))
;;127 [功能] 更新组码
;; (entmodEnt 图元 组码 组码新值 TF) TF为nil时不更新图元
(defun
MJ:entmodEnt (ent a vale TF / ENTLIST)
(setq entlist (entget
ent))
(entmod (subst (cons a vale) (assoc a entlist)
entlist))
(if TF
(entupd ent)
)
ent
)
;;128.1 [功能] 选择集->无名块
;;示例(MJ:BLK-MakeUnNameBlock (ssget))
;;注意
函数对选择集中存在具有属性的图块及复杂多义线无效
(defun MJ:BLK-MakeUnNameBlock (ss / count entlist
ent blk pt)
(setq pt (car (MJ:GetssBox ss)))
(entmake (list
'(0 . "BLOCK")
'(2 . "*U")
'(70 .
1)
(cons 10 pt)
)
)
(setq count 0)
(repeat (sslength ss)
(setq
entlist (entget (setq ent (ssname ss count))))
(setq count
(1+ count))
(entmake entlist)
)
(setq
count 0)
(repeat (sslength ss)
(setq ent (ssname
ss count))
(setq count (1+ count))
(entdel ent)
)
(setq blk (entmake '((0 .
"ENDBLK"))))
(if (princ blk)
(entmake (list
(cons 0 "INSERT")
(cons 2
blk)
(cons 10 pt)
)
)
)
blk
)
;;128.2 [功能] 用
[选择集/obj表] 做成一个块
(defun MJ:add-Block (ss/objlst name InsertionPoint / block
blocks)
(if (atom ss/objlst)
(setq ss/objlst
(mapcar 'vlax-ename->vla-object
(MJ:SS->LIST ss/objlst)
)
)
)
(setq blocks (vla-get-Blocks
*doc*))
(setq block (vla-add Blocks (vlax-3d-point InsertionPoint)
name))
(vlax-invoke *doc* 'CopyObjects ss/objlst block)
block
)
;;128.3 [功能] 选择集做成一个块
(defun MJ:MakeBlock (ss / A)
(setq A (rtos (* (getvar "CDATE") 1E8)))
(if
ss
(command "_.BLOCK" A "0,0" ss "")
)
;;(command "_.INSERT" A "@" "" "" "")
)
;;129.1 [功能] 删除表中相同图元
(defun MJ:delsame (l)
(if
L
(cons (car L) (MJ:delsame (vl-remove (car L) (cdr
L))))
)
)
;;129.2 [功能] 深入递归删除重复出现的原子,每个嵌套的表也要除重
(defun
gxl-ListDumpAtomAll (Lst / tmp)
(if Lst
(cons
(if (= 'list (type (setq tmp (car Lst))))
(gxl-ListDumpAtomAll tmp)
tmp
)
(gxl-ListDumpAtomAll
(vl-remove
(car
Lst)
(cdr
Lst)
)
)
)
)
)
;;129.3 [功能] 剔除表元素 By 无痕
;;提示; 等同于: (vl-remove at list)
;;(MJ:removeat "a" '(58 3 (a . 8) "a" 4.5)) -> (58 3 (A . 8)
4.5)
(defun MJ:removeat (at lst) ;at=atom
(apply 'append
(subst nil (list at) (mapcar 'list lst)))
)
;;130 [功能] 获得特定符号表的列表。
;;
有效符号表名称为Layer,Ltype,Viewx,Style,Block,Appid,Ucs,Dimstyle和Vport。
(defun
MJ:get-tblnext (table-name / lst d)
(while (setq d (tblnext table-name
(null d)))
(setq lst (cons (cdr (assoc 2 d))
lst))
)
(reverse lst)
)
;;131.1 [功能] 返回a在表lst中的位置 or nil
(defun MJ:position (a lst / b)
(cond ((setq b (member a lst)) (- (length lst) (length b))))
)
;;131.2
[功能] 返回a在表lst中的位置 or nil
;; 示例(position x '(a b c)) -> nil, (position 'b
'(a b c d)) -> 1
(defun position (x lst / ret)
(if (not
(zerop (setq ret (length (member x lst)))));x不在表中返回nil
(-
(length lst) ret)
)
)
;;131.3 [功能] 从列表中删除指定的元素
(defun
MJ:removeNth (index lst / c)
(setq c -1)
(apply
'append
(mapcar '(lambda (x)
(if (/= (setq c (1+ c))
index)
(list
x)
)
)
lst
)
)
)
;;131.4 [功能] 从列表中删除指定的元素 By
xianaihua
(defun RemoveNth6 (index lst / i)
(setq i -1)
(vl-remove-if '(lambda (x) (= (setq i (1+ i)) index)) lst)
)
;;131.5 [功能]
元素不在列表中，则加入之
;;(adjoin 0 '(1 2 3))->(0 1 2 3)
(defun adjoin (ele lst /
tmp)
(if (= (type lst) 'SYM)
(setq tmp
lst
lst (eval tmp)
)
)
(setq lst (cond ((member ele lst) lst)
(t (cons ele
lst))
)
)
(if
tmp
(set tmp lst)
lst
)
)
;;132 [功能] 关键字a的列表框增加内容
(defun MJ:mpoplst (a lst / n)
(start_list a 3)
(setq n 0)
(repeat (length
lst)
(add_list (nth n lst))
(setq n
(+ n 1))
)
(end_list)
)
;;133.1 [功能] 旋转一个点(见113 167)
;;Rotate 'pnt'点 from a base point of 'p1' and
through an angle
;;of 'ang' (in radians)
(defun MJ:rotate_pnt (pnt p1 ang
/)
(polar p1 (+ (angle p1 pnt) ang) (distance p1 pnt))
)
;;133.2 [功能] 缩放一个点
;;scale 'pnt' from a base point of 'p1' by a factor of
fact
(defun MJ:scale_pnt (pnt p1 fact /)
(polar p1 (angle p1 pnt)
(* fact (distance p1 pnt)))
)
;;134.1 [功能] 返回文件名(带扩展名) (反findfile)
;;如a为"C:\\Program Files\\AutoCAD
2005\\support\\AlignObject.VLX",返回"AlignObject.VLX"
(defun MJ:pstrip (a /
b)
(cond ((setq b (strsea "\\" a)) (setq b b))
((setq b
(strsea "/" a)) (setq b b))
(T (setq b (list 0)))
)
(setq a (substr a (+ (last b) 1) (strlen a)))
)
;;134.2 [功能]
去文件名扩展,比如去掉.exe
(defun MJ:xstrip (fna / st)
(if (and (setq st
(strsea "." fna))
(<= (- (strlen fna) 3) (last
st))
)
(setq fna (substr
fna 1 (- (last st) 1)))
)
fna
)
(defun strsea (a b / c
n)
(cond ((equal "" a) (setq c nil))
((not (equal (type
b) (type "1")))
(progn (print
"!!!!不是字符串!!!!")
(print b)
(setq c nil)
)
)
(T
(progn (setq n 1)
(while
(>= (+ (- (strlen b) n) 1) (strlen a))
(if (equal
(substr b n (strlen a)) a)
(setq c (append c
(list n))
n (- (+ n (strlen a))
1)
)
)
(setq n (+ n 1))
)
)
)
)
c
)
;;134.3 [功能] 分割文件名为三部分
;;(fnsplitl "C:\\Program Files\\AutoCAD
2004\\acad.exe")
;;返回("C:\\Program Files\\AutoCAD 2004\\" "acad" ".exe")
;;135.1 [功能] pt到p1p2上的垂点 自贡黄明儒(见113 133.1)
(defun HH:perPt1 (P p1 p2
/ pt)
(setq pt (mapcar '+ (MAT:Rot90 (mapcar '- p1 p2))
p)) ;highflybir论矩阵
(inters p1 p2 p pt
nil) ;垂点
)
;;135.2 [功能]
p到p1p2上的垂点 by st788796
(defun HH:perPt2 (p p1 p2 / p0)
(setq p0
(trans (mapcar '- p p1) 0 (mapcar '- p2 p1)))
(mapcar '+ p1 (list (car
p0) (last p0) (cadr p0)))
)
;;135.3 [功能]
pt到曲线的垂点不在延长线上，返回T
;;(HH:perPtIn (getpoint) (car(entsel)))
(defun
HH:perPtIn (p curve / P1 P2 PA)
(setq p1 (vlax-curve-getClosestPointTo
curve p))
(setq pa (vlax-curve-getParamAtPoint curve
P1)) ;参数
(setq p2 (mapcar '+
(vlax-curve-getFirstDeriv curve pa) p1)) ;切线上一点
(equal (caddr (trans
(mapcar '- p p1) 0 (mapcar '- p2 p1))) 0 1e-5)
)
;;135.4 [功能]
pt投影到p1p2上的点是否在p1p2之间 自贡黄明儒
;;(perIn2p (getpoint)
(getpoint)(getpoint))
(defun perIn2p (P p1 p2 / pt)
(setq pt
(mapcar '+ (MAT:Rot90 (mapcar '- p1 p2)) p));highflybir论矩阵
(setq pt
(inters p1 p2 p pt nil));垂点
(equal (+ (distance p1 pt) (distance p2
pt)) (distance p1 p2) 1e-8)
)
;;135.5 [功能] pt到直线(弧)的垂点是否在直线(弧)上
自贡黄明儒
;;(HH:PtInL (getpoint) (car (entsel)))
(defun HH:PtIn (pt
Line)
(equal (vlax-curve-getClosestPointTo Line Pt t)
(vlax-curve-getClosestPointTo Line Pt)
1e-5
)
)
;;135.6 [功能] p投影到p1p2上的点是否在p1p2之间 自贡黄明儒
;;(PtIn2Pts
(getpoint) (getpoint) (getpoint))
(defun PtIn2Pts (p p1 p2)
(<= 0
(caddr (trans (mapcar '- p p1) 0 (mapcar '-
p2 p1)))
(distance p1 p2)
)
)
;;135.7 [功能] p1是否在p2 p3线上
(defun what_side (p1 p2 p3 / a dx dx1 dy
dy1)
(setq dx (- (car p3) (car p2))
dy (-
(cadr p3) (cadr p2))
dx1 (- (car p1) (car p2))
dy1 (- (cadr
p1) (cadr p2))
)
(setq a (- (* dx dy1) (* dy
dx1))
a (rtos a 2 6)
a (atof a)
)
(if (not
(equal 0.0 a))
(setq a (/ a (abs a)))
)
a
)
;;135.8 [功能] pt是否在点集包围范围内(见164.40)
(defun PtInPts (pts
pt / P1 P2)
(setq
pts (MAPCAR
'(LAMBDA (p1 p2) (REM (- (ANGLE pt p1) (ANGLE
pt p2)) PI))
(CONS (LAST pts) pts)
pts
)
)
(equal (ABS (APPLY '+ pts)) PI
1e-8)
)
;;136.1 [功能] 亮显选择集或对象(夹点不显示) 函数
(defun MJ:ayEntSSHighLight (SSorEntName /
oldGrips)
(setq oldGrips (getvar "Grips"))
(setvar "Grips"
0)
(cond
((= (type SSorEntName)
'PICKSET)
(sssetfirst nil
SSorEntName)
)
((= (type
SSorEntName) 'ENAME)
(sssetfirst nil (ssadd
SSorEntName (ssadd)))
)
)
(setvar
"Grips" oldGrips)
)
;;136.2 [功能] 亮显选择集或对象函数
(defun HH:ayEntSSHighLight
(SSorEntName / oldGrips)
(defun EntHighLight (e /
PTS)
(setq pts (HH:Ent4pt e T))
(grvecs (list 1
(car pts)
(cadr
pts)
1
(cadr
pts)
(caddr pts)
1
(caddr pts)
(cadddr
pts)
1
(cadddr
pts)
(car pts)
)
)
)
(cond ((= (type
SSorEntName) 'PICKSET)
(repeat (setq n (sslength
SSorEntName))
(EntHighLight (ssname SSorEntName (setq n
(1- n))))
)
)
((= (type SSorEntName)
'ENAME)
(EntHighLight SSorEntName)
)
)
)
;;136.3 [功能] 亮显选择集或对象函数
(defun HH::EntSSHighLight (ss)
(cond ((HH::List-p) (HH:ayEntSSHighLight ss))
(T (ayEntSSHighLight
ss))
)
)
;;137.1 [功能] 图中最后图元Find True last entity
(Defun MJ:LASTENT (/ E0
EN)
(Setq E0 (EntLast))
(While (Setq EN (EntNext E0)) (Setq
E0 EN))
E0
)
;;137.2 [功能] 获得图形中倒数第二个图元的函数
(defun
MJ:EntSecLast (/ e sle)
(entdel (setq e (entlast)))
(setq
sle (entlast))
(entdel e)
sle
)
;;137.3 [功能]
获取倒数第n个元素
(defun HH:nthEnt (n) ;by xyp1964
(ssname (ssget "x") (1-
n))
)
;;138.1 [功能] 读取指定文件中指定行的内容
;;(MJ:getfile_text "test1.txt" 5)
(defun
MJ:getfile_text (files line / fn text)
(setq line(+ 1
line));本程序假定第一行为表头
(setq files (findfile files))
(if
files
(progn
(setq
fn(open files "r"))
(if (<= line
(MJ:getfile_line files))
(progn
(repeat
line
(setq
text(read-line fn))
)
(close
fn)
text
)
nil
)
)
nil
)
)
;;138.2 [功能] 返回文件行数量
(defun MJ:getfile_line (files / tmplst x
fn)
(setq files (findfile files))
(if
files
(progn
(setq
tmplst 0)
(setq fn (open files
"r"))
(while (read-line fn)
(setq
tmplst (+ 1 tmplst))
)
(close fn)
tmplst
)
nil
)
)
;;138.3 [功能] 读取文件并按行将文件转换为表
;; 示例:(MJ:getfile "tyl.ini")
(defun
MJ:getfile(files / tmplst x fn)
(setq files(findfile files))
(if files
(progn
(setq
fn (open files "r"))
(while (setq x
(read-line fn))
(setq
tmplst(append tmplst(list x)))
)
(close fn)
tmplst
)
nil
)
)
;;139.1 [功能] 用 [选择集/obj表] 做成一个组
(defun MJ:add-group (ss/objlst group_name
/ Group groups)
(if (atom ss/objlst)
(setq
ss/objlst (mapcar
'vlax-ename->vla-object
(MJ:SS->LIST ss/objlst)
)
)
)
(setq group (vla-add
(vla-get-groups *doc*) group_name))
(vlax-invoke group 'AppendItems
ss/objlst) group
)
;;139.2 [功能] 创建无名组
(defun SS->UnNameGroup
(ss / objGroup)
(setq objGroup (vla-add (vla-get-Groups *Doc*)
"*"))
(vla-AppendItems objGroup (SS->Array ss))
objGroup
)
;;140 [功能] 加载幻灯片（见183.5)
;;(MJ:loadsld "Key1" (findfile
"HHZQ.sld"))
(defun MJ:loadsld (key sld / x y)
(setq x
(dimx_tile key)
y (dimy_tile key)
)
(start_image
key)
(fill_image 0 0 x y -2)
(slide_image 0 0 x y
sld)
(end_image)
)
;;141 [功能] 点表排序
(defun Sort_XYZ_pList (PLIST / p1 p2)
(setq plist (vl-sort
plist
'(lambda (p1
p2)
(cond ((< (car p1) (car p2))
T)
((and (= (car p1) (car
p2))
(< (cadr p1)
(cadr p2))
)
T
)
((and (= (car p1) (car
p2))
(= (cadr p1)
(cadr p2))
(<
(caddr p1) (caddr p2))
)
T
)
(T
nil)
)
)
)
)
)
;;142 [功能] 选择集相减 By 自贡黄明儒2012.8.23
;;返回 选择集 or
nil
;;(setq ss1 (ssget)) (setq ss2 (ssget))
(defun SS_SSsub (SS1
SS2 / ENAME)
(repeat (sslength SS2)
(Setq ENAME
(SsName SS2 0))
(SsDel ENAME SS2)
(SsDel ENAME SS1)
)
SS1
)
;;143 [功能] 判断图层是否存在(不存在则创建)
;;(LayerExist "dim")
(defun LayerExist
(LayerName)
(if (tblobjname "LAYER" LayerName) ;(tblsearch
"LAYER" "3")也可判断图层3是否存在
nil
(entmake
(list
'(0 .
"LAYER")
'(100 .
"AcDbSymbolTableRecord")
'(100 .
"AcDbLayerTableRecord")
;'(6 .
"CONTINUOUS") ;线型
;'(62 . 3)
;颜色
'(70 .
0) ;图层状态
(cons 2
LayerName) ;图层名
)
)
)
)
;;144.1 [功能] 读取系统剪贴板中字符串
(defun GET-CLIP-STRING (/ HTML
RESULT)
(and (setq HTML (vlax-create-object
"htmlfile"))
(setq RESULT (vlax-invoke
(vlax-get (vlax-get HTML
'PARENTWINDOW)
'CLIPBOARDDATA
)
'GETDATA
"Text"
)
)
(vlax-release-object HTML)
)
RESULT
)
;;144.2 [功能] 向系统剪贴板写入文字
(defun SET-CLIP-STRING (STR / HTML
RESULT)
(and (= (type STR) 'STR)
(setq HTML
(vlax-create-object "htmlfile"))
(setq RESULT
(vlax-invoke
(vlax-get (vlax-get HTML
'PARENTWINDOW)
'CLIPBOARDDATA
)
'SETDATA
"Text"
STR
)
)
(vlax-release-object HTML)
)
)
;;144.3 [功能]
清空剪贴板内文字
(defun xdl-clscliptext (/ ieobj)
(setq
ieobj (vlax-get-or-create-object
"Internetexplorer.application")
)
(vlax-invoke ieobj
'navigate "about :blank") ;about与:blank间无空格
(vlax-invoke
(vlax-get (vlax-get (vlax-get ieobj
'document) 'parentwindow)
'clipboarddata
)
'clearData
"text"
)
(vlax-release-object ieobj)
)
;;145 [功能] 对象四角点
;;示例(draw-pline1(HH:Ent4pt (car (entsel))
T)),返回UCS坐标系下坐标
(defun HH:Ent4pt (ent Flag / ENT LST MAT MAT1 MAXPT MINPT OBJ
UCSFLAG X)
(cond ((= (type ent) 'ENAME)
(setq obj
(vlax-ename->vla-object ent))
)
((= (type ent) 'VLA-OBJECT)
(setq obj ent))
(T (exit))
)
(and
Flag
(setq Mat (Mat:EntityMatrix
ent))
(setq Mat1 (cadr
Mat)) ;Mat1
4x4
(setq Mat (car
Mat)) ;Mat
4x4
)
(if (= (getvar "WORLDUCS") 0)
(setq UcsFlag T)
)
(cond ((and Flag UcsFlag)
(vla-TransformBy obj (vlax-tmatrix Mat))
)
(UcsFlag
(vla-TransformBy obj (vlax-tmatrix (MAT:u2w))))
(Flag (vla-TransformBy
obj (vlax-tmatrix Mat)))
)
(vla-GetBoundingBox obj 'minPt
'maxPt) ;得到包围框
(setq
minPt (vlax-safearray->list minPt))
(setq maxPt
(vlax-safearray->list maxPt))
(cond ((and Flag
UcsFlag)
(vla-TransformBy obj (vlax-tmatrix
Mat1))
)
(UcsFlag (vla-TransformBy obj (vlax-tmatrix
(MAT:w2u))))
(Flag (vla-TransformBy obj (vlax-tmatrix Mat1)))
)
(setq lst (list minPt
(list (car maxPt)
(cadr minpt) (caddr minPt))
maxPt
(list (car minpt) (cadr maxPt) (caddr minPt))
)
)
(COND (Flag nil)
(UcsFlag (setq mat1
(MAT:w2u)))
)
(cond ((or Flag UcsFlag)
(setq
lst (mapcar '(lambda (x) (mat:mxp mat1 x))
lst)) ;wcs坐标
(setq lst (mapcar
'(lambda (x) (trans x ent 1)) lst))
)
)
lst
)
;;146 [功能] 质心
;;示例 (GetCentroid (car(entsel)))
(defun GetCentroid (poly
/ AXERR CEN PL REG VA)
(setq pl (*En2Obj* poly)
va
(vlax-make-safearray vlax-vbObject '(0 . 0))
)
(vlax-safearray-put-element va 0 pl)
(setq axErr (VL-CATCH-ALL-APPLY
'vla-addregion (list *MS* va)))
(if (VL-CATCH-ALL-ERROR-P
axErr)
nil
(progn
(setq reg (car
(vlax-safearray->list (vlax-variant-value
axErr)))
cen (vla-get-centroid
reg)
)
(vla-delete reg)
(vlax-safearray->list
(vlax-variant-value cen))
)
)
)
;;147.1 [功能] 自定义max(见17,可被替代)
;;示例(max1 '("asd" "dfd"
"hgrt"))返回"hgrt"
(defun max1 (lst)
(if lst
(if (> (car lst) (max1 (cdr lst)))
(car lst)
(max1 (cdr
lst)
)
)
)
)
;;147.2 [功能] 自定义max(见17,可被替代)
;;示例(max2 '("asd" "dfd"
"hgrt"))返回"hgrt"
(defun max2 (l)
(car (vl-sort l
'>))
)
;;147.3 [功能] 自定义vl-remove-if
;; (remove-if 'numberp '(0 (0 1)
"")) -> ((0 1) "")
(defun remove-if (pred from)
(cond
((atom from) from) ;nil or symbol
(return that)
((apply pred (list (car from))) (remove-if
pred (cdr from)))
(t (cons (car from) (remove-if pred (cdr
from))))
)
)
;;147.4 [功能] 自定义remove-if-not
(defun
remove-if-not (pred lst) ; by Vladimir Nesterowsky
(apply
'append
(mapcar '(lambda (e)
(if (apply pred (list e))
(list e)
)
)
lst
)
)
)
;;147.5 [功能]
自定义vl-prin1-to-string
;; 1示例(symbol-name 'a) -> "a";(symbol-name a) ->
nil
;; 2示例(symbol-name '(0 1 2 a)) -> "(0 1 2 A)"
(defun symbol-name
(sym / f str tmp)
;; 执行完毕,搜索电脑,没有发现*sym.tmp
;;
下句产生临时文件的方法是不是与vl-filename-mktemp相同呢?
(setq tmp "$sym.tmp");temp.
filename, should be deleted原来创建txt文件如此简单!
(setq f (open tmp
"w"))
(princ sym f)
(close f)
(setq f (open tmp "r")
str (read-line
f)
f (close f)
)
;; (startapp "notepad"
tmp);显示给使用者看
str
)
;;148.1 [功能] 根据点表画多段线(见164.31)
(defun draw-pline1 (pts)
(command
"_PLINE")
(mapcar 'command pts)
(command "")
)
;;148.2
[功能] 根据点表画多段线
;; TF:T封闭，NIL不封闭
(defun draw-pline2 (pts tf)
(apply 'command (cons "pline" pts))
(if tf
(command "c")
(command "")
)
)
;;148.3
[功能] 根据点表画多段线---xyp1964
(defun Entmake-Spline (ptn / a)
(entmakeX
(append (list '(0 .
"SPLINE")
'(100 .
"AcDbEntity")
'(100 .
"AcDbSpline")
'(71 .
3)
)
(mapcar '(lambda (pt) (cons 11 pt))
ptn)
)
)
)
;;148.4 [功能] 根据点表画样条曲线
(defun draw-spline (pts)
(command "_SPLINE")
(mapcar 'command pts)
(command "" ""
"")
)
;;148.5 [功能] 调用Autocad自身命令
;;(HH:command "PLINE"
nil)
(defun HH:command (commandstr pts / E E0)
(setq e0
(entlast))
(apply 'command (list (strcat "_." commandstr)))
(cond (pts (mapcar 'command pts)))
(while (equal (getvar "cmdnames")
commandstr) (command pause))
(setq e (entlast))
(cond ((not
(equal e0 e)) e))
)
;;149.1 [功能] 进程显示
(defun spinner ()
(if (not
#spin)
(setq #spin "-")
)
(cond
((equal #spin "-") (setq #spin
"\\"))
((equal #spin "\\") (setq #spin
"|"))
((equal #spin "|") (setq #spin
"/"))
(T (setq #spin "-"))
)
(princ
(strcat (chr 8) #spin))
(princ) ;这句很重要
)
;;149.2 [功能] 进程显示
(defun
HH:WORKING ()
(if (= WRKCNT NIL)
(setq WRKCNT
0)
)
(setq WRKCNT (1+ WRKCNT))
(cond ((=
WRKCNT 1) (setq WRK "-"))
((= WRKCNT 2) (setq WRK "\\"))
((=
WRKCNT 3) (setq WRK "|"))
((= WRKCNT 4) (progn (setq WRK "/") (setq
WRKCNT 0)))
)
(princ (strcat "\n* " WRK " 请稍候...... ! " WRK
" *"))
(princ)
)
;;149.3 [功能] 进程显示
(defun spin
(wh)
(princ (strcat "\r
"
wh
(cond
((= #spin "|") (setq #spin "/"))
((= #spin "/")
(setq #spin "-"))
((= #spin "-") (setq #spin
"\\"))
(T (setq #spin
"|"))
)
)
)
(princ)
)
;;149.4
[功能] 进程显示
;;(spin1* "请稍候...")
(defun spin1* (wh)
(grtext
-2
(strcat "\r "
wh
(cond
((= #spin "|") (setq #spin
"/"))
((= #spin "/") (setq
#spin "-"))
((= #spin "-")
(setq #spin "\\"))
(T (setq
#spin "|"))
)
)
)
)
;;149.5 [功能]
进程显示
;;(spin2* 2 10)
(defun spin2* (k l)
(grtext
-2
(strcat "已完成"
(rtos (/ (* 100.0 k)
l)
2
0
)
"%...."
)
)
)
;;149.6
[功能] 进程显示
;;(REPEAT (SETQ i 0) (_progress (SETQ i (1+ i)) 100000))
(DEFUN
_progress (i n / BOX In Re)
(SETQ box '("" "▏" "▎" "▍" "▌" "▋"
"▊" "▉"))
(SETQ In (FIX (/ (* 160 i) n)))
(SETQ Re (REM In
8))
(setq In (* 2 (FIX (/ In 8))))
(setq Re (NTH Re
box))
(GRTEXT -2
(STRCAT (SUBSTR
"████████████████████"
1
In
)
Re
)
)
)
;;150 [功能] 生成无名组（139.2）
;;示例(bns_makgrp (MJ:SS->LIST (ssget))
"描述")
(defun bns_makgrp (LST DESC / EN)
(command "_.-group"
"_create" "*" DESC)
(foreach EN LST (command EN))
(command
"")
)
;;151 [功能] 曲线选集长度求和--陌生人.2004.1
;;示例(MJ:lens nil)
(defun MJ:lens (ss /
ss ssv lens)
(if (= nil ss)
(setq ss (ssget '((0
. "*LINE,ARC,CIRCLE,ELLIPSE"))))
)
(setq ssv
(vla-get-activeselectionset
(vla-get-activedocument *acad*)
)
lens 0
)
(vlax-for
obj ssv
(setq lens (+ lens
(vlax-curve-getdistatparam obj (vlax-curve-getendparam
obj))
)
)
)
)
;;152.1 [功能] 局部重生 by Lee Mac
;;示例 (MJ:Update (entget (car
(entsel))))
(defun MJ:Update (enlist)
(entupd (cdr (assoc -1
enlist)))
)
;;152.2 [功能] 局部重生
;;示例(MJ:RedrawSS (ssget))
(defun
MJ:RedrawSS (ss)
(
(lambda
(i)
(while (setq e (ssname ss (setq i (1+
i))))
(entupd
e)
)
)
-1
)
)
;;153.1 [功能] 注册应用程序名的选择集
(defun ssget-app (rname)
(ssget "X"
(list (list -3 (list rname))))
)
;;153.2 [功能] 一个图元的扩展数据列表
;;示例
(get-eedlist-all (car (entsel)))
(defun get-eedlist-all (ent)
(cdadr (assoc -3 (entget ent) '("*"))))
)
;;153.3 [功能]
一个图元的扩展数据列表(无注册应用程序名)
(defun getxdata-all (e apnlst)
(apply 'append
(mapcar 'cdr (getxdata e apnlst)))
)
;;153.4 [功能] 一个图元的扩展数据列表
(defun
getxdata (e apnlst)
(cdr (assoc -3 (entget e
apnlst)))
)
;;153.5 [功能] 删除扩展数据
(defun DelXdata
(eName )
(entmod
(list
(cons -1
eName)
(cons
-3
(mapcar
'list
(mapcar 'car (cdr (assoc -3 (entget eName
'("*")))))
)
)
)
)
)
;;153.6 [功能] 附着扩展图元数据到AutoCAD对象上
;; 示例(ax:PutXData myVlaObj '((1001
. "ACADX") (1000 . "myStringData")))
(defun ax:PutXData (vlaObj
XData)
(setq XData
(ax:BuildFilter
(mapcar
'(lambda (item /
key)
(setq key (car
item))
(if (<= 1010 key
1033)
(cons
key
(vlax-variant-value
(vlax-3d-point
(cdr
item)
)
)
)
item
)
)
XData
)
)
)
(vla-setXData vlaObj (car XData) (cadr XData))
)
;;153.7 [功能]
设置链接在一个实体上，或者获取链接(geturl)--Highflybird
(defun c:PutHyperlink1 (/ e)
(if (setq e (car (entsel "\nSelect Object to Add Hyperlink to:
")))
(seturl e "http://www.google.co.uk")
)
(princ)
)
(defun c:PutHyperlink2 (/ e)
(if (setq e
(car (entsel "\nSelect Object to Add Hyperlink to: ")))
(vla-add (vla-get-hyperlinks (vlax-ename->vla-object
e))
"http://www.google.co.uk"
)
)
(princ)
)
;;154.1 [功能] 获取ObjectDBX版本字符串
;;用于操作非打开文件
(defun GetObjectDBXVer (/
VERSION)
(if (>= (setq VERSION (atoi (getvar "acadver")))
16)
(strcat "ObjectDBX.AxDbDocument." (itoa
VERSION))
)
)
;;154.2 [功能] dwg转dxf文件函数
;;非打开文件
(defun
Dwg2Dxf (DwgName dxfName / dbxDoc)
(setq dbxDoc
(vla-GetInterfaceObject
*acad*
(GetObjectDBXVer)
)
)
(vla-open dbxDoc DwgName) ;不能打开.dxf文件
;;(vla-import dbxDoc DwgName InsertPoint scalefactor);是不行的.
(vlax-invoke dbxDoc "dxfout" dxfName)
(if dbxDoc
(vlax-release-object dbxDoc)
) ;关闭文档,用(vla-close dbxDoc
:vlax-false)行不通?
)
;;154.3 [功能]
将文件存为2K格式，并去教育版(文件名不变)
;;非打开的文件
;;(DwgOut "D:\\Drawing1.dwg")
(defun
DwgOut (DwgName / BACKUPFILE BASENAME DOCOBJ DXFFILE FILEPATH)
;;1
获取全路径，即路径后有
(defun GetFullPath (path)
(if (wcmatch path "*\\")
path
(strcat path "\\")
)
)
;;2 能删除所有文件，不管只读、隐藏与否，都能删除
(defun
DeleteFile (FIL / FILSYS FILDIR SS ENT)
(setq FILSYS
(vlax-create-object "Scripting.FileSystemObject"))
(setq
FILDIR (vl-filename-directory FIL))
(setq
SS
(vl-directory-files
FILDIR
(strcat
(vl-filename-base FIL) (vl-filename-extension FIL))
1
)
)
(foreach ENT
SS
(vlax-invoke
FILSYS
"deletefile"
(strcat FILDIR "\\"
ENT)
:vlax-false
)
)
(vlax-release-object
FILSYS)
)
;;3 本程序主程序:1转成dxf 2原文件改名为备份 3打开另存为2K
4删除dxf
(setq BaseName (vl-filename-base
DwgName)
filepath (vl-filename-directory
DwgName)
dxfFile (vl-string-subst ".dxf" ".dwg"
DwgName)
BackupFile (strcat (getfullpath
filepath)
BaseName
"_Backup"
(vl-filename-extension
DwgName)
)
)
(Dwg2Dxf DwgName
dxfFile) ;利用objectdbx转存文件,目的是去教育版印戳
(if (findfile
BackupFile)
(deletefile BackupFile)
) ;检查原dwg文件的备份文件名是否存在，如果存在，则删除
(if
(vl-file-rename DwgName BackupFile) ;修改原dwg文件名
(progn
(setq
DocObj (vla-open
(vla-get-documents *acad*)
dxfFile
)
) ;打开dxf文件
(vla-saveas DocObj DwgName acR15_DWG)
;再存为2k版dwg文件
(vla-close DocObj
:vlax-false)
(deletefile
dxfFile) ;删除dxf文件
)
)
(princ)
)
;;154.4 [功能] 将文件以Wblock输出,并去教育版(文件名不变)
;;非打开的文件
;;示例
(DwgOutWblock "D:\\Drawing1.dwg")
(defun
DwgOutWblock
(DwgName /
BACKUPFILE BASENAME
DOCOBJ DXFFILE FILEPATH
NEWSET
SSETS
)
;;1 获取全路径，即路径后有
(defun GetFullPath (path)
(if (wcmatch path
"*\\")
path
(strcat path "\\")
)
)
;;2
能删除所有文件，不管只读、隐藏与否，都能删除
(defun DeleteFile (FIL / FILSYS FILDIR
SS ENT)
(setq FILSYS (vlax-create-object
"Scripting.FileSystemObject"))
(setq FILDIR
(vl-filename-directory FIL))
(setq
SS
(vl-directory-files
FILDIR
(strcat
(vl-filename-base FIL) (vl-filename-extension FIL))
1
)
)
(foreach ENT
SS
(vlax-invoke
FILSYS
"deletefile"
(strcat FILDIR "\\"
ENT)
:vlax-false
)
)
(vlax-release-object
FILSYS)
)
;;3 本程序主程序:1转成dxf 2原文件改名为备份 3打开并以wblock输出
4删除dxf
(setq BaseName (vl-filename-base
DwgName)
filepath (vl-filename-directory
DwgName)
dxfFile (vl-string-subst ".dxf" ".dwg"
DwgName)
BackupFile (strcat (getfullpath
filepath)
BaseName
"_Backup"
(vl-filename-extension
DwgName)
)
)
(Dwg2Dxf DwgName
dxfFile) ;利用objectdbx转存文件,目的是去教育版印戳
(if (findfile
BackupFile)
(deletefile BackupFile)
) ;检查原dwg文件的备份文件名是否存在，如果存在，则删除
(if
(vl-file-rename DwgName BackupFile) ;修改原dwg文件名
(progn
(setq
DocObj (vla-open
(vla-get-documents *acad*)
dxfFile
)
) ;打开dxf文件
(setq
ssets (vla-get-selectionsets DocObj))
(if
(vl-catch-all-error-p
(vl-catch-all-apply 'vla-item
(list ssets "$Set"))
)
(setq newSet (vla-add ssets
"$Set"))
(progn
(vla-delete (vla-item ssets
"$Set"))
(setq newSet (vla-add ssets
"$Set"))
)
)
;;select all objects in the
drawing
(vla-Select newSet
acSelectionSetAll)
(vla-WBlock DocObj DwgName
newSet)
(vla-close DocObj
:vlax-false)
(deletefile
dxfFile) ;删除dxf文件
)
)
(princ)
)
;;154.5 [功能] 打开的文件以Wblock输出,并去教育版(除激活的文档外,文件名不变)
(defun
DwgOutWblockOpen (/ *ACAD* *DOCS* BASENAME CUR DWGNAME DWGNAMEEXT
DWGNAMELIST FILEPATH N NEWDWGNAME SSOBJ)
;;1 获取全路径，即路径后有
(defun GetFullPath (path)
(if (wcmatch path
"*\\")
path
(strcat path "\\")
)
)
(setq
*DOCS* (vla-get-Documents *ACAD*)
)
;;2
打开的文件(除激活的文档外),全关闭,按非打开处理,再打开
;;DwgNameList除激活的文档外的打开文件列表,并关闭
(vlax-for item
*DOCS*
(if (= (vla-get-active item)
:vlax-false)
(progn (setq DwgName
(vlax-get-property item 'FullName))
(setq
DwgNameList (cons DwgName DwgNameList))
(vla-close item :vlax-false)
)
(setq cur item)
)
)
(setq n -1)
(repeat (length
DwgNameList)
(setq DwgName (nth (setq n (1+ n))
DwgNameList))
(DwgOutWblock DwgName)
(vla-open (vla-get-documents *acad*)
DwgName) ;再打开
)
;;3
激活的文档须更名输出
(setq DwgName (vlax-get-property cur 'FullName))
(setq BaseName (vl-filename-base DwgName))
(setq filepath
(vl-filename-directory DwgName))
(setq DwgNameExt
(vl-filename-extension DwgName))
(setq n -1)
(while
(findfile (setq NewDwgName
(strcat (getfullpath
filepath)
BaseName
(itoa (setq n (1+
n)))
DwgNameExt
)
)
)
)
(ssget "x"
(list (cons 410 (getvar "ctab"))))
(setq SSOBJ
(vla-get-activeselectionset cur))
(vla-wblock cur NewDwgName
SSOBJ)
(DwgOutWblock NewDwgName)
(vla-open
(vla-get-documents *acad*) NewDwgName)
(alert (strcat "\n 当前文档已经更名为"
BaseName (itoa n)))
(command "vbastmt"
"AcadApplication.activeDocument.close false ")
)
;;154.6 [功能]
打开的文件全部Wblock输出
(defun OpenFileWblock (/ *ACAD* *DOCS* BASENAME DWGNAME
DWGNAMEEXT EACH FILEPATH N NEWDWGNAME NEWSET SSETS J)
;;1
获取全路径，即路径后有
(defun GetFullPath (path)
(if (wcmatch path "*\\")
path
(strcat path "\\")
)
)
;;2 打开的文件更名输出
(setq *DOCS*
(vla-get-Documents *ACAD*))
(setq n -1)
(repeat
(vlax-get-Property *DOCS* 'count)
(setq each (vla-item
*docs* (setq n (1+ n))))
(setq DwgName (vlax-get-Property
each 'fullname))
(setq BaseName
(vl-filename-base DwgName)
filepath
(vl-filename-directory DwgName)
DwgNameExt
(vl-filename-extension DwgName)
)
(setq J -1)
(while (findfile (setq
NewDwgName
(strcat (getfullpath
filepath)
BaseName
(itoa (setq J (1+
J)))
DwgNameExt
)
)
)
)
(setq ssets
(vla-get-selectionsets each))
(if (vl-catch-all-error-p
(vl-catch-all-apply 'vla-item
(list ssets "$Set"))
)
(setq newSet
(vla-add ssets "$Set"))
(progn
(vla-delete (vla-item ssets "$Set"))
(setq newSet
(vla-add ssets "$Set"))
)
)
;;select all objects in the
drawing
(vla-Select newSet
acSelectionSetAll)
(vla-WBlock each NewDwgName
newSet)
)
(princ)
)
;;154.7 [功能]
复制非打开文件的块至本图
;;(Odbx-copyblocks 文件名)
;;(Odbx-copyblocks
"D:\\DrawingA.dwg"),之后输入命令i,就可以看到DrawingA的块均在本图中了
(defun Odbx-copyblocks
(DwgName / DBXBLOCKS DBXDOC NUM)
(setq dbxDoc
(vla-GetInterfaceObject
*acad*
(GetObjectDBXVer)
)
)
(vla-open dbxDoc DwgName) ;不能打开.dxf文件,返回nil
(setq DBXBLOCKS (vla-get-blocks dbxDoc))
(vlax-for
BLK DBXBLOCKS
(if (and (not (wcmatch (substr
(vla-get-name BLK) 1 1) "`*"))
(=
(vla-get-isxref BLK)
:vlax-false)
) ;去除系统块、匿名块和参照类对象
(setq namelst (append namelst (list (vla-get-name BLK))))
)
)
(foreach name namelst
(setq
num (vla-item DBXBLOCKS name))
(vla-copyobjects
dbxDoc
(vlax-safearray-fill
(vlax-make-safearray vlax-vbobject '(0 .
0))
(list num)
)
(vla-get-modelspace
(vla-get-activedocument
*acad*)
)
)
)
(if dbxDoc
(vlax-release-object
dbxDoc)
)
)
;;154.8 [功能] 复制非打开文件的特定块至本图
;;示例(CopyBlock
"D:\\DrawingA.dwg" "ccd1"),之后输入命令i,就可以看到DrawingA的"ccd1"块在本图中了
;;
COPYBLOCK.LSP Copyright ?999 Tony Tanzillo
;; http://www.caddzone.com
;; tony.tanzillo@caddzone.com
(defun
CopyBlock (DwgName BlkName / *ACAD* BLOCKS DBXDOC NUM)
(setq
blocks (vla-get-blocks (vla-get-ActiveDocument *acad*)))
(setq dbxDoc
(vla-GetInterfaceObject *acad* (GetObjectDBXVer)))
(vla-open dbxDoc
DwgName)
(setq num (vla-item (vla-get-blocks dbxDoc)
BlkName))
(vla-CopyObjects
dbxDoc
(vlax-safearray-fill
(vlax-make-safearray
vlax-vbObject
'(0 .
0)
)
(list
num)
)
blocks
)
(vlax-release-object dbxDoc)
(vla-item blocks BlkName)
)
;;154.9
[功能]
复制特定文件的块至本图(不论打开或者非打开)
;;本程序将选择一个文件,然后将其下的块均拷贝到本图中,用命令i就可以插入这些块了
(defun
B2CurDrawing (/ *ACAD* *DOC* *DOCS* FNAME FULLNAME LST)
(defun
Open-copyblocks (fname / BLOCKS DOC DOCBLOCKS NAMELST NUM)
(setq blocks (vla-get-blocks *DOC*))
(setq Doc
(vla-item *DOCS*
(strcat (vl-filename-base
fname)
(vl-filename-extension
fname)
)
)
)
(setq DocBLOCKS (vla-get-blocks
Doc))
(vlax-for BLK
DocBLOCKS
(if (and (not (wcmatch (substr
(vla-get-name BLK) 1 1) "`*"))
(=
(vla-get-isxref BLK) :vlax-false)
) ;去除系统块、匿名块和参照类对象
(setq namelst (append namelst
(list (vla-get-name BLK))))
)
)
(foreach name
namelst
(setq num (vla-item DocBLOCKS
name))
(vla-CopyObjects
Doc
(vlax-safearray-fill
(vlax-make-safearray
vlax-vbObject
'(0 . 0)
)
(list
num)
)
blocks
)
)
(vlax-release-object
doc)
)
(setq
*DOC* (vla-get-ActiveDocument
*acad*)
*DOCS* (vla-get-Documents *ACAD*)
)
;;(setq
fullname (vla-get-fullname *DOC*))
;;打开文件列表
(vlax-for
doc *DOCS*
(setq
lst (cons (if (/= (setq fname (vla-get-fullname doc))
"")
fname
(vla-get-name
doc)
)
lst
)
)
)
(setq fname
(getfiled "选择DWG文件"
(getvar
"DWGPREFIX")
"DWG"
0
)
)
;;(VL-FILE-SYSTIME fname);打开的文件返回nil,这个方法太好了
;;(vl-catch-all-error-p (vl-catch-all-apply 'vla-item (list *DOCS*
fname)))
(cond ((and fname (member fname lst) (not (equal
fullname fname)))
(Open-copyblocks fname)
)
((and
fname (not (member fname lst)))
(Odbx-copyblocks
fname)
)
(T nil)
)
(princ)
)
;;155 [功能] 统计组定义个数--lxx.2004.2
(defun c:countgp ()
(vla-get-count (vla-get-groups *DOC*))
)
;;155.1.1 [功能] 炸开所有组
(defun
c:delgps ()
(vlax-for obj (vla-get-groups *DOC*)
(vla-delete obj)
)
)
;;155.1.2 [功能] 分解组
(defun
bns_groups_unsel (/ na e1 a n lst lst2 lst3)
(defun m_assoc (a
lst / b lst2)
(while (setq b (assoc a
lst))
(setq lst (cdr (member b
lst))
lst2 (append lst2 (list
b))
)
)
lst2
)
(setq lst (dictsearch
(namedobjdict) "ACAD_GROUP"))
(setq lst2 (m_assoc 3 lst))
(repeat (setq n (length lst2))
(setq a (nth
(setq n (1- n )) lst2))
(setq na (cdr (car (cdr (member a
lst)))))
(setq e1 (entget na))
(if (member '(71 . 1) e1)
(progn
;;(command "_.-group" "_sel" (cdr a) "_y")
(setq e1
(subst '(71 . 0) '(71 . 1) e1))
(entmod e1)
(setq lst3 (append
lst3 (list na)))
)
)
)
lst3
)
;;155.1.3 [功能]
重组分解组
;;(setq lst (bns_groups_unsel))(bns_groups_sel lst)
(defun
bns_groups_sel (lst / n na e1)
(repeat (setq n (length
lst))
(setq na (nth (setq n (1- n)) lst)
e1 (entget na)
)
(setq e1 (subst
'(71 . 1) '(71 . 0) e1))
(entmod e1)
)
)
;;155.1.4 删除匿名组(并不删除组对象) lxx.2005.10.
(defun c:del*gp ()
(vlax-for obj (vla-get-groups *DOC*)
(if (wcmatch
(vla-get-name obj)"'**")(vla-delete obj))
)
)
;;155.1.5 [功能] 删除空组及数量为1的组定义(并不删除组对象) By lxx.2005.10改.
(defun c:delgp0
()
(vlax-for obj (vla-get-groups *DOC*)
(if
(< (vla-get-count obj)2)(vla-delete obj))
)
)
;;155.2 [功能]
组定义添加实体.
(defun GroupAdd (/ B G)
(if (and (setq g (car (entsel
"\n 击要添加对象的组：")))
(setq b (cons 340 (car (entsel "\n
添加到组的对象："))))
)
(progn
(setq g (gpdef1 G))
(entmod (append g (list
b)))
)
)
(princ)
)
;;155.3.1
[功能] 所有组列表
(defun c:listgps ()
(vlax-for
obj (vla-get-groups
(vla-get-activedocument
*acad*)
)
;;(setq gphd (append gphd (list
(vla-get-handle obj))))
(print (entget (handent
(vla-get-handle obj))))
)
;;(mapcar '(lambda (x) (print
(entget (handent x))) (print)) gphd)
(princ)
)
;;155.3.2 [功能]
所有可选择的组名列表
;;组可选标志: dxf70 =3?
(defun c:gpsel1 (/ gps)
(vlax-for
obj (vla-get-groups
(vla-get-activedocument
*acad*)
)
(if ;;(/= 3 (cdr (assoc 70
(entget (vlax-vla-object->ename obj)))))
(/=
3
(cdr (assoc 70 (entget (handent (vla-get-handle
obj)))))
)
(setq gps (append gps
(list (vla-get-name obj))))
)
)
gps
)
;;155.3.3 [功能] 求所有组名列表
(defun c:gpsel2 (/ LST)
(setq
lst (dictsearch (namedobjdict) "ACAD_GROUP"))
(mapcar
'cdr
(vl-remove-if '(lambda (x) (/= 3 (car x))) lst)
)
)
;;155.4.1 [功能] 求组定义(一重的组)
;;测试: (gpdef1 (car(entsel)))
(defun gpdef1
(gpe)
(entget(cdr(assoc 330 (entget gpe))))
)
;;155.4.2 [功能]
求组内实体(一重的组)
;;测试:返回-> (<图元名: 7ef7ceb0> <图元名: 7ef7ceb8>
<图元名: 7ef7cea8>)
(defun C:GetGroupEntity ()
(mapcar
'cdr
(vl-remove-if
'(lambda (x) (/=
340 (car x)))
(gpdef1 (car
(entsel)))
)
)
)
;;155.4.3 [功能]
求组名(一重的组)
(defun C:GroupName1 (/ GPDEFL GPDICT GPNAME)
(setq gpdefl
(gpdef1 (car (entsel))))
(setq gpdict (entget (cdr (assoc 330
gpdefl))))
(setq gpname (cdadr (member (cons 350 (cdr (assoc -1
gpdefl)))
(reverse
gpdict)
)
)
)
)
;;155.5.1
[功能] 求组定义列表 -> (组定义1 组定义2 ...):
;;测试: (gpdef (car(entsel)))
(defun
gpdef (gpe / el lst a gpdf gplst)
(setq el (entget gpe))
(if
(setq lst (member '(102 . "{ACAD_REACTORS") el))
(while
(and (setq lst (cdr lst)) (= 330 (car (setq a (car
lst)))))
(if (= "GROUP" (cdr (assoc 0 (setq
gpdf (entget (cdr a))))))
(setq gplst (cons gpdf
gplst))
)
)
)
(reverse gplst)
)
;;155.5.2 [功能] 求组内实体:
求组信息-----lxx.2004.5
;;示例:(getgp (car(entsel)))=>(("G3" <Entity name:
7ef7bd90> (<Entity name: 7ef7b500> <Entity name: 7ef7b378>))
("G4" <Entity name: 7ef7bd98> (<Entity name: 7ef7b500><Entity
name: 7ef7b378> <Entity name: 7ef7acd0>)))
(defun getgp (gpe /
GPDICT GPELST GPENT GPNAME X)
(mapcar '(lambda
(x)
(setq gpent (cdr (assoc -1
x))
gpelst (mapcar
'cdr
(vl-remove-if '(lambda (x) (/= 340 (car
x))) x)
)
gpdict (entget
(cdr (assoc 330 x)))
gpname (cdadr (member (cons 350
gpent) (reverse gpdict)))
)
(list gpname gpent
gpelst)
)
(gpdef gpe)
)
)
;;155.5.3 [功能] 取得组名列表:
;; (gpn1 (car(entsel))) -> ("X1" "X2"
"TT")
(defun gpn1 (gpe / el lst a gpdf gps gpname gpnlst)
(setq el
(entget gpe))
(if (setq lst (member '(102 . "{ACAD_REACTORS")
el))
(while (and (setq lst (cdr lst)) (= 330 (car (setq a
(car lst)))))
(if (= "GROUP" (cdr (assoc 0
(setq gpdf (entget (cdr a))))))
(setq gps (if
gps
gps
(entget (cdr (assoc 330
gpdf)))
)
gpname (cdadr (member (cons 350 (cdr
(assoc -1 gpdf)))
(reverse
gps)
)
)
gpnlst (cons gpname
gpnlst)
)
)
)
)
(reverse gpnlst)
)
;;155.5.4 [功能] 取得组名列表:
;;
(gpn2 (car(entsel))) -> ("X1" "X2" "TT")
(defun gpn2 (gpe / el lst a g
gpnlst)
(setq el (entget gpe))
(if (setq lst (member
'(102 . "{ACAD_REACTORS") el))
(while (and (setq lst (cdr
lst)) (= 330 (car (setq a (car lst)))))
(if (=
"GROUP" (cdr (assoc 0 (entget (setq g (cdr a))))))
;;(=
"AcDbGroup" (vla-get-objectName (setq gobj (vlax-ename->vla-object (cdr
a)))))
(setq gpnlst (cons (vla-get-Name (vlax-ename->vla-object g))
gpnlst))
)
)
)
(reverse gpnlst)
)
;;155.5.5 [功能] 取得组名列表:
(defun gpn3 (/
doc theobj grp obj kj ip)
(setq doc (vla-get-Activedocument
*acad*))
(vla-getentity
(vla-get-utility
doc)
'theobj
'ip
"\nSelect Object: "
)
(vlax-for
grp (vla-get-groups doc)
(vlax-for obj
grp
(if (equal (vla-get-objectid obj)
(vla-get-objectid theobj))
(setq kj (cons (vla-get-name grp)
kj))
)
)
)
kj
)
;;155.5.6 [功能] 取得组名列表:
;;(gpn4
(car(entsel)))
(defun gpn4 (e / g)
;;获取实体的永久反应器 --- by
eachy
;;(get_object_reactor (car(entsel))),同(acet-acadreactor-ids-get
(car (entsel)))-by lucas
(defun get_object_reactor (e / elst lst
etlst)
(setq elst (entget e))
(if (and (assoc 102 elst)
(= (cdr (assoc
102 elst)) "{ACAD_REACTORS")
)
(progn
(setq lst (cdr (member '(102 . "{ACAD_REACTORS")
elst)))
(while (= (caar lst) 330)
(setq etlst (cons
(cdar lst) etlst))
(setq lst (cdr
lst))
)
)
)
etlst
)
(setq lst
(get_object_reactor e))
(foreach item (mapcar
'vlax-ename->vla-object lst)
(if (=
(vla-get-objectname item) "AcDbGroup")
(setq g
(cons (vla-get-name item) g))
)
)
g
)
;;155.5.7 [功能] 取得组名列表: --by 灯火
;;(gpn5 (car(entsel)))
(defun
gpn5 (eName / DXF102 ELIST EN ET GPNAME OBJGROPU)
(setq dxf102 (assoc
102 (entget eName)))
(if (and dxf102 (= (cdr dxf102)
"{ACAD_REACTORS"))
(progn
(setq
eList (cdr (member '(102
. "{ACAD_REACTORS") (entget eName)))
)
(while (= (caar eList) 330)
(setq
en (cdar eList))
(setq et (cdr (assoc 0 (entget en))))
(if (=
et "GROUP")
(progn
(setq objGropu
(vlax-ename->vla-object en))
(setq gpName (cons
(vla-get-Name objGropu) gpName))
)
)
(setq
eList (cdr eList))
)
)
)
gpName
)
;;155.5.8 [功能] 取得组名列表: --by 灯火
;;(gpn6
(car(entsel)))
(defun gpn6 (ename / key dct rtn)
(setq key
(cons 340 ename)
dct (dictsearch (namedobjdict) "acad_group")
)
(while (setq dct (member (assoc 3 dct) dct))
(if (member key (entget (cdadr dct)))
(setq rtn (cons (cdar dct) rtn))
)
(setq dct (cddr dct))
)
(reverse rtn)
)
;;155.5.9 [功能]
取得组名列表: --by 灯火
;;(gpn7 (car(entsel)))
(defun gpn7 (Obj / Cur_ID
NmeLst)
(setq Gb:AcO (cond
(Gb:AcO)
(T
*acad*)
)
Gb:AcD (cond
(Gb:AcD)
(T (vla-get-activedocument
Gb:AcO))
)
Cur_ID
(vla-get-ObjectID (vlax-ename->vla-object Obj))
)
(vlax-for Grp (vla-get-Groups Gb:AcD)
(vlax-for Ent
Grp
(if (equal (vla-get-ObjectID Ent)
Cur_ID)
(setq NmeLst (cons (vla-get-Name Grp)
NmeLst))
)
)
)
(reverse NmeLst)
)
;;155.6 [功能]
生成无名组
;;示例(acet-group-make-anon (list WIPOUT TXT) "In use by
TEXTMASK")
(defun acet-group-make-anon (LST DESC / EN)
(command
"_.-group" "_create" "*" DESC)
(foreach EN LST (command EN))
(command "")
)
;;156.1 [功能] 删除重叠对象(overkill)
;;不知谁写的,太好了.
;;(HH:delBLOCKs (ssget)
nil)
(DEFUN HH:delBLOCKs (ss dxf / E EN LST N)
(setq dxf (append
'(-1 5 330) dxf))
(repeat (setq n (sslength ss))
(setq e (ssname ss (setq n (1- n))))
(setq en
(vl-remove-if '(lambda (x) (member (car x) dxf)) (entget
e)))
(cond ((member en lst) (entdel e))
(T
(setq lst (cons en lst)))
)
)
)
;;156.2
[功能] 删除重叠数字，保留较大的数或保留较小的数---Gu_xl
(defun c:delWords (/ kd e ll ur n s1 L
SS)
(initget "Big Small")
(setq kd (getkword
"\n[留大数Big/留小数Small]<Big>:"))
(if (= "Small"
kd)
(setq kd <)
(setq kd
>)
)
(while (setq ss (ssget ":S" '((0 .
"*text"))))
(while (> (sslength ss)
0)
(setq e (ssname ss
0))
(vla-GetBoundingBox
(vlax-ename->vla-object e) 'll 'ur)
(setq
ll (vlax-safearray->list ll)
ur
(vlax-safearray->list ur)
)
(setq s1 (ssget
"c"
(trans ll 0
1)
(trans ur 0
1)
'((0 .
"*text"))
)
l nil
)
(repeat (setq n (sslength
s1))
(setq l (cons (ssname s1 (setq n (1- n)))
l))
)
(setq
l (vl-sort l
'(lambda (a b)
(kd (atof (cdr (assoc 1 (entget
a))))
(atof (cdr (assoc 1
(entget b))))
)
)
)
)
(ssdel
(car l) ss)
(foreach a (cdr l)
(ssdel
a ss)
(entdel a)
)
)
)
(princ)
)
;;157 [功能] 曲线取点函数(用于封闭曲线内局部放大或者删除其内图元时)(见164.45)
;;(mapcar '(lambda(x)
(command "line" x '(0 0) "")) (get-spline-vertexs (car(entsel))
10))
;;改造highflybir程序，使之适合圆、椭圆、弧(自贡黄明儒 2014.11.7)
(defun
get-spline-vertexs (ent n / DIST ENDPAR LEN NAME OBJ PT PTS SEG)
(setq
obj (vlax-ename->vla-object ent))
(setq endpar
(vlax-curve-getEndParam obj))
(setq len (vlax-curve-getDistAtParam obj
endpar))
(setq seg (/ len n))
(setq dist 0)
(while
(< dist len)
(setq pt (vlax-curve-getPointAtDist obj
dist))
(setq pts (cons pt pts))
(setq dist (+ seg dist))
)
(setq Name (vlax-get obj
'ObjectName))
;;改造适合圆、椭圆、弧(自贡黄明儒 2014.11.7)
(cond ((and
(equal Name "AcDbSpline")
(=
(vla-get-closed obj) :vlax-false)
)
(setq pt
(vlax-curve-getEndPoint obj)
pts
(cons pt pts)
)
)
)
(reverse
pts)
)
;;158.1 [功能] ENTSEL函数功能扩展 caoyin
;;
MSG：和ENTSEL一样，为用于提示用户的字符串，当该参数为nil时，缺省提示信息为"选择对象: "。
;;
FIL：图元dxf特性过滤器，和ssget函数相同。
;;
ERRMAG：出错提示信息，在选择目标不符合条件时在命令行打印。当该参数为nil时，缺省提示信息为"无效的对象。"。
(defun MC:ENTSEL1
(MSG FIL ERRMSG / E PF SS RT ERR)
(setq E T
PF
(getvar 'PICKFIRST)
)
(or ERRMSG (setq ERRMSG
"无效的对象。"))
(setvar 'PICKFIRST 1)
(while
E
;;用apply的目的在于当entsel后面的参数为nil时不会出错。
(if (setq E
(apply 'entsel (cond (MSG (list MSG)))))
(cond
((vl-consp E)
;;后面的ssadd是建立一个空选择集，前面的ssadd是向该空选择集中添加entsel所拾取的图元。
(setq SS (ssadd
(car E) (ssadd)))
;;将选择集SS设为已选择状态
(sssetfirst nil
SS)
(setvar "nomutt" 1)
;;获取当前激活的选择集，而过滤器则保证从中筛选出符合条件的对象。
(if (setq SS (ssget "_I"
FIL))
;;当SS返回为真，则将变量E设为nil以结束while，反之则打印出错提示信息，并将变量E设为T以确保while继续执行。
(setq RT E
E nil
)
(progn (princ ERRMSG) (setq E T))
)
(setvar "nomutt" 0)
)
(T
(setq RT
E
E nil
)
)
)
;;当ERRNO返回7，表明用户鼠标的拾取点上没有对象，变量E设为T确保while继续。若ERRNO返回52则表明用户右击鼠标放弃选择。
(cond ((= (setq ERR (getvar 'ERRNO)) 7)
(setq
E T)
(princ
"未选择对象。")
)
((= ERR 52)
(setq E nil))
)
)
)
(setvar 'PICKFIRST PF)
RT
)
;;158.2 [功能]
带提示、关键字、过滤表、选择错误时的提示并且会亮显所选对像的entsel
;;(clh-entsel "\n请选择一个圆：" "A
B C" '((0 . "circle"))
"\n所选对像不符合要求！请重新选择：")
;;说明：过滤表与ssget的过滤表相同;函数由CLH521，2009.6.7
(defun
clh-entsel (msg key fil ermsg / el)
(while
(and
(setvar "errno"
0)
(not
(and
(setq el
(apply '(lambda (msg key) (initget key) (entsel msg)) (list msg
key)))
(cond
((= (type el) 'str)
el)
(T
(cond
((ssget (cadr el) fil) (princ "Good Job!\n"))
(T
(prompt ermsg))
)
)
)
)
)
(/= (getvar "errno")
52)
)
)
(cond ((= (type el) 'list)
(redraw (car el) 3)))
el
)
;;158.3 [功能] 带过滤器的entsel
By飞诗
(defun Fsxm-entsel (msg filter)
(setq enp (entsel
msg))
(if (or (= (type enp) 'str)
(and enp (ssget
(cadr enp) filter))
)
enp
)
)
;;159 [功能] 块爆破(属性转成文字)burst
(Defun C:HH:BURST2 (/ ENAME SS1)
;;1 Item from association list
(Defun ITEM (N E) (CDR (Assoc N
E)))
;;2 Convert Attribute Entity to Text Entity
(Defun ATT-TEXT (AENT / TENT ILIST INUM)
(Setq TENT '((0 .
"TEXT")))
(ForEach INUM
'(8 6 38 39 62 67 210 10 40 1 50 41 51 7 71 72 73 11
74)
(If (Setq ILIST (Assoc INUM
AENT))
(Setq TENT (Cons ILIST TENT))
)
)
(Setq tent (Subst (Cons 73 (item
74 aent)) (Assoc 74 tent) tent))
(EntMake (Reverse
TENT))
)
;;3 BURST-ONE
(Defun
BURST-ONE1
(BNAME / AENT AGAIN ANAME ATYPE BENT ENAME SS SS1
SS2)
(Setq BENT (EntGet BNAME))
(If (= 1 (ITEM 66
BENT)) ;如果是属性块
(Progn (Setq ANAME
BNAME)
(While (Setq ANAME (EntNext
ANAME)
AENT (EntGet
ANAME)
ATYPE (ITEM 0
AENT)
AGAIN (= "ATTRIB"
ATYPE)
)
(ATT-TEXT
AENT)
)
)
)
(command "_.explode"
bname)
(setq ss (ssget "_p"))
(setq
ss2 (ssget "_p" '((0 . "ATTDEF"))))
(command "._Select" ss
"")
(setq ss1 (ssget "_p" '((0 .
"INSERT"))))
(if ss2
(command "_.erase" ss2
"")
)
(If SS1
(Progn
(Repeat (SsLength SS1)
(Setq ENAME (SsName
SS1 0))
(SsDel ENAME SS1)
(BURST-ONE1
ENAME) ;递归
)
)
)
)
;;4 主程序
(Setq SS1
(SsGet (list (cons 0 "INSERT"))))
(If SS1
(Progn
(Setvar "highlight" 0)
(terpri)
(Repeat (SsLength SS1)
(Setq ENAME (SsName SS1
0))
(SsDel ENAME
SS1)
(BURST-ONE1 ENAME)
)
(princ "\n ")
)
)
(princ)
)
;;160.1 [功能] 获取指定文件夹(不包括子文件夹)下所有满足扩展名的文件
(defun GetFullPath
(path)
(if (wcmatch path "*\\")
path
(strcat path "\\")
)
)
;;返回列表文件表元素全为小写
;;示例(GetAllSpecFilesInFolder "D:\\TEMP\\"
"*.dwg")
(defun GetAllSpecFilesInFolder (dir filter)
(mapcar
(function
(lambda (file)
(strcase (strcat (getfullpath dir) file)
T)
)
)
(vl-directory-files dir filter 1)
)
)
;;160.2 [功能] 获取指定文件夹(包括子文件夹)下所有满足扩展名的文件
;;
示例(GetAllSpecFilesInFolders "D:\\TEMP\\" "*.dwg")
(defun
GetAllSpecFilesInFolders (dir filter / filenames)
(setq filenames (mapcar
(function
(lambda
(file)
(strcase (strcat (getfullpath dir) file)
T)
;;递归出口
)
)
(vl-directory-files dir filter 1)
)
)
(mapcar
(function
(lambda (subdir)
;; 此处递归
(setq
filenames (append filenames
(GetAllSpecFilesInFolders
(strcat (getfullpath dir) subdir)
filter
)
)
)
)
)
(vl-remove-if
(function (lambda (subdir)
(member subdir '("."
".."))
)
)
(vl-directory-files dir nil
-1)
)
)
filenames
)
;;161.1 [功能]
选择集->VlaSS集合
;;(vlax-map-Collection (ss->vlass ss)
'vla-delete)
(defun ss->vlass (ss)
(command "_.select" ss
"")
(vla-get-activeselectionset
(vla-get-ActiveDocument *acad*)
)
)
;;161.2 [功能]
lisp选择集或图元转为vla选择集 By namezg
;;(vlax-map-Collection (SS->vlaSS ss)
'vla-delete)
(defun SS->vlaSS1 (ss / *DOC* I OBJLST SARRAY SSET
VLA)
(setq *DOC* (vla-get-ActiveDocument *acad*))
(setq SSet
(vla-get-ActiveSelectionSet *DOC*))
(vla-Clear
SSet) ;清空选择集
;;得到VLA物体列表
(repeat (setq i
(sslength ss))
(setq vla (vlax-ename->vla-object
(ssname ss (setq i (1- i)))))
(setq objlst (cons vla
objlst))
)
(setq sArray
(vlax-make-safearray
vlax-vbobject
(cons 0 (1-
(length objlst)))
)
) ;在数组 SArray 的元素中存储数据
(vlax-safearray-fill sArray objlst)
(vla-AddItems SSet sArray)
SSet
)
;;161.3 [功能] 将一个选择集转化为VLA选择集 By 裸奔的花猫
(defun ss->vlass2 (ss / *DOC* I
OBJLST SSET VLA)
(setq *DOC* (vla-get-activedocument
*acad*)
sset (vla-get-SelectionSets *DOC*)
)
;;有选择集$Set，则先删除,或者(vla-Clear $Set)
(if
(vl-catch-all-error-p
(vl-catch-all-apply 'vla-item (list sset
"$Set"))
)
nil
(vla-delete (vla-item sset "$Set"))
)
(setq SSet (vla-add sset "$Set")) ;新建一个VLA选择集
;;得到VLA物体列表
(repeat (setq i (sslength ss))
(setq
vla (vlax-ename->vla-object (ssname ss (setq i (1-
i)))))
(setq objlst (cons vla objlst))
)
(vlax-invoke SSet 'additems objlst)
SSet
)
;;162.1 [功能] 数值后续零清除(见121)
;|值为 0 到 3 时仅影响英尺-英寸标注：
DIMZIN
0
消除零英尺和零英寸
1 包含零英尺和零英寸
2 包含零英尺，消除零英寸
3 包含零英寸，消除零英尺
4
消除十进制标注中的前导零（例如，0.5000 变为 .5000）
8 消除十进制标注中的后续零（例如，12.5000 变为 12.5）
12
消除前导零和后续零（例如，0.5000 变为 .5）
|;
;;示例(HH:rtosr 2.500)；"2.5"
(defun
HH:rtosr (RealNum / DIMZIN1 SHORTREAL1)
(setq DimZin1 (getvar
"DIMZIN"))
(setvar "DIMZIN" 8)
(setq ShortReal1 (rtos
RealNum 2 8))
(setvar "DIMZIN" DimZin1)
ShortReal1
)
;;162.2 [功能] 保留小数位数(四舍五入)
;|(rtos 数 mode 小数位数)
mode
1
Scientific
2 Decimal
3 Engineering (feet and decimal
inches)
4 Architectural (feet and fractional inches)
5
Fractional
|;
;;示例1 保留一位小数，四舍五入(HH:rtosr1 2.555 1)；"2.6"
;;示例2
取整数，四舍五入(read(HH:rtosr1 215.46 0))，返回215
;;示例3 十位数，四舍五入(* (read(HH:rtosr1 (/
215.46 10) 0)) 10)，返回220
;;示例4 保留一位小数，四舍五入(read(HH:rtosr1 215.46
1))，返回215.5
(defun HH:rtosr1 (RealNum n / DIMZIN1 SHORTREAL1)
(setq
DimZin1 (getvar "DIMZIN"))
(setvar "DIMZIN" 0)
(setq
ShortReal1 (rtos RealNum 2 n))
(setvar "DIMZIN" DimZin1)
ShortReal1
)
;;163.1 [功能] lisp反应器是否启用
(defun HH::List-p (/ FLAG)
(foreach x
(vlr-reactors :vlr-lisp-reactor)
(cond ((VLR-added-p (cadr
x)) (setq Flag T)))
)
Flag
)
;;163.2 [功能]
启动lisp反应器HH::editor:start
(defun HH::List:start ()
(vlr-lisp-reactor
nil
'((:VLR-lispWillStart . HH:SaveOsmode)
(:vlr-lispEnded . HH:ResetOsmode)
(:vlr-lispCancelled . HH:ResetOsmode)
)
)
)
;;163.3 [功能] 停止lisp反应器
(defun HH::List:stop (/ X)
(foreach x (vlr-reactors :vlr-lisp-reactor)
(cond
((VLR-added-p (cadr x)) (VLR-Remove (cadr x))))
)
)
;;163.4 [功能]
定义lisp回调函数(开始)
(defun HH:SaveOsmode (v1 v2)
(setq HH:Osmode
(vl-catch-all-apply 'getvar (list "osmode")))
(princ)
)
;;163.5 [功能] 定义lisp回调函数(程序结束)
(defun HH:resetosmode (v1
v2)
(vl-catch-all-apply 'setvar (list "osmode"
HH:Osmode));常用捕捉
(HH:DBLCLKEDIT) ;双击
(cond ((and (getvar "STATUSBAR") (= (getvar "STATUSBAR") 0)) (setvar "STATUSBAR"
2)))
(princ)
)
;;164.1 [功能] 曲线是否封闭
;;示例(HH:isClosed (car (entsel)))
(defun HH:isClosed
(e)
(or (vlax-curve-isclosed e)
(equal (vlax-curve-getstartpoint e)
(vlax-curve-getendpoint e)
1e-5
)
)
)
;;164.2
[功能]使多段线封闭
(defun HH:MakeClosed (en / OBJ)
(cond ((equal (type
en) 'ENAME) (setq obj (vlax-ename->vla-object en)))
(T (setq obj
en))
)
;;(if (equal (vlax-get obj 'Closed) 0) (vlax-put obj
'Closed -1))
(if (not (vlax-curve-isclosed
obj)) ;(equal (vlax-get-property obj
'closed) :vlax-false)
(vla-put-closed obj
:vlax-true)
)
)
;;164.3 [功能] 多段线端点列表
;;示例(HH:PtLists (car
(entsel)))
(defun HH:PtLists (en)
(mapcar 'cdr
(vl-remove-if-not '(lambda (x) (= (car x) 10)) (entget en))
)
)
;;164.4 [功能] 矩形中点坐标
;;示例(HH:RectangCen (car (entsel)))
(defun
HH:RectangCen (en / PL X Y)
(setq pl (vl-remove-if-not '(lambda (x) (=
(car x) 10)) (entget en)))
(setq pl (mapcar 'cdr pl))
(mapcar '(lambda (X Y) (* (+ X Y) 0.5)) (car pl) (caddr
pl))
)
;;示例(HH:RectangCen1 (car (entsel)))
(defun HH:RectangCen1 (en /
OBJ PL PL1 X Y)
(setq obj (vlax-ename->vla-object en))
(setq pl (vlax-safearray->list (vlax-variant-value (vla-get-coordinates
obj))))
(setq pl1 (cddddr pl))
(mapcar '(lambda (X Y) (* (+
X Y) 0.5))
(list (car pl) (cadr pl))
(list (car
pl1) (cadr pl1))
)
)
;;164.5 [功能] 参数param处的切线方向的角度
;;示例(HH:ParamFirstAngle (car (entsel))
1)
;;注1 (vlax-curve-getFirstDeriv obj param)
函数计算的值是曲线上在参数值为param点处的切线方向
;;注2 param起始值为0
(defun HH:ParamFirstAngle (obj
param)
(setq pt (vlax-curve-getpointatparam obj param))
(angle pt (mapcar '+ pt (vlax-curve-getFirstDeriv obj param)))
)
;;164.6 [功能] 参数param处的法线方向的角度
;;示例(HH:ParamSecondAngle (car (entsel))
1)
;;注:param处是直线，则返回0.0
(defun HH:ParamSecondAngle (obj param)
(setq pt (vlax-curve-getpointatparam obj param))
(angle pt (mapcar '+
pt (vlax-curve-getSecondDeriv obj param)))
)
;;164.7 [功能] 曲线一点的切线方向的角度
;;示例(HH:PtFirstAngle (car (entsel))
(getpoint))
(defun HH:PtFirstAngle (obj pt)
(setq param
(vlax-curve-getParamAtPoint obj pt))
(angle pt (mapcar '+ pt
(vlax-curve-getFirstDeriv obj param)))
)
;;164.8 [功能] 曲线一点的法线方向的角度
;;示例(HH:PtSecondAngle (car (entsel))
(getpoint))
(defun HH:PtSecondAngle (obj pt)
(setq param
(vlax-curve-getParamAtPoint obj pt))
(angle pt (mapcar '+ pt
(vlax-curve-getSecondDeriv obj param)))
)
;;164.9 [功能] 去除多段线重点(见114.5)
;;示例(HH:Remove (car (entsel)) 1e-3)
(defun
HH:Remove (e fuzz / I LST P0 P1 PAR)
(cond ((IsTrueClosePL e)
(MakeTrueClosePL e))) ;如果假闭合，变成真闭合
(cond ((HH:isClosed e)
(setq Par (fix (vlax-curve-getEndParam E)))))
(setq i 0)
(foreach x (entget e)
(cond
((= 10 (car
x))
(setq i (1+
i))
(cond
(p0
(setq p1 p0)
(setq p0 (cdr x))
(cond ((and
Par (not (= i Par))) (setq Lst (cons x Lst)))
(T (cond ((not
(equal p1 p0 fuzz)) (setq Lst (cons x Lst)))))
)
)
(T (setq p0 (cdr x)) (setq Lst (cons x
Lst)))
)
)
(T (setq
Lst (cons x Lst)))
)
)
(entmod
(reverse Lst))
)
;;164.10 [功能] 判断点是否在曲线上
;;示例(HH:PtOnCurve (getpoint) (car
(entsel)))
(defun HH:PtOnCurve (pt curve)
(equal pt
(vlax-curve-getClosestPointTo curve pt) 0.00001)
)
;;164.11 [功能] 曲线长度
;;直线、圆弧、圆、多段线、优化多段线、样条曲线等图元
;;示例 (HH:GetCurveLength
(car (entsel)))
(defun HH:GetCurveLength (curve)
(vlax-curve-getDistAtParam curve (vlax-curve-getEndParam curve))
)
;;164.12 [功能] 多段线子段数量
;;相当于组码90
;;示例 (HH:GetCurveNum (car
(entsel)))
(defun HH:GetCurveNum (obj)
(if (vlax-curve-isClosed
obj)
(fix (1- (vlax-curve-getendParam
obj)))
(fix (vlax-curve-getendParam obj))
)
)
;;164.13 [功能] 曲线中点
;;示例 (HH:GetMidpointCurve (car (entsel)))
(defun
HH:GetMidpointCurve (curve / d)
(setq d (vlax-curve-getEndParam
curve));终点参数
(setq d (* (vlax-curve-getDistAtParam curve d)
0.5))
(vlax-curve-getPointAtDist curve d)
)
;;164.14 [功能] 曲线一点的参数param
;;(HH:PtToParam (car (entsel))
(getpoint))
(defun HH:PtToParam (obj pt)
(vlax-curve-getParamAtPoint obj pt)
)
;;164.15 [功能]
参数param处的坐标
;;(HH:ParamTopt (car (entsel)) 0)
(defun HH:ParamTopt (obj
param)
(vlax-curve-getPointAtParam obj param)
)
;;164.16 [功能]
多段线第n子段的起点坐标
;;示例 (HH:GetSegStratPt (car (entsel)) 0)
(defun
HH:GetSegStratPt (curve n)
(vlax-curve-getPointAtParam curve (fix
n))
)
;;164.17 [功能] 多段线第n子段的终点坐标
;;示例 (HH:GetSegEndPt (car (entsel))
0)
(defun HH:GetSegEndPt (curve n)
(vlax-curve-getPointAtParam
curve (1+ (fix n)))
)
;;164.18 [功能] 多段线所点击子段的两端点列表
;;示例(HH:PickSegEndPt (car(setq en(entsel)))
(cadr en))
(defun HH:PickSegEndPt (obj p / pp n)
(setq pp
(vlax-curve-getclosestpointto obj (trans p 1 0))
n (fix
(vlax-curve-getparamatpoint obj pp))
)
(list (vlax-curve-getPointAtParam obj
n)
(vlax-curve-getPointAtParam obj (1+ n))
)
)
;;164.19 [功能] 多段线所点击点最近的一个顶点
;;示例(HH:PickClosePt (car(setq en(entsel)))
(cadr en))
(defun HH:PickClosePt (obj p / N P1 P2 PP)
(setq pp
(vlax-curve-getclosestpointto obj (trans p 1 0))
n (fix
(vlax-curve-getparamatpoint obj pp))
)
(setq p1
(vlax-curve-getPointAtParam obj n))
(setq p2
(vlax-curve-getPointAtParam obj (1+ n)))
(if (< (distance pp p1)
(distance pp p2))
p1
p2
)
)
;;164.20 [功能] 多段线所点击子段param(索引)
;;示例(HH:PickSegIndex (car(setq
en(entsel))) (cadr en))
(defun HH:PickSegIndex (obj p / PP)
(setq
pp (vlax-curve-getclosestpointto obj (trans p 1 0)))
(fix
(vlax-curve-getparamatpoint obj pp))
)
;;164.21 [功能]
多段线所点击子段的起点坐标
;;示例(HH:PickSegStratPt (car(setq en(entsel))) (cadr
en))
(defun HH:PickSegStratPt (obj p / pp n)
(setq pp
(vlax-curve-getclosestpointto obj (trans p 1 0))
n (fix
(vlax-curve-getparamatpoint obj pp))
)
(vlax-curve-getPointAtParam obj n)
)
;;164.22 [功能]
多段线所点击子段的终点坐标
;;示例(HH:PickSegEndPt (car(setq en(entsel))) (cadr
en))
(defun HH:PickSegEndPt (obj p / pp n)
(setq pp
(vlax-curve-getclosestpointto obj (trans p 1 0))
n (fix
(vlax-curve-getparamatpoint obj pp))
)
(vlax-curve-getPointAtParam obj (1+ n))
)
;;164.23 [功能]
多段线所击点离起点近
;;示例(HH:PickToStart (car(setq en(entsel))) (cadr en))
(defun
HH:PickToStart (curve p / L1 L2 PP)
(setq pp
(vlax-curve-getclosestpointto curve (trans p 1 0)))
(setq L2
(vlax-curve-getDistAtParam curve (vlax-curve-getEndParam curve)))
(setq L1 (vlax-curve-getDistAtPoint curve pp))
(> (- L2 L1)
L1)
)
;;164.24 [功能] 多段线所击子段是否是直线(返回nil是弧)
;;示例(HH:PickArc (car(setq
en(entsel))) (cadr en))
(defun HH:PickArc (curve p / PP)
(setq pp
(vlax-curve-getclosestpointto curve (trans p 1 0)))
(setq pp
(vlax-curve-getSecondDeriv
curve
(fix (vlax-curve-getparamatpoint curve
pp))
)
)
(equal pp '(0.0 0.0
0.0))
)
;;164.25 [功能] 求多段线上的弧段(圆或圆弧也有效)的圆心 by caoyin
;;(HH:GetCenter1 (entsel
"\n选择多段线弧段: "))
(defun HH:GetCenter1 (EP / E P)
(mapcar 'set '(E P)
EP)
(setq P (apply 'vlax-curve-getClosestPointTo EP))
(mapcar '+
P
(vlax-curve-getsecondderiv
E
(vlax-curve-getParamAtPoint E P)
)
)
)
;;164.26 [功能] 求多段线上的弧段(圆或圆弧也有效)的圆心
;;(HH:GetCenter2
(car(setq en(entsel))) (cadr en))
(defun HH:GetCenter2 (curve P / EP N PARAM
PP SP)
(setq pp (vlax-curve-getclosestpointto curve (trans p 1
0)))
(setq Param (vlax-curve-getParamAtPoint curve pp))
(setq n (fix Param))
(setq sp (vlax-curve-getPointAtParam curve
n))
(setq Ep (vlax-curve-getPointAtParam curve (1+ n)))
(if (minusp (car (trans (mapcar '- pp Ep) 0 (mapcar '- Ep
sp))))
(mapcar '+ pp (vlax-curve-getsecondderiv curve
Param))
(mapcar '- pp (vlax-curve-getsecondderiv curve
Param))
)
)
;;164.27 [功能] 判断多段线是否有圆弧(凸度/=0)的子段
;;(HH:checkarc1 (car
(entsel)))
(defun HH:checkarc1 (en / BU N OBJ PLIST)
(setq obj
(vlax-ename->vla-object en))
(setq plist (vlax-safearray->list
(vlax-variant-value (vla-get-coordinates obj))))
(setq n 0)
(repeat (/ (length plist) 2)
(if (/= (vla-getbulge
obj n) 0)
(setq bu T)
)
(setq n (+ n 1))
)
bu
)
;;164.28 [功能] 判断多段线是否有圆弧(凸度/=0)的子段
;;(HH:checkarc2 (car
(entsel)))
(defun HH:checkarc2 (en / G)
(setq G (vl-remove-if-not
'(lambda (x) (= (car x) 42)) (entget en)))
(not (vl-every 'zerop
(mapcar 'cdr G))) ;(vl-remove 0.0 (mapcar 'cdr
G))
)
;;164.29 [功能] 连接线、弧成多段线
;;(HH:JionToPolyline)
(defun HH:JionToPolyline
(/ PET SS)
(setq pet (getvar "PEDITACCEPT"))
(setvar
"PEDITACCEPT" 1)
(while (setq ss (ssget '((0 .
"ARC,*LINE"))))
(command "_.pedit" (ssname ss 0) "j" ss ""
"")
)
(setvar "PEDITACCEPT" pet)
(princ)
)
;;164.30 [功能] 构造矩形 by highflybird(见148.1)
(defun Make-Rectange (pt1
pt2)
(entmake
(list
'(0 .
"LWPOLYLINE")
;轻多段线
'(100 .
"AcDbEntity")
'(100 .
"AcDbPolyline")
'(90 .
4)
;四个顶点
'(70 .
1)
;闭合
(cons 38 (caddr
pt1))
;高程
(cons 10 (list (car pt1) (cadr
pt1))) ;左下角
(cons 10 (list (car pt2) (cadr pt1)))
;右下角
(cons 10 (list (car pt2) (cadr
pt2))) ;右上角
(cons 10 (list (car pt1) (cadr pt2)))
;左上角
(cons 210 '(0 0
1)) ;法线方向
)
)
)
;;164.31 [功能] 点表生成多段线(见148.1)
(defun Make-LWPOLYLINE (lst / PT)
(entmakeX (append (list '(0 . "LWPOLYLINE")
'(100 .
"AcDbEntity")
'(100 .
"AcDbPolyline")
(cons 90 (length
lst))
)
(mapcar '(lambda
(pt) (cons 10 pt)) lst)
)
)
)
;;164.32
[功能] 画3d多段线 by highflybird
;; draw a closed 3d Polyline
(defun Make3dPoly
(pts / e)
(setq e (Entmake (list '(0 . "POLYLINE")'(70 .
9))))
(foreach p Pts
(entmake (list '(0 .
"VERTEX") '(70 . 32) (cons 10 p)))
)
(entmake '((0 .
"SEQEND")))
(entlast)
)
;;164.33 [功能] 多段线反向 (By 自贡黄明儒
2015.2.9)
;;entget中，高版本和低版本显示内容不同了，zml84写的那个要重写
;;(_HH:PLReverse
(car(entsel)))
(defun _HH:PLReverse (e / EN L L1 LST X)
(setq en
(entget e))
(while (setq x (car
en)
en (cdr en)
)
(cond
((and (/= (car
x) 10) (or (not L) (not L1))) (setq Lst (cons x
Lst)))
((equal (car x) 10) (setq L1 (cons L
L1)) (setq L nil)(setq L (cons x L)))
(T (setq
L (cons x L)))
)
)
(setq L1 (cons L
L1))
(entmod(append (reverse lst) (apply 'append (mapcar 'reverse L1))
(list x)))
)
;;164.34 [功能] 多段线删除顶点
(defun HH:delLwpolyPt (/ EN ENT L1 L2 P P1 P2 P90 SS
X Y)
(setq p1 (getpoint))
(setq p2 (getcorner p1))
(if (setq ss (ssget "C" p1 p2 '((0 . "LWPOLYLINE"))))
(progn
(setq en (ssname ss
0))
(setq ENT (entget
EN))
(if (> (setq P90 (cdr (assoc 90 ent)))
2)
(progn
(setq p (mapcar '(lambda (X Y) (/ (+ X Y)
2.0)) p1 p2))
(setq p (vlax-curve-getclosestpointto en (trans p
1 0)))
(setq p1 (HH:PickClosePt en p))
(setq p1
(list 10 (car p1) (cadr p1)))
(setq L2 (cddddr (member p1
ent))) ;后段
(setq L1 (reverse (cdr
(member p1 (reverse ent))))) ;前段
(setq ent (append L1
L2))
(entmod (subst (cons 90 (1- P90)) (assoc 90 ent)
ent))
)
)
)
)
)
;;示例(HH:delLwpolyPt1 (car(setq en(entsel))) (cadr
en))
(defun HH:delLwpolyPt1 (en p / ENT L1 L2 P1)
(setq ENT (entget
en))
(setq p (vlax-curve-getclosestpointto en (trans p 1
0)))
(setq p1 (HH:PickClosePt en
p)) ;离p最近的顶点
(setq p1 (list 10
(car p1) (cadr p1)))
(setq L2 (cdr (member p1
ent))) ;后段
(setq L1 (reverse (cdr
(member p1 (reverse ent))))) ;前段
(entmod
(append L1 L2))
)
;;164.35 [功能] 多段线增加顶点
;;示例(HH:LwAddVertex (car(setq
en(entsel))) (cadr en))
(defun HH:LwAddVertex (en pt / EN GR N PP)
;;增加一个顶点
(defun LwAddVertex (obj index pt bugle sw
ew)
(vlax-invoke obj 'addvertex index
pt)
(vla-setbulge obj index bugle)
(vla-setwidth obj index sw ew)
)
(setq pp
(vlax-curve-getClosestPointTo en (trans pt 1 0)))
(setq n (fix
(vlax-curve-getParamAtPoint en pp)))
(setq obj
(vlax-ename->vla-object en))
(vla-GetWidth obj n 'sw 'ew)
(setq pp (getpoint "\n 新增点 "))
(setq pp (mapcar '+ '(0 0)
pp))
(vl-catch-all-apply 'LwAddVertex (list obj (1+ n) pp 0 sw
sw))
)
;;164.36 [功能] 多段线修改顶点
;;示例(HH:ModifyVertex (car(setq en(entsel))) (cadr
en) (getpoint))
(defun HH:ModifyVertex (en pt newPt / ENT L1 L2 NPT P
P10)
(setq p (HH:PickClosePt en pt))
(setq p10 (list 10 (car
p) (cadr p)))
(setq ent (entget en))
(setq L2 (cdr (member
p10 ent)))
(setq L1 (reverse (cdr (member p10 (reverse
ent)))))
(setq Npt (list (list 10 (car newPt) (cadr
newPt))))
(entmod (append L1 Npt L2))
)
;;(HH:ModifyVertex1
(car(setq en(entsel))) (cadr en))
(defun HH:ModifyVertex1 (en p / ENT GR
L1 L2 NPT P10)
(setq ent (entget en))
(setq pt
(HH:PickClosePt en p))
(setq p10 (list 10 (car pt) (cadr
pt)))
(setq L2 (cdr (member p10 ent)))
(setq L1 (reverse
(cdr (member p10 (reverse ent)))))
(while (and (setq gr (grread 5)) (=
(car gr) 5))
(setq Npt (list (list 10 (car (cadr gr))
(cadr (cadr gr)))))
(entmod (append L1 Npt L2))
)
)
;;164.37 [功能] 多段线拷贝子段
;;(HH:CopyLwSeg (car(setq en(entsel))) (cadr
en))
(defun HH:CopyLwSeg (en p / ENT L0 L1 L2 LASTENT N P1 PP TEM)
(setq pp (vlax-curve-getClosestPointTo en p))
(setq n (fix
(vlax-curve-getParamAtPoint en pp)))
(setq p1
(vlax-curve-getPointAtParam en n))
(setq p1 (list 10 (car p1) (cadr
p1)))
(setq ent (entget en))
(setq tem (member p1
ent))
(repeat 8 (setq L0 (cons (car tem) L0)) (setq tem (cdr
tem)))
(setq L0 (reverse L0))
(setq L2 (list (last
tem)))
(setq L1 (list
'(0 .
"LWPOLYLINE")
'(100 .
"AcDbEntity")
'(100 .
"AcDbPolyline")
'(90 .
2)
)
)
(entmake (append L1 l0
L2))
(setq Lastent (entlast))
(command "_.move" Lastent ""
pp pause)
)
;;164.38 [功能] 修改多段线子段
;;示例(HH:ModifySeg (car(setq en(entsel))) (cadr
en))
(defun HH:ModifySeg (en p / ENT GR I L1 L2 N P1 P2 P42 PP X Y)
;;133.1 [功能] 旋转一个点(见113)
;;Rotate 'pnt'点 from a base point of 'p1' and
through an angle of 'ang' (in radians)
(defun MJ:rotate_pnt (pnt p1
ang)
(polar p1 (+ (angle p1 pnt) ang) (distance p1
pnt))
)
;;两点之中点
(defun mid (p1 p2 / X
Y)
(mapcar '(lambda (X Y) (/ (+ X Y) 2.0)) p1
p2)
)
;;已知三点p1 p2 p，求组码42
(defun my42 (p1 p2 pt /
CEN D H P1P2 P1T P2P1 PT1 R)
(setq d (/ (distance p1 p2)
2.0))
(setq p1p2 (mid p1 p2))
(setq
p2p1 (MJ:rotate_pnt p1 p1p2 (/ pi 2)))
(setq pt1 (mid p1
pt))
(setq p1t (MJ:rotate_pnt p1 pt1 (/ pi
2)))
(setq cen (inters p1p2 p2p1 pt1 p1t
nil))
(setq h (car (trans (mapcar '- cen p1) 0 (mapcar '-
p1 p2))))
(setq r (distance cen p1))
(if (MINUSP h)
(setq r (+ r
h))
(setq r (- h r))
)
(/ r d)
)
(setq pp (vlax-curve-getClosestPointTo en p))
(setq n (fix
(vlax-curve-getParamAtPoint en pp)))
(setq p1
(vlax-curve-getPointAtParam en n))
(setq p2
(vlax-curve-getPointAtParam en (1+ n)))
(setq ent (entget
en))
(setq i 0)
(while (or (/= (caar ent)
42)
(if (< i
n)
(setq i (1+
i))
)
)
(setq
L1 (cons (car ent) L1)
ent (cdr ent)
)
)
(setq L1 (REVERSE L1))
(setq L2 (cdr
ent))
(while (and (setq gr (grread 5)) (= (car gr)
5))
(setq p42 (cons 42 (my42 p1 p2 (cadr
gr))))
(entmod (append L1 (list p42) L2))
)
(princ)
)
;;164.39 [功能] 修改多段线子段为直线
;;(HH:ModifySegLine (car(setq en(entsel))) (cadr
en))
(defun HH:ModifySegLine (en p / ENT I L1 L2 N P1 P2 PP)
(setq pp (vlax-curve-getClosestPointTo en p))
(setq n (fix
(vlax-curve-getParamAtPoint en pp)))
(setq p1
(vlax-curve-getPointAtParam en n))
(setq p2
(vlax-curve-getPointAtParam en (1+ n)))
(setq ent (entget
en))
(setq i 0)
(while (or (/= (caar ent)
42)
(if (< i
n)
(setq i (1+
i))
)
)
(setq
L1 (cons (car ent) L1)
ent (cdr ent)
)
)
(setq L1 (REVERSE L1))
(setq L2 (cdr
ent))
(entmod (append L1 (list (cons 42 0)) L2))
(princ)
)
;;164.40 [功能] 点在封闭多段线内返回T，其余nil By
狂刀(见175)
;;本程序为狂刀思想，并非源程序
;;(PtInorOut1 ((HH:PtLists (car(entsel)))
(getpoint))
(defun PtInorOut1 (pts pt / P1 P2)
(setq pts
(MAPCAR '(LAMBDA (p1 p2) (REM (- (ANGLE pt p1) (ANGLE pt p2))
PI))
(CONS (LAST pts)
pts)
pts
)
)
(equal (ABS (APPLY '+ pts)) PI)
)
;;164.41 [功能] 点在封闭多段线内返回T，其余nil By SmcTools
;;(PtInorOut2
(car(entsel))(getpoint))
(defun PtInorOut2 (en pt / I N PT_LIST VA
VA_COUNT)
(setq pt_list (HH:PtLists en))
(setq i
0
va_count 0
n (length pt_list)
pt_list
(append pt_list (list (car pt_list)))
)
(repeat
n
(setq va (- (angle pt (nth i
pt_list))
(angle pt (nth (1+ i)
pt_list))
)
)
(cond ((> va pi) (setq va (- va pi)))
((< va (* -1 pi)) (setq va (+ va pi)))
)
(setq va_count (+ va_count va)
i (1+ i)
)
)
(equal
(abs va_count) pi)
)
;;164.42 [功能] 判断点在封闭曲线内外，自交曲线不适用 By Gu_xl 2012.07.31
;;返回:
点在封闭曲线上或曲线内，返回T，否则返回nil
;;测试: (gxl-PtInCurveP (car(entsel "\n选择曲线:"))
(getpoint))
(defun HH:PtInCurveP (POLY PT / CLOCKWISEP CP CURVELENGTH D1 D2
DEV DIST ENDPARAM PARAM)
(setq cp (vlax-curve-getclosestpointto
poly pt))
(cond
((equal pt cp 1e-8) T) ;_ 点在曲线上
T
((not (apply 'ALG:InCorner-p (cons pt (Entity:Box
POLY)))) NIL) ;_ 点在曲线最小包围盒外 nil
(t
(setq ClockwiseP (Curve:Direction
POLY))
(setq endparam (vlax-curve-getendparam
poly))
(setq curvelength (vlax-curve-getDistAtParam
poly endparam)) ;_ 曲线长度
(setq param
(vlax-curve-getparamatpoint poly cp))
(setq dist
(vlax-curve-getDistAtParam poly param))
(cond
((equal param (fix param)
1e-8)
(cond ((minusp (setq d1 (- dist 1e-8))) (setq d1 (+ curvelength
d1))))
(cond ((> (setq d2 (+ dist 1e-8)) curvelength) (setq d2 (- d2
curvelength))))
(setq d1 (vlax-curve-getpointatdist poly
d1))
(setq d2 (vlax-curve-getpointatdist poly d2))
(cond
((< (distance pt d1) (distance pt d2)) (setq param
d1))
(T (setq param
d2))
)
)
)
(setq dev
(vlax-curve-getFirstDeriv poly param)
cp
(vlax-curve-getpointatparam poly param)
)
(= ClockwiseP (minusp (det pt cp (mapcar '+ cp
dev))))
)
)
)
;;164.43 [功能] 判断点是否在曲线内
;;判断点在封闭图形内 自贡黄明儒 2014.11.22
;;(HH_PtInCurve
(getpoint) (ssget))=>2角点((-2405.26 2394.67 -1.0e-008) (-2313.72 2482.31
1.0e-008))
;;(HH_PtInCurve (getpoint) (car(entsel)))
(defun HH_PtInCurve
(p ss / E EN PTS)
(cond ((equal (type ss) 'ENAME) (setq ss (ssadd ss
(ssadd)))))
(setvar "nomutt" 1)
(setq e (entlast))
(APPLY 'bpoly (list p ss '(1 0)))
(while (not (equal (getvar
"cmdnames") "")) (apply 'command (list "")))
(setvar "nomutt"
0)
(cond ((not(equal(setq en (entlast)) e)) (setq pts (Entity:Box en))
(entdel en) pts))
)
;;164.43 [功能] 判断点是否在曲线内(射线法)
;;线内T
线上0 线外nil
;;(InCurve (setq pt (getpoint)) (setq e (car (entsel))))
(DEFUN
InCurve (pt e / _EntmakeXlineX FLAG i TMPRAY)
(defun
_EntmakeXlineX (pt)
(entmakeX (list '(0 .
"XLINE")
'(100 .
"AcDbEntity")
'(100 .
"AcDbXline")
(cons 10
pt)
(cons 11 '(1 0
0))
)
)
)
(IF (EQUAL pt (VLAX-CURVE-GETCLOSESTPOINTTO e pt)
1E-6)
0 ;在线上
(PROGN
(SETQ e (VLAX-ENAME->VLA-OBJECT
e))
(SETQ TmpRay (VLAX-ENAME->VLA-OBJECT
(_EntmakeXlineX pt)))
(SETQ pt (VLAX-3D-POINT
pt))
(SETQ i
0)
(setq Flag T)
(while (and (/= 180 i)
Flag)
;;如果Flag 为nil或者长度为3，则结束;
(if (and (setq Flag
(VLAX-INVOKE e 'INTERSECTWITH TmpRay ACEXTENDNONE))
(/= (LENGTH
Flag) 3)
)
(progn (setq i (+ i 15))
(VLA-ROTATE TmpRay pt (/ PI 15)));采用12度
(setq Flag
nil)
)
)
(VLA-DELETE
TmpRay)
(if Flag T)
)
)
)
;;164.44 [功能] 多段线弧段全改为直线段
;;(HH:ModifySegLine1 (car(setq
en(entsel))))
(defun HH:ModifySegLine1 (en / X)
(entmod
(mapcar '(lambda
(x)
(if (equal (car x)
42)
(cons 42 0)
x
)
)
(entget
en)
)
)
)
;;164.45 [功能] 沿多段线取点，弧处按角度加密取点(见157)
;;示例(LP:getpts (car
(entsel)))
(defun LP:getpts (E / EN I II J L42 N PT PTLST X)
(defun
get42 (en)
(mapcar 'cdr
(vl-remove-if-not '(lambda (x) (= (car x) 42)) en)
)
)
(setq en (enget e))
(setq l42 (get42
en))
(setq j 0)
(repeat (length l42)
(setq x (car l42))
(setq l42 (cdr
l42))
(cond
((and (/= x
0)
(setq i (fix (/ (* (atan (abs x)) 180)
pi))) ;弧取点密度
(> i
0)
)
(setq ii (/ 1.0
i))
(repeat i
(setq pt
(vlax-curve-getPointAtParam e j))
(setq ptlst (cons pt
ptlst))
(setq j (+ ii j))
)
(setq j (fix (+ 0.5
j)))
)
(T
(setq pt (vlax-curve-getPointAtParam
e j))
(setq ptlst (cons pt
ptlst))
(setq j (1+
j))
)
)
)
ptlst
)
;;164.46 [功能] 多段线自相交 by st788796
(defun rrr (e / getlst ep obj pts ptl
pams il)
(defun Getlst (n / i il)
(setq i
(fix n))
(repeat i (setq il (cons (setq n (1- n))
il)))
il
)
(setq obj
(vlax-ename->vla-object e)
ep (vlax-curve-getendparam
e)
)
(if (setq pts (vlax-invoke obj 'IntersectWith obj
0))
(progn
(while
pts
(setq ptl (cons (list (car pts) (cadr pts) (caddr pts))
ptl)
pts (cdddr
pts)
)
)
(setq il (cdr (getlst
ep))
pams (mapcar '(lambda
(x)
(vlax-curve-getparamatpoint e
x)
)
ptl
)
)
(if
(vlax-curve-isclosed e)
(not (equal (reverse
pams)
(cons 1. (cons 0. (cdr
il)))
)
)
(not (equal
(vl-remove '0. (reverse pams)) il)) ;_假闭合情况
)
)
)
)
;;164.47.1 [功能] pt到直线(弧)的垂点是否在直线(弧)上 自贡黄明儒
;;(HH:PtInL (getpoint) (car
(entsel)))
(defun HH:PtIn (pt Line)
(equal
(vlax-curve-getClosestPointTo Line Pt t)
(vlax-curve-getClosestPointTo
Line Pt)
1e-5
)
)
;;164.47.2 [功能]
pt投影到p1p2上的点是否在p1p2之间 自贡黄明儒
;;(PtIn2 (getpoint) (getpoint)
(getpoint))
(defun PtIn2 (p p1 p2)
(<
0
(caddr (trans (mapcar '- p p1) 0 (mapcar '- p2
p1)))
(distance p1 p2)
)
)
;;164.47.3 [功能] pt到曲线的垂点不在延长线上，返回T
;;(HH:perPtIn (getpoint)
(car(entsel)))
(defun HH:perPtIn (p curve / P1 P2 PA)
(setq p1
(vlax-curve-getClosestPointTo curve p))
(setq pa
(vlax-curve-getParamAtPoint curve P1)) ;参数
(setq p2 (mapcar '+ (vlax-curve-getFirstDeriv curve pa) p1))
;切线上一点
(equal (caddr (trans (mapcar '- p p1) 0 (mapcar '- p2 p1))) 0
1e-5)
)
;;164.47.4 [功能] pt投影到p1p2上的点是否在p1p2之间 自贡黄明儒
;;(perIn2p
(getpoint) (getpoint)(getpoint))
(defun perIn2p (P p1 p2 / pt)
(setq pt (mapcar '+ (MAT:Rot90 (mapcar '- p1 p2)) p));highflybir论矩阵
(setq pt (inters p1 p2 p pt nil));垂点
(equal (+ (distance p1 pt)
(distance p2 pt)) (distance p1 p2) 1e-8)
)
;;164.48 [功能] 多线上的弧段的圆心列表
;;(HH:GetCenter3 (car(setq
en(entsel))))
(defun HH:GetCenter3 (curve / CENLIST EP FLAG MDERIV MP PARAM
SP)
;;(setq curve (car (entsel)))
(setq param (fix
(vlax-curve-getEndParam curve)))
(setq sp (vlax-curve-getPointAtParam
curve param))
(repeat param
(setq param (1-
param))
(setq Ep (vlax-curve-getPointAtParam curve
param))
(setq Mp (vlax-curve-getPointAtParam curve (+
param 0.5))) ;中点
(setq Mderiv (vlax-curve-getsecondderiv
curve (+ param 0.5))) ;中点法线
(setq Flag (car (trans (mapcar
'- Mp Ep) 0 (mapcar '- Ep sp))))
(cond ((equal Flag 0)
nil)
((minusp Flag)
(setq CenList (cons
(mapcar '- Mp Mderiv) CenList))
)
(T
(setq CenList (cons (mapcar '+ Mp Mderiv)
CenList))
)
)
(setq
sp Ep)
)
CenList
)
;;164.49 [功能]
弧圆心或者半径
;;示例(HH:getArcCen (car(entsel)))
(defun HH:getArcCen (e / CEN OBJ
R)
(setq obj (vlax-ename->vla-object e))
(setq R
(vlax-get obj 'Radius))
(setq Cen (vlax-get obj 'Center))
(list R Cen)
)
;;164.50 [功能] 弧与直线在X轴(Y轴)方向的最短距离
;;Flag T时，X轴方向最短距离
;;(HH:LineArcShort
(car(entsel))(car(entsel)) T)=>(6.9505 (-1400.95 2003.86) (-1394.0
2003.86))
;;=>(距离 弧上点 直线上点) 或 nil(nil说明这种方法求得的不是最短距离)
(defun
HH:LineArcShort (eA eL Flag / CEN E P1 P2 PT PTS SCOR)
(setq Cen (cadr
(HH:getArcCen eA)))
(setq pt (vlax-curve-getClosestPointTo EL Cen
T))
(setq e (EntmakeLine Cen
pt)) ;圆心到直线的垂线
(setq pts
(HH:TwoEntsInters eA e 0))
(entdel e)
(cond
(pts
(setq p1 (car
pts))
;弧与垂线交点
(setq e (EntmakeXline p1
Flag)) ;作一射线
(setq pts (HH:TwoEntsInters EL e 0))
;射线与原直线交点
(entdel e)
(cond
(pts
(setq p2 (car
pts))
(setq Scor (list (distance p1 p2) p1
p2))
)
)
)
)
Scor
)
;;164.51 [功能]
弧与弧在X轴(Y轴)方向的最短距离
;;Flag T时，X轴方向最短距离
;;(移动距离 第二对象移动基点
移动到)或者nil(nil表示此最小移动距离为端点)
;;(HH:TwoArcShort (car(entsel)) (car(entsel))
T)=>(12.3644 (-1334.55 2032.55 0.0) (-1346.91 2032.55))
(defun
HH:TwoArcShort (eA1 eA2 Flag / CEN1 CEN2 ECIRCLE ELINE OBJ P2 PTS R1 R2
SCOR)
(setq Cen1 (HH:getArcCen eA1))
(setq R1 (car
Cen1))
(setq Cen1 (cadr Cen1))
(setq Cen2 (HH:getArcCen
eA2))
(setq R2 (car Cen2))
(setq Cen2 (cadr Cen2))
(setq eCircle (EntmakeCircle Cen2 (+ R1 R2)))
;以第圆中心画一圆
(if Flag
(setq p2 (list (car Cen2)
(cadr Cen1)))
(setq p2 (list (cadr Cen2) (car
Cen1)))
)
(setq eLine (EntmakeLine Cen1
p2)) ;圆1到圆2中心处，产生一直线
(setq pts
(car (HH:TwoEntsInters eCircle eLine 0)))
;新产生圆与新产生直线交点
(entdel eCircle)
(entdel eLine)
(if
pts
(progn
(setq pts
(mapcar '- pts Cen1))
(setq p2 (mapcar '- Cen2
pts))
;圆2新中心点
(setq eLine (EntmakeLine Cen1
p2))
(setq pts (HH:TwoEntsInters eA1 eLine
0))
(cond
(pts
(setq obj
(vla-copy (vlax-ename->vla-object eA2)))
(vla-move obj
(vlax-3d-point Cen2) (vlax-3d-point p2))
(setq pts (HH:TwoEntsInters
eLine (entlast) 0))
(entdel eLine)
(entdel
(entlast))
(cond
(pts
(setq Scor (list (distance p2 Cen2) Cen2
p2))
)
)
)
(T (entdel
eLine))
)
)
)
Scor
)
;;164.52 [功能] 两多段线之间最小距离 自贡黄明儒2014.4.6
(defun C:HH:TwoLWPShort (/
CPT1 CPT2 E1 E2 LST P PTS1 PTS2 SS)
(if (and
(setq ss (ssget
":S" '((0 . "LWPOLYLINE"))))
(equal (sslength ss)
2)
)
(progn
(setq e1 (ssname ss
0))
(setq e2 (ssname ss
1))
(setq pts1 (HH:PtLists
e1))
;http://bbs.xdcad.net/thread-671377-1-1.html
(setq pts2 (HH:PtLists e2))
(setq Cpt1
(HH:GetCenter3 e1))
(setq Cpt2 (HH:GetCenter3
e2))
(foreach X pts1
(setq p
(vlax-curve-getClosestPointTo e2 x))
(setq lst (cons (list (distance x
p) x p) lst))
)
(foreach X pts2
(setq p
(vlax-curve-getClosestPointTo e1 x))
(setq lst (cons (list (distance x
p) p x) lst))
)
(if Cpt1
(foreach X
Cpt1
(setq p (vlax-curve-getClosestPointTo e2
x))
(setq x (vlax-curve-getClosestPointTo e1 p))
(setq lst (cons (list (distance x p) x p)
lst))
)
)
(if Cpt2
(foreach X
Cpt2
(setq p (vlax-curve-getClosestPointTo e1
x))
(setq x (vlax-curve-getClosestPointTo e2 p))
(setq lst (cons (list (distance x p) p x)
lst))
)
)
(setq lst (car (HH:ssPts:Sort lst "x"
0.001)))
(grdraw (cadr lst) (caddr lst)
1)
)
)
lst
)
;;164.53 [功能]
两多段线X(Y)轴方向最小距离 自贡黄明儒2014.4.6
;;ss两条多段线选择集 Flag T时X方向，nil时Y方向
(defun
HH:XLWPShort (ss Flag / CMD1 E1 E11 E2 E21 I J LST S1 S2 SCOR SHORTC TYPE1
TYPE2)
;;错误处理
(defun *error* (msg)
(vl-bt)
(if *DOC*
(_EndUndo *DOC*)
;块内图元增减
)
(while (not (equal (getvar
"cmdnames") "")) (command nil))
(if cmd1
(setvar "cmdecho"
cmd1)
)
(if SHORTC
(setvar "SHORTCUTMENU"
SHORTC)
)
(if s1 (vl-cmdf "_.erase"
s1 ""))
(if s2 (vl-cmdf "_.erase" s2
""))
(setvar "nomutt" 0)
(princ "\n
出错啦!")
(princ)
)
(setq e1 (ssname ss
0))
(setq e2 (ssname ss 1))
(vla-copy
(vlax-ename->vla-object e1))
(vl-cmdf "_.explode"
(entlast))
(setq s1 (ssget "_p"))
(vla-copy
(vlax-ename->vla-object e2))
(vl-cmdf "_.explode"
(entlast))
(setq s2 (ssget "_p"))
(repeat (setq i (sslength
s1))
(setq e11 (ssname s1 (setq i (1-
i))))
(setq type1 (cdr (assoc 0 (entget
e11))))
(repeat (setq j (sslength
s2))
(setq e21 (ssname s2 (setq j (1-
j))))
(setq type2 (cdr (assoc 0 (entget
e21))))
(cond
((and (equal type1
"LINE") (equal type2 "ARC"))
(if (setq scor (HH:LineArcShort e21 e11
Flag))
(setq lst (cons scor lst))
)
)
((and (equal type2 "LINE") (equal type1
"ARC"))
(if (setq scor (HH:LineArcShort e11 e21
Flag))
(setq lst (cons scor lst))
)
)
((and (equal type2 "ARC") (equal type1 "ARC"))
(if (setq scor (HH:TwoArcShort e11 e21 Flag))
(setq
lst (cons scor lst))
)
)
)
)
)
(vl-cmdf "_.erase" s1 s2 "")
(foreach x
(HH:PtLists e1)
(if (setq scor (HH:XYCurvePt e2 x
Flag))
(setq lst (append lst
scor))
)
)
(foreach x (HH:PtLists
e2)
(if (setq scor (HH:XYCurvePt e1 x
Flag))
(setq lst (append lst
scor))
)
)
(if (setq lst (car
(HH:ssPts:Sort lst "x" 0.001)))
(grdraw (cadr lst) (caddr
lst) 1)
)
lst
)
;;164.54 [功能]
过一点射线与曲线的交点
;;示例(HH:XYCurvePt (car(entsel)) (getpoint)
"X"),返回过一点X轴上的点
(defun HH:XYCurvePt (e1 pt Flag / E2 LST PTS)
(setq
e2 (EntmakeXline pt Flag))
(setq pts (HH:TwoEntsInters e1 e2
0))
(entdel e2)
(foreach x pts
(setq
lst (cons (list (distance x pt) x pt) lst))
)
lst
)
;;164.55 [功能] 多段线是否真闭合
;;非输入C闭合的为假闭合，返回T是非输入C闭合的
(defun
IsTrueClosePL (e)
(and
;;(equal (vlax-get
(vlax-ename->vla-object e) 'closed) 0)
(not
(vlax-curve-isClosed e))
;这个可以任何曲线
(equal (vlax-curve-getstartpoint e)
(vlax-curve-getendpoint e) 1e-3)
)
)
;;164.56 [功能]
使多段线真闭合
;;(MakeTrueClosePL (car(entsel)))对于非输入C闭合的
(defun MakeTrueClosePL
(e / EN L L1 LST X)
(setq en (entget e))
(while (setq
x (car en)
en (cdr
en)
)
(cond
((and (/= (car x) 10) (or (not L) (not L1))) (setq Lst (cons x
Lst)))
((equal (car x) 10) (setq L1 (cons L
L1)) (setq L nil) (setq L (cons x L)))
(T
(setq L (cons x L)))
)
)
(setq lst
(reverse lst))
(setq lst (subst '(70 . 1) (assoc 70 lst)
lst))
(setq lst (subst (cons 90 (1- (cdr (assoc 90 lst)))) (assoc 90
lst) lst))
(setq L1 (apply 'append (reverse (mapcar 'reverse
L1))))
(entmod (append lst L1 (list x)))
)
;;164.57 [功能] 多段线可倒角端点
;;示例(HH:PL42 (car (entsel)))=>(nil T nil
nil)
;;但此点与前后不形成三角形不能倒角，可以先去除重点
(defun HH:PL42 (e / EN X)
(cond
((IsTrueClosePL e) (setq e (MakeTrueClosePL e))))
;如果假闭合，变成真闭合
(cond ((vlax-curve-isClosed
e) ;真闭合
(setq en (vl-remove-if-not
'(lambda (x) (= (car x) 42)) (entget e)))
(setq en (mapcar '(lambda
(x) (cond ((equal (cdr x) 0.0 1e-3) T))) en))
(mapcar 'and en (cons
(last en) en))
)
(T
(setq en (vl-remove-if-not
'(lambda (x) (= (car x) 42)) (entget e)))
(setq en (mapcar '(lambda
(x) (cond ((equal (cdr x) 0.0 1e-3) T))) en))
(setq en (mapcar 'and en
(cdr en)))
(append (cons nil (reverse (cdr (reverse en))))
'(nil))
)
)
)
;;164.58 [功能] 多段线接着画
(defun C:ContinuePL (/ E LST)
(cond
((setq e (ssget "_+.:E:S" '((0 .
"LWPOLYLINE"))))
;;如果击点在起点，则多段线要反向，本程序略
(setq e (ssname e
0))
(setq lst (PL->List
e))
(entdel e)
(apply
'command (cons "_.pline" lst))
;;(while (equal
(getvar "cmdnames") "PLINE") (command pause))
)
)
(princ)
)
;;PL化为表
;;(PL->List (ssname (ssget "_+.:E:S"
'((0 . "LWPOLYLINE"))) 0))
(defun PL->List (e / CARX FLAG I LST MIDPT
P PAR)
(setq i -1)
(setq par (vlax-curve-getEndParam
e))
(foreach x (entget e)
(setq carX (car
x))
(cond
((equal carX
10)
(setq i (1+
i))
(setq p (trans (cdr x) 0
1))
(setq lst (append lst (list "non"
p)))
(cond ((not (equal i par)) (setq
lst (append lst (list "_Width")))))
)
((and (or (equal carX 40) (equal carX 41))
(not (equal i par)))
(setq lst (append
lst (list (cdr x))))
)
((and (equal carX 42) (not (equal i
par)))
(cond
((and (/= (cdr x)
0))
(setq Flag T)
(setq midPt
(vlax-curve-getPointAtParam e (+ i 0.5)))
(setq midPt (trans
midPt 0 1))
(setq lst (append lst (list "_Arc" "_Second" "non"
midPt)))
)
(T
(IF
Flag
(PROGN (setq lst (append lst (list "_Line")))
(setq Flag nil))
)
)
)
)
)
)
lst
)
;;165 [功能] 取出图元索引i对应的值 By 顾晓林
;;(gxl-dxf (car(entsel)) 10) (gxl-dxf
(entget(car(entsel))) 10)
;;(gxl-dxf (car(entsel)) (list 0 10))
(defun
gxl-dxf (ent i)
(cond ((= (type ent) 'ename) (setq ent (entget ent
'("*")))))
(cond ((atom i) (cdr (assoc i
ent)))
((MJ:ConsP i) (mapcar '(lambda (x) (cdr (assoc x ent)))
i))
)
)
;;166 [功能] 预测字符长度 by st788796
(defun XD::String:Len (sty str h
scl)
(and (or (not sty)
(= sty
"")
(not (tblsearch "style"
sty))
)
(setq sty (getvar
"textstyle"))
)
(abs
(car
(apply
'mapcar
(cons '-
(textbox (list (cons 1 str) (cons 7 sty) (cons 40 h) (cons 41
scl))
)
)
)
)
)
;;167 [功能] 两对象交点列表(也可能是虚交点)
;;Flag:
;;acextendnone 0
不延伸
;;acextendthisentity 1 延伸基准对象
;;acextendotherentity
2
;;acextendboth 3
;;示例(HH:TwoEntsInters (car(entsel)) (car(entsel))
0)
(defun HH:TwoEntsInters (e1 e2 Flag / OBJ1 OBJ2 PTL PTS)
(setq obj1 (vla-copy (vlax-ename->vla-object e1)))
(setq obj2
(vla-copy (vlax-ename->vla-object e2)))
(XX:LeftPick:LineZto0Ent
(vlax-vla-object->ename obj1))
(XX:LeftPick:LineZto0Ent
(vlax-vla-object->ename obj2))
(setq pts (vlax-invoke obj1
'Intersectwith obj2 Flag))
(VL-CATCH-ALL-APPLY 'vla-Delete (list
obj1))
(VL-CATCH-ALL-APPLY 'vla-Delete (list obj2))
(while
pts
(setq ptl (cons (list (car pts) (cadr pts))
ptl))
(setq pts (cdddr pts))
)
ptl
)
;;168 [功能] 限定角度在0~C*pi之间(弧度)
;;C=1,pi; c=0.5,pi/2; c=2,2pi
(defun
HH::ANGLEFORMAT (A C)
(setq B (* pi C))
(while (< A
0)
(SETQ A (+ A B))
)
(while (>= A
B)
(SETQ A (- A B))
)
(cond ((EQUAL A
B 1.0e-008) (SETQ A 0.0)))
A
)
;;169 [功能] 像素单位(见117.1)
(defun pixel_unit (/ x y x1 y1)
(setq y (getvar "viewsize")
x1 (car (getvar
"screensize"))
y1 (cadr (getvar "screensize"))
x (* y (/
x1 y1))
)
(max (abs (/ y
y1))
(abs (/ x x1))
)
)
;;170 [功能] Z坐标归0------------------组码
;;(XX:LeftPick:LineZto0Ent
(car(entsel)))
(defun XX:LeftPick:LineZto0Ent (ss / E EN N NA NALIST NAME
X)
(defun MoveOne (e / X)
(entmod
(mapcar
'(lambda
(X)
(cond
((member (car
x) '(10 11 12 13 14)) (list (car x) (cadr x) (caddr
x)))
(T x)
)
)
(entget e)
)
)
)
(defun MovePL (e)
(vlax-put
(vlax-ename->vla-object e) 'Elevation 0)
)
;;块归
(defun MoveBlock (e / E1 NAME)
(MoveOne
e)
(setq e1 e)
(while
(and (setq e1 (entnext e1))
(setq Name (cdr (assoc 0 (entget
e1))))
(not (equal Name "SEQEND"))
)
(spin*
"请稍侯,块正在归零...")
(cond ((equal Name
"LWPOLYLINE") (MovePL e1))
((equal Name "INSERT")
(MoveBlock e1))
(T (MoveOne
e1))
)
)
(entupd e)
)
;;主
(cond
((equal (type ss)
'ENAME)
(setq Name (cdr (assoc 0 (entget
ss))))
(cond ((equal Name "LWPOLYLINE") (MovePL
ss))
((equal Name "INSERT") (MoveBlock
ss))
(T (MoveOne ss))
)
)
((equal (type ss)
'PICKSET)
(repeat (setq n (sslength
ss))
(setq e (ssname ss (setq n (1-
n))))
(setq en (entget
e))
(setq Name (cdr (assoc 0
en)))
(spin* (strcat "请稍侯," Name
"块正在归零..."))
(cond ((equal Name
"LWPOLYLINE") (MovePL e))
((equal Name
"INSERT")
(setq Na (cdr (assoc 0
en)))
(cond ((not (member Na NaList))
(setq NaList (cons Na NaList)) (MoveBlock e)))
)
(T (MoveOne
e))
)
)
)
)
(princ)
)
;;171 [功能] 两对象交点在对象上的点列表
;;Flag1
为T时，返回在e1上的点;否则在e2上的点
;;(HH:TwoEntsInters1 (car(entsel)) (car(entsel)) 0
T)
(defun HH:TwoEntsInters1 (e1 e2 Flag Flag1 / OBJ1 OBJ2 PTL PTS)
(setq obj1 (vla-copy (vlax-ename->vla-object e1)))
(setq obj2
(vla-copy (vlax-ename->vla-object e2)))
(XX:LeftPick:LineZto0Ent
(vlax-vla-object->ename obj1))
(XX:LeftPick:LineZto0Ent
(vlax-vla-object->ename obj2))
(setq pts (vlax-invoke obj1
'Intersectwith obj2 Flag))
(VL-CATCH-ALL-APPLY 'vla-Delete (list
obj1))
(VL-CATCH-ALL-APPLY 'vla-Delete (list obj2))
(while
pts
(setq ptl (cons (list (car pts) (cadr pts))
ptl))
(setq pts (cdddr pts))
)
(cond (Flag1 (setq e e1))
(T (setq e e2))
)
(mapcar '(lambda (x) (vlax-curve-getClosestPointToProjection e x '(0 0 1)
T))
ptl
)
)
;;172 [功能] 创建带文字的线型 By edata
(defun c:makelt (/ str file fn
exprt)
(setq str (getstring T "\n Enter string for
linetype: ")
file (strcat (getvar 'dwgprefix) (vl-filename-base
(getvar 'dwgname)) "_mylt.lin")
fn (open file
"w")
exprt (getvar 'expert)
)
(write-line (strcat
"*" str ", ---" str "---") fn)
(write-line (strcat
"A,0.5,-0.05,[\""
str
"\",STANDARD,S=0.1,R=0.0,X=-0.0,Y=-.05],"
(rtos (* -0.1 (strlen str)) 2 3)
)
fn
)
(close
fn)
(setvar 'expert 5)
(command ".-linetype" "load" "*" file
"")
(setvar 'expert exprt)
(vl-file-delete file)
(princ)
)
;;173 [功能] 表->字符串
;;(lst->str (getpoint)
",")=>"-2112.02,2562.58,0.0"
;;(lst->str (list 2 "3" 4)
",")=>"2,3,4"
(defun lst->str (lst del / A)
(if (cdr
lst)
(strcat (VL-PRINC-TO-STRING (car lst)) del
(lst->str (cdr lst) del))
(VL-PRINC-TO-STRING (car
lst))
)
)
;;173.1 [功能] 表->字符串 by dnbcgrass
(defun
lst->str1 (lst del)
(vl-string-right-trim
del
(apply 'strcat (mapcar '(lambda (x) (strcat
(vl-princ-to-string x) del)) lst))
)
)
;;174.1 [功能] 点积(内积):p1p2 p1p3是否垂直，垂直为0;锐角为正，钝角为负 By
Highflybird
;;定义向量的点积函数(向量A投影在向量B上的长度，但是它还要乘上B的长度)
(defun dot (p1 p2 p3 /
x1 y1)
(setq x1 (car p1)
y1 (cadr p1)
)
(+ (* (- (car p2) x1) (- (car p3) x1)) (* (- (cadr p2) y1) (- (cadr
p3) y1)))
)
;;174.2 [功能] 叉积(外积) By Highflybird
;;1 三角形之倍面积
;;2 p1 p2
p3 逆时针为正。
;;3 三点共线为0
(defun det (p1 p2 p3 / x2 y2)
(setq x2
(car p2)
y2 (cadr p2)
)
(- (* (- x2 (car p3)) (- y2
(cadr p1))) (* (- x2 (car p1)) (- y2 (cadr p3))))
)
;;175 [功能] 判断点是否在窗口内 by highflybir(见164.40)
(defun ALG:InCorner-p
(pt pMin pMax)
(and
(<= (car pMin) (car pt)
(car pMax))
(<= (cadr pMin) (cadr pt) (cadr
pMax))
)
)
;;176 [功能] 两角点变四点(左下 右下 右上 左上)
(defun _pnts:box (box)
(list (car box)
(list (caar box) (cadadr box) (last (car
box)))
(cadr box)
(list (caadr box) (cadar box) (last
(car box)))
)
)
;;177.1 [功能] 小于n的质数
;;(SPrime 100)=>(2 3 5 7 11 13 17 19 23 29 31 37 41
43 47 53 59 61 67 71 73 79 83 89 97)
(defun Sprime (n / I K L LST
ROOT)
(setq i 1)
(setq root (sqrt n))
(while
(<= (setq i (+ i 2)) n) (setq l (cons i l)))
(setq l (reverse
l))
(while (and (setq k (car l)) (<= k root))
(setq l (vl-remove-if '(lambda (x) (= (rem x k) 0)) (cdr
l)))
(setq lst (cons k lst))
)
(append
'(2) (reverse lst) l)
)
;;177.2 [功能] n1 n2之间的质数
;;(Sprime2 200
2000)
(defun Sprime2 (n1 n2)
(vl-remove-if '(lambda (x) (< x
n1)) (Sprime n2))
)
;;178 [功能] 求凸壳的直径的程序 by highflybird(旋转卡壳)(见13)
;;参数：逆时针的凸壳
H-------注意逆时针!!!
;;返回值: 直径的两个端点和直径 Pair . MaxD
;;(Max-distance (getpt
(ssget) 10))=>(((-2670.87 3701.22 0.0) (-1725.61 3689.13 0.0)) .
945.338)
(defun Max-distance (H / D M MAXD P PAIR Q U V W)
(setq Q
(cdr (append H H (list (car H)))))
;构造一个首尾循环的凸集,且起始点为凸壳的第二点
(setq MaxD
0.0) ;初始化最小距离为0
(foreach U H
;依次检查凸壳的边
(setq V (car
Q))
;循环集的第一点
(setq W (cadr
Q))
;循环集的第二点
(setq M (MJ:Mid V
W)) ;这两点的中点
(while (> (dot M U V) 0.0)
;如果夹角小于90度（即点积大于0）
(setq Q (cdr
Q))
;循环集推进
(setq V (car
Q))
;取下一点
(setq W (cadr
Q))
;下下一点
(setq M (MJ:Mid V
W)) ;这两点的中点
)
(setq D (distance U
V)) ;计算这时的最大距离
(if (> D MaxD)
;如果大于前面的最大距离
(setq MaxD
D
;就替换前面的最大距离
Pair (list U
V)
;并记录这对点
)
)
)
(cons Pair MaxD)
;返回这对点和最大距离
)
;;179 [功能] Graham扫描法求凸包 by highflybird
;;(mapcar '(lambda(x) (command
"line" x '(0 0) "")) (Graham-scan (getpt (ssget)
10)))
;;扫描后的结果是从最右边的一个点开始的,逆时针
(defun Graham-scan (ptlist / hullpt maxXpt
sortPt P Q)
(if (< (length ptlist)
3) ;3点以下
ptlist
;是本集合
(progn
(setq
maxXpt (assoc (apply 'max (mapcar 'car ptlist)) ptlist))
;最右边的点(1个点)
(setq sortPt
(sort-by-angle-distance ptlist maxXpt))
;分类点集
(setq hullPt (list (cadr sortPt)
maxXpt)) ;开始的两点
(foreach n (cddr sortPt)
;从第3点开始
(setq hullPt (cons n
HullPt)) ;把Pi加入到凸集
(setq P (cadr
hullPt)) ;Pi-1
(setq Q (caddr
hullPt)) ;Pi-2
(while (and q
(> (det n P Q) -1e-6)) ;如果左转
(setq hullPt (cons n (cddr hullPt)))
;删除Pi-1点
(setq P (cadr
hullPt)) ;得到新的Pi-1点
(setq Q
(caddr hullPt))
;得到新的Pi-2点
)
)
(reverse
hullpt)
;返回凸集
)
)
)
;;179.1 [功能] 以某点为基点，按照角度和距离分类点集
;;按离pt最近、角度最小排序
(defun
sort-by-angle-distance (ptlist pt /)
(vl-sort
ptlist
'(lambda (e1 e2 / ang1
ang2)
(setq ang1 (angle pt
e1))
(setq ang2 (angle pt
e2))
(if (= ang1
ang2)
(< (distance pt e1) (distance pt
e2))
(< ang1 ang2)
)
)
)
)
;;180 [功能] Function : Find the minimum area of encasing rectangle. by
highflybird
;;Arguments : A CCW
HULL
;;Return: The Four points of Rectangle and its
Area
;;=>(((-1985.38 2464.12) (-2010.16
2466.87) (-2011.17 2457.81) (-1986.39 2455.06)) . 227.229)
(defun
MinAreaRectangle (ptlist /
AA AI BB D1 D2
EDGE I I1X
I1Y
I2X I2Y IL INF IX
IY J1 J2 MINA
MINH
MINW NORH NORM PI1
PI2 PTI0 PTI1 PTI2 PTJ1 PTK1
PTM1
PTS1 PTS2 PTS3 PTS4
REC1 REC2 REC3 REC4 RECT VECH
VECL
VJ12 VM12
)
(setq INF (distance (car ptlist)(cadr ptlist)));(setq INF
1e309)黄明儒2014.12.19改
(setq minA
INF) ;Initiating the Minimum
area is infinite
(setq pti0 (car
ptlist)) ;the first point of
Hull.
(setq pts1 (append ptlist (list
pti0))) ;add the first point at back of
Hull
(setq pts2 (cdr (append ptlist ptlist (list
pti0)))) ;Construct a loop for the hull
(setq
i 0)
;;Find area of encasing rectangle anchored on each edge.
(repeat (length ptlist)
(setq pi1 (car
pts1) ;第一点
pi2 (cadr
pts1) ;第二点
i1x (car
pi1) ;第一点X
i1y
(cadr pi1) ;第一点Y
i2x
(car pi2) ;第二点X
i2y (cadr pi2) ;第二点Y
ix (- i2x i1x)
iy (- i2y i1y)
il (distance (list ix iy) '(0.0 0.0))
)
;;寻找最左点
;;Find a vertex on on
first perpendicular line of support
(while (> (DOTPR ix
iy pts2) 0.0)
(setq pts2 (cdr
pts2))
)
;;寻找最上点
;;Find a vertex on second perpendicular line of
suppoer
(if (= i 0)
(setq pts3 pts2)
)
(while (>
(CROSSPR ix iy pts3) 0.0)
(setq pts3 (cdr
pts3))
)
;;寻找最右点
;;Find a vertex on second perpendicular line of
suppoer
(if (= i 0)
(setq pts4 pts3)
)
(while (<
(DOTPR ix iy pts4) 0.0)
(setq pts4 (cdr
pts4))
)
;;得出了每边的矩形
;;Find distances between parallel and
perpendicular lines of support
(cond
((equal i1x i2x
1e-4)
;如果边两点的X值相同
(setq d1 (- (caar pts3)
i1x)
;那么矩形的高就是最上点与边的X的差值
d2 (- (cadar pts4)
(cadar pts2))
;矩形的宽就是最左和最右的Y的差值
)
)
((equal
i1y i2y 1e-4)
;如果边两点的Y值相同
(setq d1 (- (cadar
pts3) i1y)
;那么矩形的高就是最上点与边的Y的差值
d2 (- (caar pts4)
(caar pts2))
;矩形的宽就是最左和最右的X的差值
)
)
(T
(setq aa (det pi1 pi2 (car pts3)))
;否则计算边和最上点构成的面积的二倍(det)
(setq d1 (/ aa
il))
;高就是det值除以边长
(setq j1 (car
pts2))
;最右边点
(setq j2 (list (- (car j1) iy) (+
(cadr j1) ix)))
;通过最右边点的垂直边的点
(setq bb (det j1 j2 (car
pts4)))
;最右边点，上面的点和最左边的点
(setq d2 (/ bb
il))
;这三点的det除以边长就是宽
)
)
;;计算矩形的面积，必要时更新最小面积
;;Compute area
of encasing rectangle anchored on current edge.
;;if the
area is smaller than the old Minimum area,then update,and record the
width,height and five points.
(setq Ai (abs (* d1
d2))) ;面积就是高和宽的积
(if (< Ai MinA)
;如果面积小于先前的最小面积，则记录：
(setq MinA
Ai
;更新最小面积
MinH
d1
;最小面积的高
MinW
d2
;最小面积的宽
pti1
pi1
;最小面积的边的第一个端点
pti2
pi2
;最小面积的边的第二个端点
ptj1 (car
pts2)
;最右边的点
ptk1 (car
pts3)
;最上面的点
ptm1 (car
pts4)
;最左边的点
)
)
(setq pts1 (cdr
pts1)) ;检测下一条边
(setq i (1+ i)) ;计数器加一
)
;;according to the result ,draw the Minimum Area Rectangle
(setq edge (mapcar '- pti2 pti1))
;最小面积的边对应的向量
(setq VecL (distance edge '(0.0
0.0))) ;最小面积的边的长度
(setq NorH (abs (/
MinH VecL))) ;这边的法线
(setq Norm (list (- (cadr edge)) (car
edge))) ;这边的垂直向量
(setq vj12 (mapcar '+
ptj1 Norm)) ;通过最右点的垂直向量
(setq vm12
(mapcar '+ ptm1 Norm)) ;通过最左点的垂直向量
(setq vecH (mapcar '* (list NorH NorH) Norm))
(setq rec1 (inters pti1 pti2 ptj1 vj12
nil)) ;矩形的第一点
(setq rec4 (inters pti1
pti2 ptm1 vm12 nil)) ;矩形的第四点
(setq rec2
(mapcar '+ rec1 vecH)) ;矩形的第二点
(setq rec3 (mapcar '+ rec4 vecH))
;矩形的第三点
(setq rect (list Rec1 rec2 rec3
rec4)) ;矩形的点表
(cons rect
MinA) ;返回这个矩形的点表和最大距离
)
;;180.1 [功能] 点积= x1*x2 + y1*y2
(defun DOTPR (ix iy pts / pt1
pt2)
(setq pt1 (car pts))
(setq pt2 (cadr pts))
(+
(* ix (- (car pt2) (car pt1)))
(* iy (- (cadr pt2)
(cadr pt1)))
)
)
;;180.2 [功能] 叉积= x1*y2 - x2*y1
(defun CROSSPR (ix iy pts / pt1
pt2)
(setq pt1 (car pts))
(setq pt2 (cadr pts))
(-
(* ix (- (cadr pt2) (cadr pt1)))
(* iy (- (car pt2)
(car pt1)))
)
)
;;180.3 [功能] 取点函数2
(defun getpt (ss n / i s a b c d e)
(setq i
0)
(if ss
(repeat (sslength
ss)
(setq a (ssname ss
i))
(setq b (entget
a))
(setq e (cdr (assoc 0
b)))
(cond
((= e
"LWPOLYLINE")
(setq c (get-pline-vertexs a n))
(setq s
(append c s))
)
((wcmatch e
"SPLINE,ARC,CIRCLE,ELLIPSE")
(setq c (get-spline-vertexs a
n))
(setq s (append c s))
)
((= e "LINE")
(setq c (cdr (assoc 10 b)))
(setq d (cdr (assoc 11 b)))
(setq c (list (car c) (cadr c)))
(setq d (list (car d) (cadr
d)))
(setq s (cons c s))
(setq s (cons d
s))
)
((= e "POINT")
(setq c (cdr (assoc 10
b)))
(setq c (list (car c) (cadr c)))
(setq s (cons c
s))
)
)
(setq i (1+ i))
)
)
s
)
;;180.4 [功能] 取得多边形顶点
(defun get-LWpolyline-vertexs (DXF / lst)
(foreach n DXF
(if (= (car n)
10)
(setq lst (cons (cdr n)
lst))
)
)
(reverse
lst)
)
;|
(defun get-3dpolyline-vertexs (ent / p)
(if (and
(setq ent (entnext ent)) (setq p (cdr (assoc 10 (entget
ent)))))
(cons p (get-3dpolyline-vertexs ent))
)
p
)|;
;;180.5 [功能] 取得含有圆弧的多段线的点
;;(mapcar '(lambda(x) (command "line" x '(0 0)
"")) (get-pline-vertexs (car(entsel)) 10))
;;n 为弧的取点数量
(defun
get-pline-vertexs (ent n / BLG DIST ENDPAR I L1 L2 L3 LI OBJ PT PTS
VEXNUM)
(setq obj (vlax-ename->vla-object ent))
(setq
endpar (vlax-curve-getEndParam obj))
(setq vexNum (fix
endPar))
(setq pts nil)
(setq i 0)
(repeat
vexNum
(setq pt (vlax-curve-getPointAtParam obj
i))
(setq pts (cons pt pts))
(setq
blg (vla-getbulge obj i))
(if (/= blg
0.0)
(progn
(setq l1
(vlax-curve-getDistAtParam obj i))
(setq l2 (vlax-curve-getDistAtParam
obj (1+ i)))
(setq l3 (- l2
l1)) ;弧长
(setq li (/ l3
n))
(setq dist l1)
(repeat (1- n)
(setq
dist (+ dist li))
(setq pt (vlax-curve-getPointAtDist obj
dist))
(setq pts (cons pt
pts))
)
)
)
(setq i (1+ i))
)
(if (=
(vla-get-closed obj) :vlax-false)
(setq pt
(vlax-curve-getEndPoint obj)
pts (cons pt
pts)
)
)
pts
)
;;181.1 [功能] 插入属性块(vla法)(相当于command "_.Insert"
;;(vla:IBlock "ccd1"
(getpoint))
;;Name可以是属性块名或者.dwg文件
(defun vla:IBlock (Name pt /
*SPACE)
(or *ACAD* (setq *ACAD* (vlax-get-acad-object)))
(or
*DOC* (setq *DOC* (vla-get-ActiveDocument *ACAD*)))
(if (zerop
(vla-get-ActiveSpace *DOC*))
(setq *Space
(vla-get-PaperSpace *DOC*))
(setq *Space
(vla-get-ModelSpace *DOC*))
)
(vla-InsertBlock *Space
(vlax-3d-point (trans pt 1 0)) Name 1 1 1 0)
)
;;181.2 [功能]
Entmake插入块(插入属性块时，属性丢失) by自贡黄明儒整理
;;(EntmakeInsert "ccd1"
(getpoint))
(defun EntmakeInsert (name pt)
(entmakeX (list '(0 .
"INSERT") (cons 2 name) (cons 10 (trans pt 1 0))))
)
;;181.3 [功能]
插入块(entmake法 属性或者非属性块)
;;(EntmakeInsertB "ccd1"
(getpoint))
;;(EntmakeInsertB "TYBTL" (getpoint))
(defun EntmakeInsertB
(name pt / E EN P10 STR)
(defun MKATTRIB (pt str
H)
(entmake
(list
'(0 .
"ATTRIB")
'(100 .
"AcDbEntity")
'(100 .
"AcDbText")
(cons 10
pt)
(cons 40
H)
(cons 1
str)
'(100 .
"AcDbAttribute")
(cons 2
str)
'(70 .
0)
)
)
)
(setq e (TBLOBJNAME "Block" name))
(setq
pt (trans pt 1 0))
(cond ((equal (assoc 70 (entget e)) '(70 .
0))
(entmake (list '(0 . "INSERT") (cons 2 name) (cons 10
pt)))
)
(T
(entmake (list '(0 . "INSERT") '(66 . 1)
(cons 2 name) (cons 10 pt)))
(while (setq e (entnext
e))
(setq en (entget e))
(cond
((equal (assoc 0 en) '(0 . "ATTDEF"))
(setq p10 (mapcar '+ pt (cdr (assoc 10 en))))
(setq str
(cdr (assoc 1 en)))
(MKATTRIB p10 str
(cdr (assoc 40 en)))
)
)
)
(entmake '((0 . "SEQEND")))
)
)
(entlast)
)
;;182 [功能] 曲线方向判断
(defun Curve:Direction (curve / box
params)
(setq box (_pnts:box (Entity:Box
curve))
params (mapcar
'(lambda
(x)
(vlax-curve-getParamAtPoint
curve
(vlax-curve-getClosestPointTo curve x)
)
)
box
)
)
(or
(apply '<= params)
(<=
(cadr lst) (caddr params) (cadddr params) (car params))
(<= (caddr params)
(cadddr params)
(car
params)
(cadr params)
)
(<= (cadddr params)
(car params)
(cadr
params)
(caddr params)
)
)
)
;;183.1 [功能] 列表框增加内容
;;(DCL-ADDLIST "ltypelist1" Ltypes
0),用在new_dialog之后
(defun dcl-AddListAddList (key val item)
(start_list key)
(foreach n val (add_list n))
(end_list)
(cond (item (set_tile key item)))
)
;;183.2 [功能]
灰显控件
;|
(defun dcl-keyContrls (Lst value)
(foreach key (mapcar
'(lambda (x) (strcat "key" (VL-PRIN1-TO-STRING x))) Lst)
(mode_tile key value)
)
)
(if (= (get_tile "toggle_key")
"1")
(dcl-keyContrls '(1 2 3) 1)
(dcl-keyContrls '(1 2 3)
0)
)|;
;;用在new_dialog之后
(defun
dcl-disablectrls (keylist)
(foreach key keylist (mode_tile key
1))
)
;;183.3 [功能] 激活控件
;;用在new_dialog之后
(defun dcl-enablectrls
(keylist)
(foreach key keylist (mode_tile key 0))
)
;;183.4 [功能]
列表框(file库文件)
;;(action_tile "cmdlist" "(act_cmdlist $reason
$value)")
;;$reason=4双击；=1单击。$value第一项"0"
;;183.5 [功能] 图像框（见140)
;;(dcl-image "RM" 5 5 "rough.slb")
(defun
dcl-image (key x y file)
(start_image key)
(setq max_x
(dimx_tile key)
max_y (dimy_tile key)
)
(slide_image x
y
(- max_x
x)
(- max_y
y)
(strcat (findfile file) "(" key
")")
)
(end_image)
)
;;184.1 [功能] 将文件转成二进制
;;(ReadBinary (getfiled "Select a file" "" ""
8))
(defun ReadBinary (filename / str wsObj)
(if (setq wsObj
(vlax-create-object "ScriptControl"))
(progn
(vlax-put wsObj "language"
"VBS")
(setq
str
"Function
ReadBinary(FileName)
Const adTypeBinary = 1
Dim stream,
xmldom, node
Set xmldom =
CreateObject(\"Microsoft.XMLDOM\")
Set node =
xmldom.CreateElement(\"binary\")
node.DataType =
\"bin.hex\"
Set stream =
CreateObject(\"ADODB.Stream\")
stream.Type =
adTypeBinary
stream.Open
stream.LoadFromFile
FileName
node.NodeTypedValue =
stream.Read
stream.Close
Set stream =
Nothing
ReadBinary = node.Text
Set node = Nothing
Set
xmldom = Nothing
End Function"
)
(vlax-invoke wsObj 'ExecuteStatement
str)
(setq str (vlax-invoke wsObj 'run
"ReadBinary" filename))
(vlax-release-object
wsObj)
str
)
)
)
;;;Write Binary file from strings
;;184.2 [功能]
将二进制文件buffer，写入FileName
(defun WriteBinary (FileName buffer / wsObj
str)
(if (setq wsObj (vlax-create-object
"ScriptControl"))
(progn
(vlax-put wsObj "language" "VBS")
(setq
str
"Sub WriteBinary(FileName,
Buf)
Const adTypeBinary = 1
Const adSaveCreateOverWrite =
2
Dim stream, xmldom, node
Set xmldom =
CreateObject(\"Microsoft.XMLDOM\")
Set node =
xmldom.CreateElement(\"binary\")
node.DataType =
\"bin.hex\"
node.Text = Buf
Set stream =
CreateObject(\"ADODB.Stream\")
stream.Type =
adTypeBinary
stream.Open
stream.write
node.NodeTypedValue
stream.saveToFile FileName,
adSaveCreateOverWrite
stream.Close
Set stream =
Nothing
Set node = Nothing
Set xmldom =
Nothing
End
Sub"
)
(vlax-invoke wsObj 'ExecuteStatement str)
(vlax-invoke wsObj 'run "WriteBinary" Filename
buffer)
(vlax-release-object
wsObj)
(princ)
)
)
)
;;184.3 [功能]
将文件转成二进制文件，并保存在当前文件夹下
;;下面函数将DynWrapX.dll转成二进制文件DynWrapX.txt,以便将txt打包进vlx中。
(defun
C:Read_Write_BinaryFile (/ name buff file)
(if (setq name (getfiled
"Select a file" "" "" 8))
(progn
(setq buff (readbinary
name))
(setq file (strcat
(vl-filename-directory name) (vl-filename-base
name)))
(setq file (open (strcat file ".txt")
"W"))
(princ buff
file)
(close
file)
(princ (strcat "\n文件保存路径"
(vl-filename-directory name)))
;;(writeBinary
"C:\\DynWrapX.dll" buff)
(princ)
)
)
)
;;185.1 [功能] 保存当前坐标系----提取自G版程序，以便以后应用
;;(_HH:SetWcs)
(defun _HH:SetWcs
(/ OBJUCS UCSORG UCSXDIR UCSYDIR)
(or *ACAD* (setq *ACAD*
(vlax-get-acad-object)))
(or *DOC* (setq *DOC* (vla-get-ActiveDocument
*ACAD*)))
(cond ((= 0 (getvar "worlducs"))
(setq
ucsorg (getvar "ucsorg")
ucsxdir (apply 'mapcar
(cons
'+ (list ucsorg (getvar
"ucsxdir")))
)
ucsydir (apply
'mapcar
(cons '+ (list
ucsorg (getvar "ucsydir")))
)
)
(setq
objucs
(VL-CATCH-ALL-APPLY
'vla-item
(list (vla-get-UserCoordinateSystems
*Doc*) "OldUCS")
)
)
(cond ((not
(VL-CATCH-ALL-ERROR-P objucs)) (vla-delete objucs)))
(VL-CATCH-ALL-APPLY
'vla-add
(list
(vla-get-UserCoordinateSystems
*Doc*)
(vlax-3d-point
ucsorg)
(vlax-3d-point
ucsxdir)
(vlax-3d-point
ucsydir)
"OldUCS"
)
)
)
(T
(setq
objucs (VL-CATCH-ALL-APPLY
'vla-item
(list (vla-get-UserCoordinateSystems
*Doc*) "OldUCS")
)
)
(cond ((not
(VL-CATCH-ALL-ERROR-P objucs))
(VL-CATCH-ALL-APPLY 'vla-delete
(list objucs))
)
)
)
)
(princ)
)
;;185.2 [功能]
恢复坐标系----提取自G版程序
;;http://bbs.xdcad.net/thread-678868-1-1.html
保存坐标系统
(defun gxl-ReUcs (/ OBJUCS)
(or *ACAD* (setq *ACAD*
(vlax-get-acad-object)))
(or *DOC* (setq *DOC* (vla-get-ActiveDocument
*ACAD*)))
(setq
objucs (VL-CATCH-ALL-APPLY
'vla-item
(list (vla-get-UserCoordinateSystems *DOC*)
"OldUCS")
)
)
(cond ((not (VL-CATCH-ALL-ERROR-P objucs))
(vla-put-ActiveUCS *Doc* objucs)))
(princ)
)
;;186 [功能] 交换函数 by highflybird
;;(setq x 1 y 2)
;;(SWAP 'x 'y)=> !x
2
(defun SWAP (SwapX SwapY / temp)
(setq temp (VL-SYMBOL-VALUE
SwapX))
(set SwapX (VL-SYMBOL-VALUE SwapY))
(set SwapY
temp)
)