|
|
Public Sub Use3PDimAngle()
Dim DimPointAngularObj As AcadDim3PointAngular
Dim AngleVertex As Variant
Dim FirstPoint As Variant, SecondPoint As Variant
Dim TextPoint As Variant
' Define the new Dim3PointAngular object
'AngleVertex(0) = 0: AngleVertex(1) = 0: AngleVertex(2) = 0
'FirstPoint(0) = 50: FirstPoint(1) = 50: FirstPoint(2) = 0
'SecondPoint(0) = 50: SecondPoint(1) = 100: SecondPoint(2) = 0
'TextPoint(0) = 150: TextPoint(1) = 150: TextPoint(2) = 0
AngleVertex = ThisDrawing.Utility.GetPoint(, "选择第1个点：")
FirstPoint = ThisDrawing.Utility.GetPoint(, "选择第2个点：")
SecondPoint = ThisDrawing.Utility.GetPoint(, "选择第3个点：")
'TextPoint = ThisDrawing.Utility.GetPoint(SecondPoint, "选择文字位置：")
' Create the new Dim3PointAngular object in model space
Set DimPointAngularObj = ThisDrawing.ModelSpace.AddDim3PointAngular(AngleVertex, FirstPoint, SecondPoint, TextPoint)
'ZoomAll
'MsgBox "A Dim3PointAngular object has been created."
End Sub
Public Sub DimAngular()
Dim entObj1 As AcadEntity
Dim pickPnt1 As Variant
Dim oldOSMODE As Integer
'选择被标注多义线的第1个标注边
ThisDrawing.Utility.GetEntity entObj1, pickPnt1, "选择被标注对象："
If StrComp(entObj1.ObjectName, "AcDbPolyline", 1) 0 Then
MsgBox "选择的图元不是多义线，程序将退出！"
Exit Sub
End If
Dim vetexCount As Integer '多义线顶点数
Dim sVetex As Variant '始顶点坐标
Dim eVetex As Variant '终顶点坐标
'先求出顶点的元素数
vetexCount = UBound(entObj1.Coordinates)
'求顶点个数
vetexCount = (vetexCount + 1) / 2
'准备判断第1个顶点和最后一个顶点是否重合
sVetex = entObj1.Coordinate(0)
eVetex = entObj1.Coordinate(vetexCount - 1)
'求多义线非自动闭合时的实际顶点个数
If sVetex(0) = eVetex(0) And sVetex(1) = eVetex(1) Then
vetexCount = vetexCount - 1
End If
oldOSMODE = ThisDrawing.GetVariable("OSMODE")
ThisDrawing.SetVariable "OSMODE", 512
Dim dimPnt1 As Variant, dimPnt2 As Variant
dimPnt1 = ThisDrawing.Utility.GetPoint(, "选择第一个标注点：")
dimPnt2 = ThisDrawing.Utility.GetPoint(, "选择第二个标注点：")
'------------------------------------------------------------------
Dim I As Integer, J As Integer
Dim lineObj1 As AcadLine
Dim lineObj2 As AcadLine
Dim sPnt(0 To 2) As Double
Dim ePnt(0 To 2) As Double
Dim X As String, Y As String
On Error Resume Next
'判断第一条临时直线的交点落在多义线的哪条边上
For I = 0 To vetexCount - 2
sVetex = entObj1.Coordinate(I)
eVetex = entObj1.Coordinate(I + 1)
Y = (dimPnt1(1) - sVetex(1)) / (eVetex(1) - sVetex(1))
X = (dimPnt1(0) - sVetex(0)) / (eVetex(0) - sVetex(0))
'MsgBox "X1 = " & X & Chr(13) & "Y1 = " & Y
If StrComp(X, Y, 1) = 0 Then
sPnt(0) = sVetex(0): sPnt(1) = sVetex(1): sPnt(2) = 0
ePnt(0) = eVetex(0): ePnt(1) = eVetex(1): ePnt(2) = 0
Set lineObj1 = ThisDrawing.ModelSpace.AddLine(sPnt, ePnt)
lineObj1.Visible = False
GoTo lineMark1
End If
Next
sVetex = entObj1.Coordinate(0)
eVetex = entObj1.Coordinate(vetexCount - 1)
Y = (dimPnt1(1) - sVetex(1)) / (eVetex(1) - sVetex(1))
X = (dimPnt1(0) - sVetex(0)) / (eVetex(0) - sVetex(0))
'MsgBox "X1 = " & X & Chr(13) & "Y1 = " & Y
If StrComp(X, Y, 1) = 0 Then
sPnt(0) = sVetex(0): sPnt(1) = sVetex(1): sPnt(2) = 0
ePnt(0) = eVetex(0): ePnt(1) = eVetex(1): ePnt(2) = 0
Set lineObj1 = ThisDrawing.ModelSpace.AddLine(sPnt, ePnt)
lineObj1.Visible = False
End If
lineMark1:
For I = 0 To vetexCount - 2
sVetex = entObj1.Coordinate(I)
eVetex = entObj1.Coordinate(I + 1)
Y = (dimPnt2(1) - sVetex(1)) / (eVetex(1) - sVetex(1))
X = (dimPnt2(0) - sVetex(0)) / (eVetex(0) - sVetex(0))
'MsgBox "X2 = " & X & Chr(13) & "Y2 = " & Y
If StrComp(X, Y, 1) = 0 Then
sPnt(0) = sVetex(0): sPnt(1) = sVetex(1): sPnt(2) = 0
ePnt(0) = eVetex(0): ePnt(1) = eVetex(1): ePnt(2) = 0
Set lineObj2 = ThisDrawing.ModelSpace.AddLine(sPnt, ePnt)
lineObj2.Visible = False
GoTo lineMark2
End If
Next
sVetex = entObj1.Coordinate(0)
eVetex = entObj1.Coordinate(vetexCount - 1)
Y = (dimPnt2(1) - sVetex(1)) / (eVetex(1) - sVetex(1))
X = (dimPnt2(0) - sVetex(0)) / (eVetex(0) - sVetex(0))
'MsgBox "X2 = " & X & Chr(13) & "Y2 = " & Y
If StrComp(X, Y, 1) = 0 Then
sPnt(0) = sVetex(0): sPnt(1) = sVetex(1): sPnt(2) = 0
ePnt(0) = eVetex(0): ePnt(1) = eVetex(1): ePnt(2) = 0
Set lineObj2 = ThisDrawing.ModelSpace.AddLine(sPnt, ePnt)
lineObj2.Visible = False
End If
'----------------------------------------------------------------
lineMark2:
Dim dimObj As AcadDimAngular
Dim insectVert As Variant
Dim angVert(0 To 2) As Double
Dim FirstPoint(0 To 2) As Double
Dim SecondPoint(0 To 2) As Double
Dim TextPoint As Variant
'求第二和第三条临时直线的交点，此交点
'就是要标注的2条边的角度标注的标注顶点
insectVert = lineObj1.IntersectWith(lineObj2, acExtendBoth)
'删除已不用的临时线
lineObj1.Delete
lineObj2.Delete
ThisDrawing.SetVariable "OSMODE", oldOSMODE
On Error Resume Next
'确定角度标注的顶点
angVert(0) = insectVert(0)
angVert(1) = insectVert(1)
angVert(2) = insectVert(2)
'确定第一条标注边上的标注点
FirstPoint(0) = dimPnt1(0)
FirstPoint(1) = dimPnt1(1)
FirstPoint(2) = dimPnt1(2)
'确定第二条标注边上的标注点
SecondPoint(0) = dimPnt2(0)
SecondPoint(1) = dimPnt2(1)
SecondPoint(2) = dimPnt2(2)
'确定标注文字的位置
TextPoint = ThisDrawing.Utility.GetPoint(SecondPoint, "选择标注文字位置：")
'创建角度尺寸标注对象
Set dimObj = ThisDrawing.ModelSpace.AddDimAngular(angVert, FirstPoint, SecondPoint, TextPoint)
'ZoomAll
End Sub
Public Sub Add5PointDimAngular()
Dim dPnt1 As Variant, dPnt2 As Variant
Dim dPnt3 As Variant, dPnt4 As Variant
Dim oldOSMODE As Integer
'保存原目标捕捉的设定
oldOSMODE = ThisDrawing.GetVariable("OSMODE")
'设定自动捕捉图元对象上的最近点
ThisDrawing.SetVariable "OSMODE", 512
'选择第1条尺寸界线上的第1个标注点
dPnt1 = ThisDrawing.Utility.GetPoint(, "选择界线1标注点1：")
'选择第1条尺寸界线上的第2个标注点
dPnt2 = ThisDrawing.Utility.GetPoint(dPnt1, "选择界线1标注点2：")
'选择第2条尺寸界线上的第1个标注点
dPnt3 = ThisDrawing.Utility.GetPoint(, "选择界线2标注点1：")
'选择第2条尺寸界线上的第2个标注点
dPnt4 = ThisDrawing.Utility.GetPoint(dPnt3, "选择界线2标注点2：")
Dim lineObj1 As AcadLine, lineObj2 As AcadLine
Dim insectPnt As Variant
'创建第1条临时尺寸界线
Set lineObj1 = ThisDrawing.ModelSpace.AddLine(dPnt1, dPnt2)
lineObj1.Visible = False '将其设为不可见
'创建第2条临时尺寸界线
Set lineObj2 = ThisDrawing.ModelSpace.AddLine(dPnt3, dPnt4)
lineObj2.Visible = False
'求出2条临时尺寸界线的交点，即标注顶点angVert
insectPnt = lineObj1.IntersectWith(lineObj2, acExtendBoth)
'恢复原来的目标捕捉设定
ThisDrawing.SetVariable "OSMODE", oldOSMODE
'删除2条临时尺寸界线
lineObj1.Delete
lineObj2.Delete
'--------------------------------------------------------------
Dim dimObj As AcadDimAngular
Dim TextPoint As Variant
'选定标注文字的显示位置
TextPoint = ThisDrawing.Utility.GetPoint(dPnt4, "选择标注文字位置：")
'用dPnt1点作为FirstPoint点，dPnt3点作为SecondPoint点
Set dimObj = ThisDrawing.ModelSpace.AddDimAngular(insectPnt, dPnt1, dPnt3, TextPoint)
dimObj.AngleFormat = acRadians
End Sub |
|
置顶卡
