[例程]使用Utility
Public Sub UseGetConer()Dim returnPnt As Variant
Dim basePnt As Variant
'basePnt(0) = 2#: basePnt(1) = 2#: basePnt(2) = 0#
basePnt = ThisDrawing.Utility.GetPoint(, "选择第1个角点：")
' Prompt the user to pick second point and returns the point
returnPnt = ThisDrawing.Utility.GetCorner(basePnt, "输入第2个角点： ")
' Display the point picked
MsgBox "第2个角点的坐标为：" & returnPnt(0) & ", " & returnPnt(1) & ", " & returnPnt(2), , "GetCorner Example"
End Sub
Public Sub UseGetAngle()
Dim pickObj As AcadEntity
Dim pickPnt As Variant
ThisDrawing.Utility.GetEntity pickObj, pickPnt
'-------------------------------
Dim retAngle As Double
Dim basePnt As Variant
basePnt = ThisDrawing.Utility.GetPoint(, "选择一个基点：")
' Return the angle in radians with a prompt
retAngle = ThisDrawing.Utility.GetAngle(, "输入一个角度: ")
'MsgBox "输入的角度值为：" & retAngle
' Return the angle in radians with a prompt and an angle base point
'basePnt(0) = 2#: basePnt(1) = 2#: basePnt(2) = 0#
'retAngle = ThisDrawing.Utility.GetAngle(basePnt, "输入一个角度: ")
'MsgBox "输入的角度值为：" & retAngle
'---------------------------------
pickObj.Rotate basePnt, retAngle
End Sub
Public Sub UseGetKeyword()
' Define the list of valid keywords
Dim kwordList As String
kwordList = "Width Height Depth"
ThisDrawing.Utility.InitializeUserInput 1, kwordList
' Prompt the user to input any of the keywords. Return "Width", "Height" or "Depth" in
' the returnString variable depending on whether the user input "W", "H" or "D".
Dim returnString As String
returnString = ThisDrawing.Utility.GetKeyword _
("选择高(H)/宽(W)/深(D): ")
MsgBox "你选择的是：" & returnString
End Sub
Public Sub CreateSector()
'声明用于创建区域的对象数组
Dim curves(0 To 1) As AcadEntity
'声明有关创建圆弧的变量
Dim centerPoint As Variant
Dim radius As Double
Dim startAngle As Double
Dim endAngle As Double
'给圆弧变量赋值
centerPoint = ThisDrawing.Utility.GetPoint(, "选择圆弧中心：")
radius = ThisDrawing.Utility.GetReal("给定圆弧半径：")
startAngle = ThisDrawing.Utility.GetReal("给定起始角：") * 3.141592 / 180
endAngle = ThisDrawing.Utility.GetReal("给定终止角：") * 3.141592 / 180
'绘制圆弧段
Set curves(0) = ThisDrawing.ModelSpace.AddArc _
(centerPoint, radius, startAngle, endAngle)
'绘制直线段
Set curves(1) = ThisDrawing.ModelSpace.AddLine _
(curves(0).StartPoint, curves(0).EndPoint)
'创建由圆弧和直线段构成的区域
Dim keywordList As String
Dim ynValue As String
keywordList = "Yes No"
ThisDrawing.Utility.InitializeUserInput 1, keywordList
ynValue = ThisDrawing.Utility.GetKeyword("创建区域(Y)/不创建区域(N)： ")
If StrComp(ynValue, "Yes", 1) = 0 Then
Dim regionObj As Variant
regionObj = ThisDrawing.ModelSpace.AddRegion(curves)
regionObj(0).Color = acCyan
MsgBox "区域已创建完毕！"
Else
MsgBox "没有创建区域！"
End If
ZoomAll
End Sub
Public Sub RegionMove()
Dim pickObj As AcadEntity
Dim pickPnt As Variant
ThisDrawing.Utility.GetEntity pickObj, pickPnt
Dim movePnt1 As Variant
Dim movePnt2 As Variant
movePnt1 = ThisDrawing.Utility.GetPoint(, "选择移动基点：")
movePnt2 = ThisDrawing.Utility.GetPoint(movePnt1, "选择移动终点：")
pickObj.Move movePnt1, movePnt2
End Sub
Public Sub UseGetInput()
On Error Resume Next
'定义一个关键词列表
Dim keywordList As String
keywordList = "Keyword1 Keyword2"
'允许Getxxx方法输入任何形式的值
ThisDrawing.Utility.InitializeUserInput 128, keywordList
' Get the user input
Dim returnPnt As Variant
returnPnt = ThisDrawing.Utility.GetPoint _
(, "输入Keyword1或Keyword2: ")
If Err Then '如果输入发生错误
'判断错误信息是否为输入关键词
If StrComp(Err.Description, _
"User input is a keyword", 1) = 0 Then
'如果是要输入关键词，用GetInput截获
Dim inputString As String
Err.Clear
inputString = ThisDrawing.Utility.GetInput
MsgBox "You entered the keyword: " & inputString
Else
MsgBox "使用GetPoint方法时出现了" & _
Err.Description & "错误。"
Err.Clear
End If
Else '如果正常地输入了点坐标
MsgBox "点的WCS坐标为: " & returnPnt(0) & ", " & _
returnPnt(1) & ", " & returnPnt(2)
End If
End Sub
Public Sub UseGetSubEntity()
Dim subObj As AcadEntity
Dim PickedPoint As Variant
Dim TransMatrix As Variant
Dim ContextData As Variant
Dim HasContextData As String
On Error GoTo NOT_ENTITY
'获取被选择图元的有关信息
ThisDrawing.Utility.GetSubEntity subObj, PickedPoint, _
TransMatrix, ContextData
'判断是否有子图元存在
HasContextData = IIf(VarType(ContextData) = _
vbEmpty, "没有", "有")
MsgBox "被选对象类型名: " & TypeName(subObj) & vbCrLf & _
"拾取点坐标: " & PickedPoint(0) & ", " & _
PickedPoint(1) & ", " & _
PickedPoint(2) & vbCrLf & _
"该对象" & HasContextData & "嵌套对象。"
Dim I As Integer
MsgBox "被选择对象为第 " & UBound(ContextData) & " 嵌套层."
'显示由里向外嵌套图元的ObjectID
For I = LBound(ContextData) To UBound(ContextData)
MsgBox "第" & UBound(ContextData) - I & _
"嵌套层的ObjectID: " & ContextData(I)
Next
subObj.Color = acGreen
ThisDrawing.Regen True
Exit Sub
NOT_ENTITY:
'若没有选择图元或图元不具备嵌套的能力
MsgBox ("该图元不具有子图元。")
End Sub
Public Sub RotateEntity()
Dim pickObj As AcadEntity '保存被选择图元的对象变量
Dim pickPnt As Variant '选择图元时的拾取点变量
ThisDrawing.Utility.GetEntity pickObj, pickPnt, "选择图元对象："
Dim rotAng As Double '保存旋转角的变量
Dim basePnt As Variant '保存基点的变量
rotAng = ThisDrawing.Utility.GetReal("输入旋转角：")
rotAng = rotAng * 3.141592 / 180'将角度转换成弧度
basePnt = ThisDrawing.Utility.GetPoint(, "选择旋转基点：")
'旋转被选择的图元
pickObj.Rotate basePnt, rotAng
End Sub
页:
[1]