用户登陆
站点日历
站点统计
最新评论
VBA画钢筋 [ 日期：2008-08-14 ] [ 来自：'*******************正筋****************************************
Function ZhengJin(P1 As Variant, P2 As Variant)
Dim PList(0 To 19) As Double
Dim P3 As Variant
Dim P4 As Variant
Dim P5 As Variant
Dim P6 As Variant
Dim A As Double
Dim L As AcadLine
Set L = ThisDrawing.ModelSpace.AddLine(P1, P2)
A = L.angle
P3 = GetPointAR(P1, A + 150 / 180 * Atn(1) * 4, 50)
P4 = GetPointAR(P3, A + 90 / 180 * Atn(1) * 4, 50)
P5 = GetPointAR(P4, A + 30 / 180 * Atn(1) * 4, 50)
P6 = GetPointAR(P5, A + 0 / 180 * Atn(1) * 4, 100)
PList(0) = P6(0): PList(1) = P6(1)
PList(2) = P5(0): PList(3) = P5(1)
PList(4) = P4(0): PList(5) = P4(1)
PList(6) = P3(0): PList(7) = P3(1)
PList(8) = P1(0): PList(9) = P1(1)
P3 = GetPointAR(Point3D(P2(0), P2(1), 0), A + 30 / 180 * Atn(1) * 4, 50)
P4 = GetPointAR(P3, A + 90 / 180 * Atn(1) * 4, 50)
P5 = GetPointAR(P4, A + 150 / 180 * Atn(1) * 4, 50)
P6 = GetPointAR(P5, A + 180 / 180 * Atn(1) * 4, 100)
PList(10) = P2(0): PList(11) = P2(1)
PList(12) = P3(0): PList(13) = P3(1)
PList(14) = P4(0): PList(15) = P4(1)
PList(16) = P5(0): PList(17) = P5(1)
PList(18) = P6(0): PList(19) = P6(1)
Dim PL As AcadLWPolyline
Set PL = ThisDrawing.ModelSpace.AddLightWeightPolyline(PList)
Dim i As Integer
For i = 0 To 9
PL.SetWidth i, 35, 35
Next
PL.color = acByLayer
PL.Layer = "正筋"
L.Delete
End Function
Sub DrawZhengJin()
On Error Resume Next
Dim L As AcadLayer
Set L = AddLayer("正筋")
L.color = 10
Dim P1 As Variant
Dim P2 As Variant
P1 = ThisDrawing.Utility.GetPoint(, "钢筋起点:")
P2 = ThisDrawing.Utility.GetPoint(P1, "钢筋终点:")
ZhengJin P1, P2
End Sub
'******************************************************************
'*******************负筋****************************************
Function FuJin(P1 As Variant, P2 As Variant)
Dim PList(0 To 7) As Double
Dim P3 As Variant
Dim A As Double
Dim L As AcadLine
Set L = ThisDrawing.ModelSpace.AddLine(P1, P2)
A = L.angle
P3 = GetPointAR(P1, A - 90 / 180 * Atn(1) * 4, 250)
PList(0) = P3(0): PList(1) = P3(1)
PList(2) = P1(0): PList(3) = P1(1)
P3 = GetPointAR(Point3D(P2(0), P2(1), 0), A - 90 / 180 * Atn(1) * 4, 250)
PList(4) = P2(0): PList(5) = P2(1)
PList(6) = P3(0): PList(7) = P3(1)
Dim PL As AcadLWPolyline
Set PL = ThisDrawing.ModelSpace.AddLightWeightPolyline(PList)
Dim i As Integer
For i = 0 To 3
PL.SetWidth i, 35, 35
Next
PL.Layer = "负筋"
PL.color = acByLayer
L.Delete
End Function
Sub DrawFuJin()
On Error Resume Next
Dim L As AcadLayer
Set L = AddLayer("负筋")
L.color = 14
Dim P1 As Variant
Dim P2 As Variant
P1 = ThisDrawing.Utility.GetPoint(, "钢筋起点:")
P2 = ThisDrawing.Utility.GetPoint(P1, "钢筋终点:")
FuJin P1, P2
End Sub
'******************************************************************
'*******************拉筋****************************************
Function LaJin(P1 As Variant, P2 As Variant)
Dim PList(0 To 19) As Double
Dim P3 As Variant
Dim P4 As Variant
Dim P5 As Variant
Dim P6 As Variant
Dim A As Double
Dim L As AcadLine
Set L = ThisDrawing.ModelSpace.AddLine(P1, P2)
A = L.angle
P3 = GetPointAR(P1, A + 150 / 180 * Atn(1) * 4, 50)
P4 = GetPointAR(P3, A + 90 / 180 * Atn(1) * 4, 50)
P5 = GetPointAR(P4, A + 30 / 180 * Atn(1) * 4, 50)
P6 = GetPointAR(P5, A + 0 / 180 * Atn(1) * 4, 100)
PList(0) = P6(0): PList(1) = P6(1)
PList(2) = P5(0): PList(3) = P5(1)
PList(4) = P4(0): PList(5) = P4(1)
PList(6) = P3(0): PList(7) = P3(1)
PList(8) = P1(0): PList(9) = P1(1)
P3 = GetPointAR(Point3D(P2(0), P2(1), 0), A - 30 / 180 * Atn(1) * 4, 50)
P4 = GetPointAR(P3, A - 90 / 180 * Atn(1) * 4, 50)
P5 = GetPointAR(P4, A - 150 / 180 * Atn(1) * 4, 50)
P6 = GetPointAR(P5, A - 180 / 180 * Atn(1) * 4, 100)
PList(10) = P2(0): PList(11) = P2(1)
PList(12) = P3(0): PList(13) = P3(1)
PList(14) = P4(0): PList(15) = P4(1)
PList(16) = P5(0): PList(17) = P5(1)
PList(18) = P6(0): PList(19) = P6(1)
Dim PL As AcadLWPolyline
Set PL = ThisDrawing.ModelSpace.AddLightWeightPolyline(PList)
Dim i As Integer
For i = 0 To 9
PL.SetWidth i, 35, 35
Next
PL.color = acByLayer
PL.Layer = "钢筋"
L.Delete
End Function
Sub DrawLaJin()
On Error Resume Next
Dim L As AcadLayer
Set L = AddLayer("钢筋")
L.color = 14
Dim P1 As Variant
Dim P2 As Variant
P1 = ThisDrawing.Utility.GetPoint(, "钢筋起点:")
P2 = ThisDrawing.Utility.GetPoint(P1, "钢筋终点:")
LaJin P1, P2
End Sub
'******************************************************************
'********************钢筋断面************************************
Sub YuanDian()
On Error Resume Next
On Error Resume Next
Dim L As AcadLayer
Set L = AddLayer("钢筋")
L.color = 14
'填充面域
Dim TC_Entity(0 To 0) As AcadEntity
Dim TC As AcadHatch
Dim TC_Name As String
Dim TC_Type As Long
Dim TC_Associativity As Boolean
TC_Name = "SOLID"
TC_Type = 0
TC_Associativity = True
Set TC = ThisDrawing.ModelSpace.AddHatch(TC_Type, TC_Name, TC_Associativity)
Dim P As Variant
P = ThisDrawing.Utility.GetPoint(, "请点取位置:")
Dim C As AcadCircle
Set C = ThisDrawing.ModelSpace.AddCircle(P, 35)
Set TC_Entity(0) = C
TC.AppendInnerLoop (TC_Entity)
TC.Evaluate
TC.Layer = "钢筋"
TC.color = acByLayer
C.Delete
End Sub
'*******************************************************************
'********************徒手画筋************************************
Sub TuShouHuaJin()
On Error Resume Next
Dim L As AcadLayer
Set L = AddLayer("钢筋")
L.color = 14
ThisDrawing.SetVariable "PLINEWID", 35
ThisDrawing.SendCommand "PLine "
JiFa = True '留在AcadDocument_EndCommand中处理
End Sub
'*******************************************************************
Function ZhengJin(P1 As Variant, P2 As Variant)
Dim PList(0 To 19) As Double
Dim P3 As Variant
Dim P4 As Variant
Dim P5 As Variant
Dim P6 As Variant
Dim A As Double
Dim L As AcadLine
Set L = ThisDrawing.ModelSpace.AddLine(P1, P2)
A = L.angle
P3 = GetPointAR(P1, A + 150 / 180 * Atn(1) * 4, 50)
P4 = GetPointAR(P3, A + 90 / 180 * Atn(1) * 4, 50)
P5 = GetPointAR(P4, A + 30 / 180 * Atn(1) * 4, 50)
P6 = GetPointAR(P5, A + 0 / 180 * Atn(1) * 4, 100)
PList(0) = P6(0): PList(1) = P6(1)
PList(2) = P5(0): PList(3) = P5(1)
PList(4) = P4(0): PList(5) = P4(1)
PList(6) = P3(0): PList(7) = P3(1)
PList(8) = P1(0): PList(9) = P1(1)
P3 = GetPointAR(Point3D(P2(0), P2(1), 0), A + 30 / 180 * Atn(1) * 4, 50)
P4 = GetPointAR(P3, A + 90 / 180 * Atn(1) * 4, 50)
P5 = GetPointAR(P4, A + 150 / 180 * Atn(1) * 4, 50)
P6 = GetPointAR(P5, A + 180 / 180 * Atn(1) * 4, 100)
PList(10) = P2(0): PList(11) = P2(1)
PList(12) = P3(0): PList(13) = P3(1)
PList(14) = P4(0): PList(15) = P4(1)
PList(16) = P5(0): PList(17) = P5(1)
PList(18) = P6(0): PList(19) = P6(1)
Dim PL As AcadLWPolyline
Set PL = ThisDrawing.ModelSpace.AddLightWeightPolyline(PList)
Dim i As Integer
For i = 0 To 9
PL.SetWidth i, 35, 35
Next
PL.color = acByLayer
PL.Layer = "正筋"
L.Delete
End Function
Sub DrawZhengJin()
On Error Resume Next
Dim L As AcadLayer
Set L = AddLayer("正筋")
L.color = 10
Dim P1 As Variant
Dim P2 As Variant
P1 = ThisDrawing.Utility.GetPoint(, "钢筋起点:")
P2 = ThisDrawing.Utility.GetPoint(P1, "钢筋终点:")
ZhengJin P1, P2
End Sub
'******************************************************************
'*******************负筋****************************************
Function FuJin(P1 As Variant, P2 As Variant)
Dim PList(0 To 7) As Double
Dim P3 As Variant
Dim A As Double
Dim L As AcadLine
Set L = ThisDrawing.ModelSpace.AddLine(P1, P2)
A = L.angle
P3 = GetPointAR(P1, A - 90 / 180 * Atn(1) * 4, 250)
PList(0) = P3(0): PList(1) = P3(1)
PList(2) = P1(0): PList(3) = P1(1)
P3 = GetPointAR(Point3D(P2(0), P2(1), 0), A - 90 / 180 * Atn(1) * 4, 250)
PList(4) = P2(0): PList(5) = P2(1)
PList(6) = P3(0): PList(7) = P3(1)
Dim PL As AcadLWPolyline
Set PL = ThisDrawing.ModelSpace.AddLightWeightPolyline(PList)
Dim i As Integer
For i = 0 To 3
PL.SetWidth i, 35, 35
Next
PL.Layer = "负筋"
PL.color = acByLayer
L.Delete
End Function
Sub DrawFuJin()
On Error Resume Next
Dim L As AcadLayer
Set L = AddLayer("负筋")
L.color = 14
Dim P1 As Variant
Dim P2 As Variant
P1 = ThisDrawing.Utility.GetPoint(, "钢筋起点:")
P2 = ThisDrawing.Utility.GetPoint(P1, "钢筋终点:")
FuJin P1, P2
End Sub
'******************************************************************
'*******************拉筋****************************************
Function LaJin(P1 As Variant, P2 As Variant)
Dim PList(0 To 19) As Double
Dim P3 As Variant
Dim P4 As Variant
Dim P5 As Variant
Dim P6 As Variant
Dim A As Double
Dim L As AcadLine
Set L = ThisDrawing.ModelSpace.AddLine(P1, P2)
A = L.angle
P3 = GetPointAR(P1, A + 150 / 180 * Atn(1) * 4, 50)
P4 = GetPointAR(P3, A + 90 / 180 * Atn(1) * 4, 50)
P5 = GetPointAR(P4, A + 30 / 180 * Atn(1) * 4, 50)
P6 = GetPointAR(P5, A + 0 / 180 * Atn(1) * 4, 100)
PList(0) = P6(0): PList(1) = P6(1)
PList(2) = P5(0): PList(3) = P5(1)
PList(4) = P4(0): PList(5) = P4(1)
PList(6) = P3(0): PList(7) = P3(1)
PList(8) = P1(0): PList(9) = P1(1)
P3 = GetPointAR(Point3D(P2(0), P2(1), 0), A - 30 / 180 * Atn(1) * 4, 50)
P4 = GetPointAR(P3, A - 90 / 180 * Atn(1) * 4, 50)
P5 = GetPointAR(P4, A - 150 / 180 * Atn(1) * 4, 50)
P6 = GetPointAR(P5, A - 180 / 180 * Atn(1) * 4, 100)
PList(10) = P2(0): PList(11) = P2(1)
PList(12) = P3(0): PList(13) = P3(1)
PList(14) = P4(0): PList(15) = P4(1)
PList(16) = P5(0): PList(17) = P5(1)
PList(18) = P6(0): PList(19) = P6(1)
Dim PL As AcadLWPolyline
Set PL = ThisDrawing.ModelSpace.AddLightWeightPolyline(PList)
Dim i As Integer
For i = 0 To 9
PL.SetWidth i, 35, 35
Next
PL.color = acByLayer
PL.Layer = "钢筋"
L.Delete
End Function
Sub DrawLaJin()
On Error Resume Next
Dim L As AcadLayer
Set L = AddLayer("钢筋")
L.color = 14
Dim P1 As Variant
Dim P2 As Variant
P1 = ThisDrawing.Utility.GetPoint(, "钢筋起点:")
P2 = ThisDrawing.Utility.GetPoint(P1, "钢筋终点:")
LaJin P1, P2
End Sub
'******************************************************************
'********************钢筋断面************************************
Sub YuanDian()
On Error Resume Next
On Error Resume Next
Dim L As AcadLayer
Set L = AddLayer("钢筋")
L.color = 14
'填充面域
Dim TC_Entity(0 To 0) As AcadEntity
Dim TC As AcadHatch
Dim TC_Name As String
Dim TC_Type As Long
Dim TC_Associativity As Boolean
TC_Name = "SOLID"
TC_Type = 0
TC_Associativity = True
Set TC = ThisDrawing.ModelSpace.AddHatch(TC_Type, TC_Name, TC_Associativity)
Dim P As Variant
P = ThisDrawing.Utility.GetPoint(, "请点取位置:")
Dim C As AcadCircle
Set C = ThisDrawing.ModelSpace.AddCircle(P, 35)
Set TC_Entity(0) = C
TC.AppendInnerLoop (TC_Entity)
TC.Evaluate
TC.Layer = "钢筋"
TC.color = acByLayer
C.Delete
End Sub
'*******************************************************************
'********************徒手画筋************************************
Sub TuShouHuaJin()
On Error Resume Next
Dim L As AcadLayer
Set L = AddLayer("钢筋")
L.color = 14
ThisDrawing.SetVariable "PLINEWID", 35
ThisDrawing.SendCommand "PLine "
JiFa = True '留在AcadDocument_EndCommand中处理
End Sub
'*******************************************************************
'*********************90度弯钩****************************************
Sub Draw90G()
Dim PL As AcadLWPolyline
Dim PickPnt As Variant
Dim i As Integer
On Error Resume Next
ThisDrawing.Utility.GetEntity PL, PickPnt, "请选择一根多段线"
Dim P As Variant '多义线顶点数组
P = PL.Coordinates
Dim PS As AcadPoint
Dim PE As AcadPoint
Set PS = ThisDrawing.ModelSpace.AddPoint(Point3D(P(0), P(1), 0)) '用蓝色点标明多段线的起点
PS.color = acBlue
Dim L As Integer
L = UBound(P)
Set PE = ThisDrawing.ModelSpace.AddPoint(Point3D(P(L - 1), P(L), 0)) '用红色点标明多段线的终点
PE.color = acGreen
Prompt "红色点为多段线终点，蓝色点为多段线起点." & vbCr
Dim TempPoint1 As Variant '点取多义线上的一点，此点将在添加点（TempPoint2）之前
Dim TempPoint2 As Variant '点取一点，此点就是要添加的点，在多义线中排在TempPoint1点之后
Dim L1 As Double
Dim L2 As Double
L1 = P2PDistance(PickPnt, Point3D(P(0), P(1), 0))
L2 = P2PDistance(PickPnt, Point3D(P(L - 1), P(L), 0))
Dim PList() As Double
Dim XPL As AcadLWPolyline '重新绘制多段线
ReDim PList(L + 2)
Dim PJ As Variant '增加得一个点
Dim A As Double
Dim Line As AcadLine
If L1 < L2 Then
'在起点添加弯钩
Set Line = ThisDrawing.ModelSpace.AddLine(Point3D(P(0), P(1), 0), Point3D(P(2), P(3), 0))
A = Line.angle
PJ = GetPointAR(Point3D(P(0), P(1), 0), A + 90 / 180 * Atn(1) * 4, 250)
PList(0) = PJ(0): PList(1) = PJ(1)
For i = 2 To L + 2
PList(i) = P(i - 2)
Next
Else
Set Line = ThisDrawing.ModelSpace.AddLine(Point3D(P(L - 3), P(L - 2), 0), Point3D(P(L - 1), P(L), 0))
A = Line.angle
'在终点添加弯钩
PJ = GetPointAR(Point3D(P(L - 1), P(L), 0), A + 90 / 180 * Atn(1) * 4, 250)
For i = 0 To L
PList(i) = P(i)
Next
PList(L + 1) = PJ(0): PList(L + 2) = PJ(1)
End If
L = L + 2
'绘制新得PL线
Set XPL = ThisDrawing.ModelSpace.AddLightWeightPolyline(PList)
'特性匹配多段线
XPL.Layer = PL.Layer
XPL.color = PL.color
For i = 0 To Int(L / 2) - 1
XPL.SetWidth i, 35, 35
Next
If PL.Closed = True Then XPL.Closed = True
'删除原来的线和起点及终点
PL.Delete
Line.Delete
PS.Delete
PE.Delete
End Sub
'*******************************************************************
'*********************135度弯钩****************************************
Sub Draw135G()
Dim PL As AcadLWPolyline
Dim PickPnt As Variant
Dim i As Integer
On Error Resume Next
ThisDrawing.Utility.GetEntity PL, PickPnt, "请选择一根多段线"
Dim P As Variant '多义线顶点数组
P = PL.Coordinates
Dim PS As AcadPoint
Dim PE As AcadPoint
Set PS = ThisDrawing.ModelSpace.AddPoint(Point3D(P(0), P(1), 0)) '用蓝色点标明多段线的起点
PS.color = acBlue
Dim L As Integer
L = UBound(P)
Set PE = ThisDrawing.ModelSpace.AddPoint(Point3D(P(L - 1), P(L), 0)) '用红色点标明多段线的终点
PE.color = acGreen
Prompt "红色点为多段线终点，蓝色点为多段线起点." & vbCr
Dim TempPoint1 As Variant '点取多义线上的一点，此点将在添加点（TempPoint2）之前
Dim TempPoint2 As Variant '点取一点，此点就是要添加的点，在多义线中排在TempPoint1点之后
Dim L1 As Double
Dim L2 As Double
L1 = P2PDistance(PickPnt, Point3D(P(0), P(1), 0))
L2 = P2PDistance(PickPnt, Point3D(P(L - 1), P(L), 0))
Dim PList() As Double
Dim XPL As AcadLWPolyline '重新绘制多段线
ReDim PList(L + 2)
Dim PJ As Variant '增加得一个点
Dim A As Double
Dim Line As AcadLine
If L1 < L2 Then
'在起点添加弯钩
Set Line = ThisDrawing.ModelSpace.AddLine(Point3D(P(0), P(1), 0), Point3D(P(2), P(3), 0))
A = Line.angle
PJ = GetPointAR(Point3D(P(0), P(1), 0), A + 45 / 180 * Atn(1) * 4, 250)
PList(0) = PJ(0): PList(1) = PJ(1)
For i = 2 To L + 2
PList(i) = P(i - 2)
Next
Else
Set Line = ThisDrawing.ModelSpace.AddLine(Point3D(P(L - 3), P(L - 2), 0), Point3D(P(L - 1), P(L), 0))
A = Line.angle
'在终点添加弯钩
PJ = GetPointAR(Point3D(P(L - 1), P(L), 0), A + 135 / 180 * Atn(1) * 4, 250)
For i = 0 To L
PList(i) = P(i)
Next
PList(L + 1) = PJ(0): PList(L + 2) = PJ(1)
End If
L = L + 2
'绘制新得PL线
Set XPL = ThisDrawing.ModelSpace.AddLightWeightPolyline(PList)
'特性匹配多段线
XPL.Layer = PL.Layer
XPL.color = PL.color
For i = 0 To Int(L / 2) - 1
XPL.SetWidth i, 35, 35
Next
If PL.Closed = True Then XPL.Closed = True
'删除原来的线和起点及终点
PL.Delete
Line.Delete
PS.Delete
PE.Delete
End Sub
'*******************************************************************
'*********************180度圆弯钩****************************************
Sub Draw180G()
Dim PL As AcadLWPolyline
Dim PickPnt As Variant
Dim i As Integer
'On Error Resume Next
ThisDrawing.Utility.GetEntity PL, PickPnt, "请选择一根多段线"
Dim P As Variant '多义线顶点数组
P = PL.Coordinates
Dim PS As AcadPoint
Dim PE As AcadPoint
Set PS = ThisDrawing.ModelSpace.AddPoint(Point3D(P(0), P(1), 0)) '用蓝色点标明多段线的起点
PS.color = acBlue
Dim L As Integer
L = UBound(P)
Set PE = ThisDrawing.ModelSpace.AddPoint(Point3D(P(L - 1), P(L), 0)) '用红色点标明多段线的终点
PE.color = acGreen
Prompt "红色点为多段线终点，蓝色点为多段线起点." & vbCr
Dim TempPoint1 As Variant '点取多义线上的一点，此点将在添加点（TempPoint2）之前
Dim TempPoint2 As Variant '点取一点，此点就是要添加的点，在多义线中排在TempPoint1点之后
Dim L1 As Double
Dim L2 As Double
L1 = P2PDistance(PickPnt, Point3D(P(0), P(1), 0))
L2 = P2PDistance(PickPnt, Point3D(P(L - 1), P(L), 0))
Dim PList() As Double
Dim XPL As AcadLWPolyline '重新绘制多段线
ReDim PList(L + 8)
Dim PJ1 As Variant '增加得一个点
Dim PJ2 As Variant
Dim PJ3 As Variant
Dim PJ4 As Variant
Dim A As Double
Dim Line As AcadLine
If L1 < L2 Then
Set Line = ThisDrawing.ModelSpace.AddLine(Point3D(P(0), P(1), 0), Point3D(P(2), P(3), 0))
A = Line.angle
'在起点添加弯钩
' PJ2--------PJ1
' PJ3
' PJ4
' P(0)------------------------------------
PJ2 = GetPointAR(Point3D(P(0), P(1), 0), A + 90 / 180 * Atn(1) * 4, 100)
PList(2) = PJ2(0): PList(3) = PJ2(1)
PJ1 = GetPointAR(Point3D(PJ2(0), PJ2(1), 0), A + 0 / 180 * Atn(1) * 4, 100)
PList(0) = PJ1(0): PList(1) = PJ1(1)
PJ3 = GetPointAR(Point3D(PJ2(0), PJ2(1), 0), A + 210 / 180 * Atn(1) * 4, 50)
PList(4) = PJ3(0): PList(5) = PJ3(1)
PJ4 = GetPointAR(Point3D(PJ3(0), PJ3(1), 0), A - 90 / 180 * Atn(1) * 4, 50)
PList(6) = PJ4(0): PList(7) = PJ4(1)
For i = 8 To L + 8
PList(i) = P(i - 8)
Next
Else
Set Line = ThisDrawing.ModelSpace.AddLine(Point3D(P(L - 3), P(L - 2), 0), Point3D(P(L - 1), P(L), 0))
A = Line.angle
'在终点添加弯钩
' PJ2-------- PJ1
' PJ3
' PJ4
'-----------------------P(0)
PJ1 = GetPointAR(Point3D(P(L - 1), P(L), 0), A + 90 / 180 * Atn(1) * 4, 100)
PList(L + 5) = PJ1(0): PList(L + 6) = PJ1(1)
PJ2 = GetPointAR(Point3D(PJ1(0), PJ1(1), 0), A + 180 / 180 * Atn(1) * 4, 100)
PList(L + 7) = PJ2(0): PList(L + 8) = PJ2(1)
PJ3 = GetPointAR(Point3D(PJ1(0), PJ1(1), 0), A - 30 / 180 * Atn(1) * 4, 50)
PList(L + 3) = PJ3(0): PList(L + 4) = PJ3(1)
PJ4 = GetPointAR(Point3D(PJ3(0), PJ3(1), 0), A - 90 / 180 * Atn(1) * 4, 50)
PList(L + 1) = PJ4(0): PList(L + 2) = PJ4(1)
For i = 0 To L
PList(i) = P(i)
Next
End If
L = L + 8
'绘制新得PL线
Set XPL = ThisDrawing.ModelSpace.AddLightWeightPolyline(PList)
'特性匹配多段线
XPL.Layer = PL.Layer
XPL.color = PL.color
For i = 0 To Int(L / 2) - 1
XPL.SetWidth i, 35, 35
Next
If PL.Closed = True Then XPL.Closed = True
'删除原来的线和起点及终点
PL.Delete
Line.Delete
PS.Delete
PE.Delete
End Sub
'*******************************************************************
Sub Draw90G()
Dim PL As AcadLWPolyline
Dim PickPnt As Variant
Dim i As Integer
On Error Resume Next
ThisDrawing.Utility.GetEntity PL, PickPnt, "请选择一根多段线"
Dim P As Variant '多义线顶点数组
P = PL.Coordinates
Dim PS As AcadPoint
Dim PE As AcadPoint
Set PS = ThisDrawing.ModelSpace.AddPoint(Point3D(P(0), P(1), 0)) '用蓝色点标明多段线的起点
PS.color = acBlue
Dim L As Integer
L = UBound(P)
Set PE = ThisDrawing.ModelSpace.AddPoint(Point3D(P(L - 1), P(L), 0)) '用红色点标明多段线的终点
PE.color = acGreen
Prompt "红色点为多段线终点，蓝色点为多段线起点." & vbCr
Dim TempPoint1 As Variant '点取多义线上的一点，此点将在添加点（TempPoint2）之前
Dim TempPoint2 As Variant '点取一点，此点就是要添加的点，在多义线中排在TempPoint1点之后
Dim L1 As Double
Dim L2 As Double
L1 = P2PDistance(PickPnt, Point3D(P(0), P(1), 0))
L2 = P2PDistance(PickPnt, Point3D(P(L - 1), P(L), 0))
Dim PList() As Double
Dim XPL As AcadLWPolyline '重新绘制多段线
ReDim PList(L + 2)
Dim PJ As Variant '增加得一个点
Dim A As Double
Dim Line As AcadLine
If L1 < L2 Then
'在起点添加弯钩
Set Line = ThisDrawing.ModelSpace.AddLine(Point3D(P(0), P(1), 0), Point3D(P(2), P(3), 0))
A = Line.angle
PJ = GetPointAR(Point3D(P(0), P(1), 0), A + 90 / 180 * Atn(1) * 4, 250)
PList(0) = PJ(0): PList(1) = PJ(1)
For i = 2 To L + 2
PList(i) = P(i - 2)
Next
Else
Set Line = ThisDrawing.ModelSpace.AddLine(Point3D(P(L - 3), P(L - 2), 0), Point3D(P(L - 1), P(L), 0))
A = Line.angle
'在终点添加弯钩
PJ = GetPointAR(Point3D(P(L - 1), P(L), 0), A + 90 / 180 * Atn(1) * 4, 250)
For i = 0 To L
PList(i) = P(i)
Next
PList(L + 1) = PJ(0): PList(L + 2) = PJ(1)
End If
L = L + 2
'绘制新得PL线
Set XPL = ThisDrawing.ModelSpace.AddLightWeightPolyline(PList)
'特性匹配多段线
XPL.Layer = PL.Layer
XPL.color = PL.color
For i = 0 To Int(L / 2) - 1
XPL.SetWidth i, 35, 35
Next
If PL.Closed = True Then XPL.Closed = True
'删除原来的线和起点及终点
PL.Delete
Line.Delete
PS.Delete
PE.Delete
End Sub
'*******************************************************************
'*********************135度弯钩****************************************
Sub Draw135G()
Dim PL As AcadLWPolyline
Dim PickPnt As Variant
Dim i As Integer
On Error Resume Next
ThisDrawing.Utility.GetEntity PL, PickPnt, "请选择一根多段线"
Dim P As Variant '多义线顶点数组
P = PL.Coordinates
Dim PS As AcadPoint
Dim PE As AcadPoint
Set PS = ThisDrawing.ModelSpace.AddPoint(Point3D(P(0), P(1), 0)) '用蓝色点标明多段线的起点
PS.color = acBlue
Dim L As Integer
L = UBound(P)
Set PE = ThisDrawing.ModelSpace.AddPoint(Point3D(P(L - 1), P(L), 0)) '用红色点标明多段线的终点
PE.color = acGreen
Prompt "红色点为多段线终点，蓝色点为多段线起点." & vbCr
Dim TempPoint1 As Variant '点取多义线上的一点，此点将在添加点（TempPoint2）之前
Dim TempPoint2 As Variant '点取一点，此点就是要添加的点，在多义线中排在TempPoint1点之后
Dim L1 As Double
Dim L2 As Double
L1 = P2PDistance(PickPnt, Point3D(P(0), P(1), 0))
L2 = P2PDistance(PickPnt, Point3D(P(L - 1), P(L), 0))
Dim PList() As Double
Dim XPL As AcadLWPolyline '重新绘制多段线
ReDim PList(L + 2)
Dim PJ As Variant '增加得一个点
Dim A As Double
Dim Line As AcadLine
If L1 < L2 Then
'在起点添加弯钩
Set Line = ThisDrawing.ModelSpace.AddLine(Point3D(P(0), P(1), 0), Point3D(P(2), P(3), 0))
A = Line.angle
PJ = GetPointAR(Point3D(P(0), P(1), 0), A + 45 / 180 * Atn(1) * 4, 250)
PList(0) = PJ(0): PList(1) = PJ(1)
For i = 2 To L + 2
PList(i) = P(i - 2)
Next
Else
Set Line = ThisDrawing.ModelSpace.AddLine(Point3D(P(L - 3), P(L - 2), 0), Point3D(P(L - 1), P(L), 0))
A = Line.angle
'在终点添加弯钩
PJ = GetPointAR(Point3D(P(L - 1), P(L), 0), A + 135 / 180 * Atn(1) * 4, 250)
For i = 0 To L
PList(i) = P(i)
Next
PList(L + 1) = PJ(0): PList(L + 2) = PJ(1)
End If
L = L + 2
'绘制新得PL线
Set XPL = ThisDrawing.ModelSpace.AddLightWeightPolyline(PList)
'特性匹配多段线
XPL.Layer = PL.Layer
XPL.color = PL.color
For i = 0 To Int(L / 2) - 1
XPL.SetWidth i, 35, 35
Next
If PL.Closed = True Then XPL.Closed = True
'删除原来的线和起点及终点
PL.Delete
Line.Delete
PS.Delete
PE.Delete
End Sub
'*******************************************************************
'*********************180度圆弯钩****************************************
Sub Draw180G()
Dim PL As AcadLWPolyline
Dim PickPnt As Variant
Dim i As Integer
'On Error Resume Next
ThisDrawing.Utility.GetEntity PL, PickPnt, "请选择一根多段线"
Dim P As Variant '多义线顶点数组
P = PL.Coordinates
Dim PS As AcadPoint
Dim PE As AcadPoint
Set PS = ThisDrawing.ModelSpace.AddPoint(Point3D(P(0), P(1), 0)) '用蓝色点标明多段线的起点
PS.color = acBlue
Dim L As Integer
L = UBound(P)
Set PE = ThisDrawing.ModelSpace.AddPoint(Point3D(P(L - 1), P(L), 0)) '用红色点标明多段线的终点
PE.color = acGreen
Prompt "红色点为多段线终点，蓝色点为多段线起点." & vbCr
Dim TempPoint1 As Variant '点取多义线上的一点，此点将在添加点（TempPoint2）之前
Dim TempPoint2 As Variant '点取一点，此点就是要添加的点，在多义线中排在TempPoint1点之后
Dim L1 As Double
Dim L2 As Double
L1 = P2PDistance(PickPnt, Point3D(P(0), P(1), 0))
L2 = P2PDistance(PickPnt, Point3D(P(L - 1), P(L), 0))
Dim PList() As Double
Dim XPL As AcadLWPolyline '重新绘制多段线
ReDim PList(L + 8)
Dim PJ1 As Variant '增加得一个点
Dim PJ2 As Variant
Dim PJ3 As Variant
Dim PJ4 As Variant
Dim A As Double
Dim Line As AcadLine
If L1 < L2 Then
Set Line = ThisDrawing.ModelSpace.AddLine(Point3D(P(0), P(1), 0), Point3D(P(2), P(3), 0))
A = Line.angle
'在起点添加弯钩
' PJ2--------PJ1
' PJ3
' PJ4
' P(0)------------------------------------
PJ2 = GetPointAR(Point3D(P(0), P(1), 0), A + 90 / 180 * Atn(1) * 4, 100)
PList(2) = PJ2(0): PList(3) = PJ2(1)
PJ1 = GetPointAR(Point3D(PJ2(0), PJ2(1), 0), A + 0 / 180 * Atn(1) * 4, 100)
PList(0) = PJ1(0): PList(1) = PJ1(1)
PJ3 = GetPointAR(Point3D(PJ2(0), PJ2(1), 0), A + 210 / 180 * Atn(1) * 4, 50)
PList(4) = PJ3(0): PList(5) = PJ3(1)
PJ4 = GetPointAR(Point3D(PJ3(0), PJ3(1), 0), A - 90 / 180 * Atn(1) * 4, 50)
PList(6) = PJ4(0): PList(7) = PJ4(1)
For i = 8 To L + 8
PList(i) = P(i - 8)
Next
Else
Set Line = ThisDrawing.ModelSpace.AddLine(Point3D(P(L - 3), P(L - 2), 0), Point3D(P(L - 1), P(L), 0))
A = Line.angle
'在终点添加弯钩
' PJ2-------- PJ1
' PJ3
' PJ4
'-----------------------P(0)
PJ1 = GetPointAR(Point3D(P(L - 1), P(L), 0), A + 90 / 180 * Atn(1) * 4, 100)
PList(L + 5) = PJ1(0): PList(L + 6) = PJ1(1)
PJ2 = GetPointAR(Point3D(PJ1(0), PJ1(1), 0), A + 180 / 180 * Atn(1) * 4, 100)
PList(L + 7) = PJ2(0): PList(L + 8) = PJ2(1)
PJ3 = GetPointAR(Point3D(PJ1(0), PJ1(1), 0), A - 30 / 180 * Atn(1) * 4, 50)
PList(L + 3) = PJ3(0): PList(L + 4) = PJ3(1)
PJ4 = GetPointAR(Point3D(PJ3(0), PJ3(1), 0), A - 90 / 180 * Atn(1) * 4, 50)
PList(L + 1) = PJ4(0): PList(L + 2) = PJ4(1)
For i = 0 To L
PList(i) = P(i)
Next
End If
L = L + 8
'绘制新得PL线
Set XPL = ThisDrawing.ModelSpace.AddLightWeightPolyline(PList)
'特性匹配多段线
XPL.Layer = PL.Layer
XPL.color = PL.color
For i = 0 To Int(L / 2) - 1
XPL.SetWidth i, 35, 35
Next
If PL.Closed = True Then XPL.Closed = True
'删除原来的线和起点及终点
PL.Delete
Line.Delete
PS.Delete
PE.Delete
End Sub
'*******************************************************************
[本日志由 tiancao1001 于 2008-08-14 10:37 PM 编辑]
|
|
暂时没有评论
| 发表评论 - 不要忘了输入验证码哦！ |