【转帖】以前写的一些通用函数 - 精华帖集合
 

以前写的一些通用函数 - 精华帖集合
www.dimcax.com
以前写的一些通用函数
option explicit
'least_of_double + 1# =1#
public const least_of_double# = 0.00000001
public const pi# = 3.14159265358979
public const seconds_of_rad# = 206264.806247096
public const rads_of_second# = 4.84813681109537e-06
'添加菜单，如果已存在则返回该菜单对象，如果不存在则创建菜单并返回创建的菜单对象
public function csaddmenu(popupmenuname as string) as acadpopupmenu
dim i&
dim currmenugroup as acadmenugroup
set currmenugroup = thisdrawing.application.menugroups.item(0)
for i = 0 to currmenugroup.menus.count - 1
if currmenugroup.menus.item(i).name = popupmenuname then
set csaddmenu = currmenugroup.menus.item(i)
exit function
end if
next i
set csaddmenu = currmenugroup.menus.add(popupmenuname)
currmenugroup.menus.insertmenuinmenubar popupmenuname, currmenugroup.menus.count
end function
'在指定的菜单添加菜单条，如果菜单条已存在则根据 overwrite 参数是否覆盖，返回该菜单条对象，如果不存在则创建菜单条并返回创建的菜单条对象
public function csaddmenuitem(popupmenuname as string, menuitemname as string, menumacro as string, overwrite as boolean) as acadpopupmenuitem
dim i&
dim newmenu as acadpopupmenu
set newmenu = csaddmenu(popupmenuname)
for i = 0 to newmenu.count - 1
if newmenu.item(i).label = menuitemname then
if overwrite then
newmenu.item(i).delete
exit for
else
set csaddmenuitem = newmenu.item(i)
exit function
end if
end if
next i
set csaddmenuitem = csaddmenu(popupmenuname).addmenuitem(10000, menuitemname, menumacro)
end function
'添加图层，如果已存在则返回该图层对象，如果不存在则创建图层并返回创建的图层对象
public function csaddlayer(layername as string) as acadlayer
dim i as long
for i = 0 to thisdrawing.layers.count - 1
if thisdrawing.layers.item(i).name = layername then
set csaddlayer = thisdrawing.layers.item(i)
exit function
end if
next i
if thisdrawing.layers.count = i then
set csaddlayer = thisdrawing.layers.add(layername)
end if
end function
'添加选择集，如果已存在则返回该选择集对象，如果不存在则创建选择集并返回创建的选择集对象
public function csaddselectionset(selectionsetname as string) as acadselectionset
dim i as long
if thisdrawing.selectionsets.count > 0 then
for i = 0 to thisdrawing.selectionsets.count - 1
if thisdrawing.selectionsets(i).name = selectionsetname then
set csaddselectionset = thisdrawing.selectionsets(i)
exit for
end if
next i
if i = thisdrawing.selectionsets.count then
set csaddselectionset = thisdrawing.selectionsets.add(selectionsetname)
end if
else
set csaddselectionset = thisdrawing.selectionsets.add(selectionsetname)
end if
end function
'根据一个对象（多段线、二维多段线、三维多段线）返回该对象的所有节点平面坐标（x0, y0, 0, x1, y1, 0，……）
public function csgetpolygon(ent as acadentity) as double()
dim vlen&, i&
dim polygon() as double
if ent.objectname = "acdbpolyline" then
dim lwpl as acadlwpolyline
set lwpl = ent
vlen = (ubound(lwpl.coordinates) - lbound(lwpl.coordinates) + 1) / 2
redim polygon(vlen * 3 - 1)
for i = 0 to vlen - 1
polygon(i * 3) = lwpl.coordinates(i * 2)
polygon(i * 3 + 1) = lwpl.coordinates(i * 2 + 1)
polygon(i * 3 + 2) = 0
next i
'二维多段线
elseif ent.objectname = "acdb2dpolyline" then
dim pl as acadpolyline
set pl = ent
vlen = (ubound(pl.coordinates) - lbound(pl.coordinates) + 1) / 3
redim polygon(vlen * 3 - 1)
for i = 0 to vlen - 1
polygon(i * 3) = pl.coordinates(i * 3)
polygon(i * 3 + 1) = pl.coordinates(i * 3 + 1)
polygon(i * 3 + 2) = 0
next i
'三维多段线
elseif ent.objectname = "acdb3dpolyline" then
dim dpl as acad3dpolyline
set dpl = ent
vlen = (ubound(dpl.coordinates) - lbound(dpl.coordinates) + 1) / 3
redim polygon(vlen * 3 - 1)
for i = 0 to vlen - 1
polygon(i * 3) = dpl.coordinates(i * 3)
polygon(i * 3 + 1) = dpl.coordinates(i * 3 + 1)
polygon(i * 3 + 2) = 0
next i
else
exit function
end if
csgetpolygon = polygon
end function
'检查文件是否存在，存在返回 true， 不存在返回 false
public function checkfileexist(filefullname as string) as boolean
dim fso as object
set fso = createobject("scripting.filesystemobject")
if fso.fileexists(filefullname) then
checkfileexist = true
else
checkfileexist = false
end if
end function
'查看扩展数据
sub xdataview()
dim sset as acadselectionset
set sset = csaddselectionset("ss1")
sset.clear
sset.selectonscreen
' 定义扩展数据变量以保存扩展数据信息
dim xdatatype as variant
dim xdata as variant
dim xd as variant
'定义索引计数器
dim xdi as integer
xdi = 0
' 遍历选择集中的对象
' 并检索对象的扩展数据
dim msgstr as string
dim appname as string
dim ent as acadentity
appname = ""
for each ent in sset
msgstr = ""
xdi = 0
' 检索 appname 扩展数据类型和值
ent.getxdata appname, xdatatype, xdata
' 如果未初始化 xdatatype 变量，
' 则没有可供该图元检索的 appname 扩展数据
if vartype(xdatatype) <> vbempty then
for each xd in xdata
msgstr = msgstr & vbcrlf & xdatatype(xdi) _
& ": " & xd
xdi = xdi + 1
next xd
end if
' 如果 msgstr 变量为 null，则没有扩展数据
if msgstr = "" then msgstr = vbcrlf & "none"
msgbox appname & " xdata on " & ent.objectname & _
":" & vbcrlf & msgstr
next ent
end sub
'反正切函数，返回 0 ~ 2π
public function csatn(dx as double, dy as double) as double
if dy <> 0 then
if dy > 0 and abs(dx / dy) < 0.0000000001 then csatn = pi * 0.5: exit function
if dy < 0 and abs(dx / dy) < 0.0000000001 then csatn = pi * 1.5: exit function
end if
csatn = atn(dy / dx)
if (dx < 0) then csatn = pi + csatn
if (dx > 0) and (csatn < 0) then csatn = 2 * pi + csatn
end function
'由两组坐标返回距离
public function csdistance(y1 as double, x1 as double, y2 as double, x2 as double) as double
csdistance = sqr((y1 - y2) ^ 2 + (x1 - x2) ^ 2)
end function
'将弧度化成 ddd°mm′ss″ 表示的字符串
public function rad2degreestring(rad as double) as string
dim d&, m&, t&, s&
t = rad * 206264.806247096
d = t \ 3600
m = (t - d * 3600) \ 60
s = t - d * 3600 - m * 60
rad2degreestring = d & "°" & format(m, "00") & "′" & format(s, "00") & "″"
end function
复制代码