Break a line

I want to break a line an insert a block in the hole.

Is there anyone who can tell me how to do that.

Thanks


Carsten

 

Prompt user to select original line and break point.
Save original line information (endpoints, layer, linetype, etc.)
Erase the original line.
Calculate the break gap (width of block, line angle, etc.)
Calculate the endpoints of the two new lines.
Add the new lines to the database.
Add an instance of the block to the database.

 

I've already done that for schematic symbols. This sub allows you to place
blocks and then select them all at once and breaks all the lines. If this is
what you're looking for, I'll supply the other subs that it calls.


Public Sub BreakLineByBlock()
'Break lines around block insertions.

Dim str As String
Dim strHandle As String
Dim objLine As AcadLine
Dim objLine1 As AcadLine
Dim objLine2 As AcadLine
Dim objSubEnt As AcadEntity
Dim objBlock As AcadBlockReference
Dim ssBlocks As AcadSelectionSet
Dim ssLines As AcadSelectionSet
Dim vSubEnts As Variant
Dim vMinPoint As Variant
Dim vMaxPoint As Variant
Dim vIntPoint As Variant
Dim vCPoint As Variant 'compare point
Dim vSPoint As Variant 'start point
Dim vSPoint1 As Variant 'start point prime
Dim vEPoint As Variant 'end point
Dim vEPoint1 As Variant 'end point prime
Dim dPickPoint(0 To 1) As Double
Dim dPoint(0 To 2) As Double
Dim dDistSP As Double 'shortest distance from start point
Dim dDistEP As Double 'shortest distance from end point
Dim dDistC As Double 'comparison distance
Dim dVertList(0 To 7) As Double
Dim iL As Integer 'lines counter
Dim iP As Integer 'points counter
Dim iSE As Integer 'sub entities counter
Dim iCntL As Integer 'line count
Dim iCntP As Integer 'point count
Dim iCntSE As Integer 'sub entity count
Dim PtsInsideBB As Integer '0=none: 1=StartPoint: 2=EndPoint
Dim varFilterType(0) As Integer
Dim varFilterData(0) As Variant
Dim vFT As Variant
Dim vFD As Variant
Dim BBpoints(0 To 4) As Point 'Bounding box points list
Dim Cpoint As Point 'compare point

On Error GoTo Err_Control
'Set up undo for this command
ThisDrawing.StartUndoMark
'get blocks
ThisDrawing.Utility.Prompt "Lines will be broken around selected
blocks."
Set ssBlocks = toolbox.ejSelectionSets.GetSS_BlockFilter
For Each objBlock In ssBlocks
'Use the block's bounding box to select ents that intersect with it.
objBlock.GetBoundingBox vMinPoint, vMaxPoint
BBpoints(0).X = vMinPoint(0): BBpoints(0).y = vMinPoint(1)
BBpoints(1).X = vMaxPoint(0): BBpoints(1).y = vMinPoint(1)
BBpoints(2).X = vMaxPoint(0): BBpoints(2).y = vMaxPoint(1)
BBpoints(3).X = vMinPoint(0): BBpoints(3).y = vMaxPoint(1)
BBpoints(4).X = vMinPoint(0): BBpoints(4).y = vMinPoint(1)
toolbox.ejSelectionSets.AddSelectionSet ssLines, "ssLines"
ssLines.Clear
varFilterType(0) = 0: varFilterData(0) = "LINE"
vFT = varFilterType: vFD = varFilterData
ssLines.Select acSelectionSetCrossing, vMaxPoint, vMinPoint, vFT,
vFD
'get subent's of block
vSubEnts = objBlock.Explode
iCntSE = UBound(vSubEnts)
For Each objLine In ssLines
'Compare subentity intersection points with line start and
'end points to determine new line segment. Points creating the
'shortest line segments should be the outer limits of the block.
'Any other intersections are inside the block and are discarded.
' Get reference info.
vSPoint = objLine.StartPoint
vEPoint = objLine.EndPoint
dDistSP = toolbox.ejMath.XYZDistance(vSPoint, vEPoint)
dDistEP = toolbox.ejMath.XYZDistance(vEPoint, vSPoint)
Cpoint.X = vSPoint(0): Cpoint.y = vSPoint(1)
If toolbox.ejMath.InsidePolygon(BBpoints, Cpoint) = True Then
PtsInsideBB = PtsInsideBB Or 1
Cpoint.X = vEPoint(0): Cpoint.y = vEPoint(1)
If toolbox.ejMath.InsidePolygon(BBpoints, Cpoint) = True Then
PtsInsideBB = PtsInsideBB Or 2
For iSE = 0 To iCntSE
'get list of points where the line intersects with the block
Set objSubEnt = vSubEnts(iSE)
vIntPoint = objSubEnt.IntersectWith(objLine, acExtendNone)
'Compare to line segment lengths.
If UBound(vIntPoint) > -1 Then
iCntP = (UBound(vIntPoint) + 1) / 3
For iP = 1 To iCntP
vCPoint = toolbox.ejMath.Point3D((vIntPoint(iP * 3 -
3)), (vIntPoint(iP * 3 - 2)), (vIntPoint(iP * 3 - 1)))
dDistC = toolbox.ejMath.XYZDistance(vSPoint,
vCPoint)
If dDistC < dDistSP Then
dDistSP = dDistC
vSPoint1 = vCPoint
End If
dDistC = toolbox.ejMath.XYZDistance(vCPoint,
vEPoint)
If dDistC < dDistEP Then
dDistEP = dDistC
vEPoint1 = vCPoint
End If
Next iP
Else
'the array returned by IntersectWith is dimensioned
' (0 To -1) when there are no points.
End If
Next iSE
Select Case Round(objLine.Length, 14)
Case Is = Round(dDistSP, 14)
'line did not intersect the block
'do nothing
Case Is = Round(dDistSP + dDistEP, 14)
'One end of the line is inside the block and does
'not pass through, only one intersection point.
'Determine whether start point or end
'point is in the block and trim it. Assume the smaller
'distance is inside the block.
If dDistSP > dDistEP Then
'the endpoint is in the block
objLine.EndPoint = vEPoint1
objLine.Update
Else
'the startpoint is in the block
objLine.StartPoint = vSPoint1
objLine.Update
End If
Case Else
'enough intersection points exist to break the line
'create two new lines and delete the original
Select Case PtsInsideBB
Case Is = 0 'neither end is inside
If ThisDrawing.ActiveSpace = acModelSpace Then
Set objLine1 =
ThisDrawing.ModelSpace.AddLine(vSPoint, vSPoint1)
Set objLine2 =
ThisDrawing.ModelSpace.AddLine(vEPoint1, vEPoint)
Else
Set objLine1 =
ThisDrawing.PaperSpace.AddLine(vSPoint, vSPoint1)
Set objLine2 =
ThisDrawing.PaperSpace.AddLine(vEPoint1, vEPoint)
'update new lines so that they will be seen
by the next attempt to
'get a selection set
End If
objLine1.Update
objLine2.Update
objLine.Delete
Case Is = 1 'start point is inside
objLine.StartPoint = vEPoint1
objLine.Update
Case Is = 2 'end point is inside
objLine.EndPoint = vSPoint1
objLine.Update
Case Is = 3 'both ends are inside
End Select
PtsInsideBB = 0 'reset for next line
End Select
Next objLine
For iSE = 0 To iCntSE
Set objSubEnt = vSubEnts(iSE)
objSubEnt.Delete
Next iSE
Next objBlock

Exit_Here:
ThisDrawing.EndUndoMark
Exit Sub

Err_Control:
Select Case Err.Number
Case -2147352567
If GetAsyncKeyState(VK_ESCAPE) And &H8000 > 0 Then
Err.Clear
Resume Exit_Here
ElseIf GetAsyncKeyState(VK_LBUTTON) > 0 Then
Err.Clear
Resume
End If
Case Else
MsgBox Err.Description
Resume Exit_Here
End Select
End Sub