> ЛАРИСА
Я не спец в VBA, но почему б не объединить повторяющийся код?
Sub MyAddLine(ptStart() As Double, ptEnd() As Double, Optional sLineType As String = "DASHDOT", Optional dLineTypeScale As Integer = 7)
Dim oLine As AcadLine
Set oLine = ThisDrawing.ModelSpace.AddLine(ptStart, ptEnd)
oLine.Linetype = sLineType
oLine.LinetypeScale = dLineTypeScale
oLine.Update
End Sub
Sub MyAddLWPline(ptlist() As Double, Optional lColor As Integer = acRed, Optional bIsCLosed As Boolean = True)
Dim oLWPline As AcadLWPolyline
On Error Resume Next
Set oLWPline = ThisDrawing.ModelSpace.AddLightWeightPolyline(ptlist)
oLWPline.color = lColor
oLWPline.Closed = bIsCLosed
End Sub
Sub MyAddDimRot(ptStart() As Double, ptEnd() As Double, ptLoc() As Double, lAngle As Double, lLinearScale As Long)
Dim oDimRot As AcadDimRotated
oDimRot = ThisDrawing.ModelSpace.AddDimRotated(ptStart, ptEnd, ptLoc, lAngle)
oDimRot.LinearScaleFactor = lLinearScale
End Sub
Sub MyAddCircle(ptCenter() As Double, lRadius As Long, Optional lColor As Integer = acRed)
Dim oCircle As AcadCircle
On Error Resume Next
oCircle = ThisDrawing.ModelSpace.AddCircle(ptCenter, lRadius)
'oCircle.TrueColor = lColor
End Sub
Тогда в первом приближении основной код станет подобным:
If K > 0 Then
MyAddLine pl11, pl21: MyAddLine pl31, pl41: MyAddLine pl12, pl22
MyAddLine pl32, pl42: MyAddLine PL13, PL23: MyAddLine PL33, PL43
MyAddLine PL14, PL24: MyAddLine PL34, PL44
MyAddLWPline pts1: MyAddLWPline pts2: MyAddLWPline pts3: MyAddLWPline pts4
MyAddDimRot point2, pl21, location5, rotAngle, mb: MyAddDimRot point2, pl22, location5, rotAngle, mb
MyAddDimRot pl42, point4, location6, rotAngle1, mb: MyAddDimRot PL43, point4, location6, rotAngle1, mb
MyAddDimRot point6, point7, location7, rotAngle1, mb: MyAddDimRot point8, point7, location8, rotAngle, mb
ElseIf Db > 0 Then
MyAddLine pl11, pl21: MyAddLine pl31, pl41: MyAddLine pl12, pl22: MyAddLine pl32, pl42
MyAddLine PL13, PL23: MyAddLine PL33, PL43: MyAddLine PL14, PL24: MyAddLine PL34, PL44
MyAddCircle centerPoint1, Radius: MyAddCircle centerPoint2, Radius: MyAddCircle centerPoint3, Radius
MyAddCircle centerPoint4, Radius
MyAddDimRot pl21, point2, location5, rotAngle, mb: MyAddDimRot point2, pl22, location5, rotAngle, mb
MyAddDimRot pl42, point4, location6, rotAngle1, mb: MyAddDimRot point4, PL43, location6, rotAngle1, mb
Else
SendKeys "{Esc}"
End IfДальше. У примитивов AcadLine, AcadLWPolyline, AcadDimRotated и AcadCircle нет, по-моему, свойства Color. То есть изменение цвета не произойдет.
И в дополнение. По идее можно попробовать сделать массивы точек (правда, как в VBA с этим дело обстоит, я не очень - скорее всего, придется делать двумерные массивы) и передавать их.
