[编程交流] 1条路径上有2个点

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
If ThisDrawing.ActiveSpace = acModelSpace Then
Set Thisspace = ThisDrawing.ModelSpace
Else: Set Thisspace = ThisDrawing.PaperSpace
End If
For Each Item In ThisDrawing.Blocks
If Item.Name = "holden" Then GoTo continue_on
Next Item
' insert holden block
InsertBlock "p:\Autodesk\vba\holdencar.dwg", 0
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! Please do again"
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 = 3.05
startang = 4.71239
endang = 1.570796
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)
Set arcobj = Thisspace.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 = Thisspace.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
GoTo Exit_out
Something_Wrong:
MsgBox Err.Description
Exit_out:
End Sub
Private Sub InsertBlock1()
   '****************************************
   '*** Code from VisibleVisual.com ********
   '****************************************
   InsertBlock "p:\Autodesk\vbaholden.dwg", 0
   'Change the 0 to another value (in degrees) to rotate the block'
   End Sub
   Function InsertBlock(ByVal blockpath As String, ByVal rotation As Double)
   Dim blockobj As AcadBlockReference
   Dim insertionPnt As Variant
   Dim prompt1 As String
   'set rotation Angle
   rotateAngle = rotation
   'rotateAngle = rotation * 3.141592 / 180#
   'Prompt is used to show instructions in the command bar
   prompt1 = vbCrLf & "Enter block insert point: "
 
   'ThisDrawing.ActiveSpace = acModelSpace
 
   insertionPnt = ThisDrawing.Utility.GetPoint(, prompt1)
   Set blockRefObj = ThisDrawing.ModelSpace.InsertBlock(insertionPnt, blockpath, 1#, 1#, 1#, rotateAngle)
   'Change Modelspace into Paperspace to insert the block into Paperspace
 
   End Function