社区 › Auto Lisp › VBA-沿Lin的多块

wannabe 发表于 2022-7-6 17:15:46

VBA-沿Lin的多块

请有人告诉我，我应该如何开始生产VBA宏，将由一个窗体操作，允许我选择一个多段线，直线或三维多段线；然后选择一个块；最后选择要插入所选直线、多边形、3dpoly等的块之间的间距。
 
我可能会遇到的一个问题是，我只需要将间距设为X坐标，而需要忽略Z坐标。
 
这张图是一个平面图，就像我上面说的，它有一些轮廓，我需要完全忽略，因此上面的观点。
 
理想情况下，我只想被推到正确的方向上，自己会尽可能多地尝试编写代码（从其他线程来看，我可能需要专家们的更多帮助）。
 
提前谢谢。

borgunit 发表于 2022-7-6 17:48:40

你开始宏的任何部分了吗？我们能看看吗？

wannabe 发表于 2022-7-6 17:58:05

不，我现在还没有开始，只要我复制一个三维多边形并删除其Z坐标，measure命令似乎可以完成所有这些。

BIGAL 发表于 2022-7-6 18:19:07

这段代码根据垂直点之间的间距沿多条直线放置一个块“holden”，只是简单地划分为间隔，您可以修改以使用固定的间隔距离。一个良好的起点。也可以在这里搜索batterticks
 
对于那些感兴趣的人来说，它可以用来检查汽车是否在十字路口触底。
 
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
ReDim blpnt2(100)
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 = "holden" 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 = 2.8
startang = 4.712
endang = 1.57
CAR = "HOLDEN"
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

查看完整版本: VBA-沿Lin的多块