Block Question

[david.brissenden]

Hi guys,

I have a strange question with regard to blocks. I have attached a drawing to show what I am describing. If I draw a line across two blocks, in VBA how can I trim the line to the outside of the blocks?

Is this possible? Has anyone done anything similar before?

Thanks

[fixo]

Try this one


Option Explicit

Sub BreakWithBlock()

Dim fpt As Variant, spt As Variant
Dim ftype(0) As Integer
Dim fdata(0) As Variant
Dim osm As Integer
Dim strp1 As String, strp2 As String
Dim strh As String
ftype(0) = 0: fdata(0) = "LINE,LWPOLYLINE"
Dim dxftype As Variant, dxfdata As Variant
dxftype = ftype: dxfdata = fdata
Dim ss As AcadSelectionSet

On Error GoTo Err_Control

Set ss = ThisDrawing.PickfirstSelectionSet
ss.Clear
With ThisDrawing
osm = .GetVariable("OSMODE")
.SetVariable "OSMODE", 32
fpt = .Utility.GetPoint(, vbCr & "Specify first break point")
ss.Select acSelectionSetCrossing, fpt, fpt, dxftype, dxfdata
If ss.Count = 1 Then
ss.Highlight True
Else
MsgBox Chr(9) & "0 objects selected OR " & vbNewLine & _
"incorrect number of objects selected..."
GoTo Exit_Here
End If
spt = .Utility.GetPoint(, vbCr & "Specify second break point")
End With

Dim ln As AcadLine
Dim pl As AcadLWPolyline
Dim oent As AcadEntity
Set oent = ss.Item(0)
If TypeOf oent Is AcadLine Then
Set ln = oent

strh = ln.Handle
ElseIf TypeOf oent Is AcadLWPolyline Then
Set pl = oent

strh = pl.Handle
End If

strp1 = Replace(CStr(fpt(0)), ",", ".") & "," & _
Replace(CStr(fpt(1)), ",", ".") & "," & _
Replace(CStr(fpt(2)), ",", ".")
strp2 = Replace(CStr(spt(0)), ",", ".") & "," & _
Replace(CStr(spt(1)), ",", ".") & "," & _
Replace(CStr(spt(2)), ",", ".")

ThisDrawing.SetVariable "CMDECHO", 0
ThisDrawing.SendCommand "-OSNAP NONE "
ThisDrawing.SendCommand "_BREAK " & _
"(handent " & Chr(34) & strh & Chr(34) & ")" & _
vbCr & strp1 & vbCr & strp2 & vbCr

Exit_Here:
ss.Highlight False
ss.Clear
With ThisDrawing
.Regen acActiveViewport
.SetVariable "OSMODE", 512
.SetVariable "CMDECHO", 1
End With

Err_Control:
If Err.Number <> 0 Then
MsgBox Err.Description
Resume Exit_Here
End If

End Sub

~'J'~

[david.brissenden]

Thanks Fixo.

It is not entirely what I was aiming for...what I really wanted to do is click on two points (like what you helped me with before) to generate a line which then automatically trims itself around any blocks in the same command.

My intention was to build this in to the code you helped me with last time so that the rectangle will trim itself around any blocks that are in its way as it is created so you only run one command.

Looking around, I have discovered the VBA API does not support the trim command (and others) which is extremly disapointing from Autodesk. If they are going to provide these commands in LISP then they should also do it in VBA!! :(

Anyway, because of the shortcomings of the API, I have decided not to continue this particular project any further - I just need to wait for the next one :)

Thanks very much for your help Fixo, I am sure that this code will be useful for other people though.

Come on Autodesk, sort out the API ;)

[Ed Jobe]

Looking around, I have discovered the VBA API does not support the trim command (and others) which is extremly disapointing from Autodesk. If they are going to provide these commands in LISP then they should also do it in VBA!! :(

LISP doesn't actually provide commands, it provides the command() function, which just spits out text to the command line. VBA has the same thing, SendCommand(). However, the vba implementation is asyncronous, which would not work for what you want to do.

[david.brissenden]

LISP doesn't actually provide commands, it provides the command() function, which just spits out text to the command line. VBA has the same thing, SendCommand(). However, the vba implementation is asyncronous, which would not work for what you want to do.

Oh right, I didn't realise that is how LISP worked!!

Thanks for the info, Ed

[fixo]

Try another one instead


Sub BreakALine()
Dim fstPt, sndPt, strPt, endPt
Dim oEnt As AcadEntity
Dim oLine As AcadLine
Dim oLineDup As AcadLine
Dim dblDist As Double
Dim dblLeng As Double
Dim dirFlag As Boolean
Dim ftype(0) As Integer
Dim fdata(0) As Variant
ftype(0) = 0: fdata(0) = "LINE"
Dim dxfCode As Variant, dxfValue As Variant
dxfCode = ftype: dxfValue = fdata
Dim oSset As AcadSelectionSet
Dim intOsm As Integer

With ThisDrawing
intOsm = .GetVariable("OSMODE")
.SetVariable "OSMODE", 32
fstPt = .Utility.GetPoint(, vbCr & "Specify first break point: ")
sndPt = .Utility.GetPoint(, vbCr & "Specify second break point: ")

With .SelectionSets
While .Count > 0
.Item(0).Delete
Wend
Set oSset = .Add("$Line$")
End With

oSset.SelectAtPoint fstPt, dxfCode, dxfValue
Set oEnt = oSset.Item(0)
Set oLine = oEnt
dblLeng = oLine.Length
strPt = oLine.StartPoint
endPt = oLine.EndPoint

If Distance(strPt, fstPt) < Distance(strPt, sndPt) Then
dirFlag = True
Else
dirFlag = False
End If

Set oLineDup = oLine.Copy

With .ModelSpace
If dirFlag Then
oLine.StartPoint = strPt
oLine.EndPoint = fstPt
oLineDup.StartPoint = sndPt
oLineDup.EndPoint = endPt
Else
oLine.StartPoint = strPt
oLine.EndPoint = sndPt
oLineDup.StartPoint = fstPt
oLineDup.EndPoint = endPt
End If
End With
.Regen acActiveViewport
.SetVariable "OSMODE", intOsm
End With

End Sub

Public Function Distance(fPoint As Variant, sPoint As Variant) As Double
' by Frank Oquendo
Dim x1 As Double, x2 As Double
Dim y1 As Double, y2 As Double
Dim z1 As Double, z2 As Double
Dim cDist As Double

x1 = fPoint(0): y1 = fPoint(1): z1 = fPoint(2)
x2 = sPoint(0): y2 = sPoint(1): z2 = sPoint(2)

cDist = Sqr(((x2 - x1) ^ 2) + ((y2 - y1) ^ 2) + ((z2 - z1) ^ 2))
Distance = cDist

End Function

~'J'~