Jump to content



Recommended Posts



I've made one very useful tool. It's called MLINE SPLIT and you guessed what it does. However it doesn't work on first and second vertices (1 and 2 vertex), and that is real mystery for me. Why are these vertices so different than all the other vertices. Below is my VBA code:


Public Sub MLineSplit()

On Error GoTo eh

Dim ent As AcadEntity

Dim p1 As Variant

Dim p2 As Variant

Dim x As Double

Dim y As Double

Dim atst As Double

Dim min_atst As Double

Dim taskas As Double

Dim atst_nustatytas As Boolean

Dim dblVertices() As Double

Dim dblVerticesCnt As Double

Dim dblVertices2() As Double

Dim dblVerticesCnt2 As Double

Dim sset As AcadSelectionSet

Dim perdavimui As Variant

Dim obj As AcadMLine

Dim obj2 As AcadMLine

Dim varpnt As Variant

Dim krd(2) As Double

Dim aa As Integer

Dim objEnt As AcadMLine

Dim objEnt2 As AcadMLine

ThisDrawing.Utility.GetEntity ent, 1, "Select MLINE: "

p2 = ThisDrawing.Utility.GetPoint(, "Select the SPLIT point in MLINE: ")

x = p2(0): y = p2(1)

atst_nustatytas = False

dblVerticesCnt = -1

dblVerticesCnt2 = -1

'randam artimiausia

If TypeOf ent Is AcadMLine Then 'AcadBlockRef isrinkimas

Set obj = ent

'ThisDrawing.SetVariable "CMLSTYLE", obj.StyleName

For aa = 0 To UBound(obj.Coordinates) Step 3

'MsgBox Str(obj.Coordinates(aa)) & "," & Str(obj.Coordinates(aa + 1)) & "," & Str(obj.Coordinates(aa + 2))

atst = DistanceBetween(obj.Coordinates(aa), obj.Coordinates(aa + 1), x, y)

If (atst_nustatytas = False) Then

min_atst = atst

atst_nustatytas = True

End If

If atst

min_atst = atst

taskas = aa

End If

Next aa


MsgBox "Must select MLINE!"

Exit Sub

End If

Set perdavimui = obj.Copy

Set obj2 = perdavimui


'Exit Sub

For aa = 0 To UBound(obj.Coordinates) Step 3

'MsgBox obj.Coordinates(aa)

'MsgBox obj.Coordinates(aa + 1)

'MsgBox obj.Coordinates(aa + 2)

If aa >= taskas Then

dblVerticesCnt = dblVerticesCnt + 3

ReDim Preserve dblVertices(dblVerticesCnt)

dblVertices(dblVerticesCnt - 2) = obj.Coordinates(aa)

dblVertices(dblVerticesCnt - 1) = obj.Coordinates(aa + 1)

dblVertices(dblVerticesCnt) = obj.Coordinates(aa + 2)

End If

If aa

dblVerticesCnt2 = dblVerticesCnt2 + 3

ReDim Preserve dblVertices2(dblVerticesCnt2)

dblVertices2(dblVerticesCnt2 - 2) = obj2.Coordinates(aa)

dblVertices2(dblVerticesCnt2 - 1) = obj2.Coordinates(aa + 1)

dblVertices2(dblVerticesCnt2) = obj2.Coordinates(aa + 2)

End If

Next aa

If ThisDrawing.ActiveSpace = acModelSpace Then

If dblVerticesCnt >= 5 Then obj.Coordinates = dblVertices

If dblVerticesCnt2 >= 5 Then obj2.Coordinates = dblVertices2


If dblVerticesCnt >= 5 Then obj.Coordinates = dblVertices

If dblVerticesCnt2 >= 5 Then obj2.Coordinates = dblVertices2

End If



Exit Sub


MsgBox "Error number: " & str(Err.Number) & " . Description: " & Err.Description

End Sub

Link to comment
Share on other sites

Join the conversation

You can post now and register later. If you have an account, sign in now to post with your account.
Note: Your post will require moderator approval before it will be visible.

Unfortunately, your content contains terms that we do not allow. Please edit your content to remove the highlighted words below.
Reply to this topic...

×   Pasted as rich text.   Restore formatting

  Only 75 emoji are allowed.

×   Your link has been automatically embedded.   Display as a link instead

×   Your previous content has been restored.   Clear editor

×   You cannot paste images directly. Upload or insert images from URL.

  • Create New...