一组函数

ObjectARX · 发表于 2017-5-30 14:05:00

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

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

×

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

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

csharp · 发表于 2017-5-30 15:40:32

看着像 VBA 代码

yjch · 发表于 2017-5-31 11:10:44

函数太好，谢谢。好好学习天天向上

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

[每日一码] 一组函数

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