任何方式快速插入块确保插入点位于1个圆的中心，然后绘制一个圆7.0个单位。使用旋转器旋转块。交叉点的角度正确。
我的版本绘制了许多块用于检查。
ContinBoss77查看代码，它会旋转块以适应。
我知道，但它不适用于普通的Autocad commando 看看这个
键入VBAMAN New pick the global1，visual basic编辑器，双击global1左上角的“代码”窗口应打开“粘贴代码并保存”以查看结果使用RUN sub/userform try 1作为间隔。更多的是关于如何做的方法。您还需要一个新的顶点lsp来计算显示的顶点数和间距。目前的时间是一个完整解决方案的问题。
Sub draw_vehicle()
Dim CAR As String
Dim arcobj As AcadArc
Dim oPoly As AcadEntity
Dim blkobj As AcadEntity
Dim retVal As Variant
Dim snapPt As Variant
Dim oCoords As Variant
Dim blpnt1() As Variant
ReDim blpnt1(100)
Dim blpnt2() As Variant
Dim vertPt(0 To 2) As Double
Dim Pt1(0 To 2) As Double
Dim Pt2(0 To 2) As Double
Dim newPt(0 To 2) As Double
Dim iCnt, w, x, y, z As Integer
Dim cRad, interval, blkangle As Double
Dim circObj As AcadCircle
Dim lineObj As AcadLine
On Error GoTo Something_Wrong
For Each Item In ThisDrawing.Blocks
If Item.Name = "temp" Then GoTo continue_on
Next Item
' exits out of program
GoTo Exit_out
continue_on:
w = 1
ThisDrawing.Utility.GetEntity oPoly, snapPt, vbCr & "Select polyline :"
If oPoly.ObjectName = "AcDbPolyline" Then
oCoords = oPoly.Coordinates
Else: MsgBox "This object is not a polyline!"
Exit Sub
End If
interval = CDbl(InputBox("Enter interval:", , 1#))
If interval < 1 Then
interval = 1
End If
For iCnt = 0 To UBound(oCoords) - 2 Step 2
Pt1(0) = oCoords(iCnt): Pt1(1) = oCoords(iCnt + 1): Pt1(2) = 0#
newPt(0) = Pt1(0)
newPt(1) = Pt1(1)
newPt(2) = 0#
iCnt = iCnt + 2
Pt2(0) = oCoords(iCnt): Pt2(1) = oCoords(iCnt + 1): Pt2(2) = 0#
x = (Pt1(0) - Pt2(0)) / interval
y = (Pt1(1) - Pt2(1)) / interval
'reset back 2 values
iCnt = iCnt - 2
cRad = 7#
startang = 4.7123889
endang = 1.57079632
CAR = "temp"
For z = 1 To interval
vertPt(0) = newPt(0) - x
vertPt(1) = newPt(1) - y
vertPt(2) = 0#
'blpnt1(w) = vertPt
Set arcobj = ThisDrawing.ModelSpace.AddArc(vertPt, cRad, endang, startang)
retval2 = arcobj.IntersectWith(oPoly, acExtendOtherEntity)
arcobj.Delete
Set arcobj = Nothing
blkangle = ThisDrawing.Utility.AngleFromXAxis(retval2, vertPt)
Set blkobj = ThisDrawing.ModelSpace.InsertBlock(vertPt, CAR, 1#, 1#, 1#, blkangle)
Set blkobj = Nothing
w = w + 1
newPt(0) = newPt(0) - x
newPt(1) = newPt(1) - y
Next z
Next iCnt
Something_Wrong:
MsgBox Err.Description
Exit_out:
End Sub
页:
1
[2]