Intersection coordinates exported to Excel using vba

[Anonymous]

Dears,

I have some background with VBA for Excel, but almost zero with VBA for AutoCAD.

Is it possible using VBA for Excel to extract a list of intersection points of a opened CAD file?

[grobnik]

Hi,
If I understood well you want to develope a macro inside Autocad for
exporting intersection points, to Excel?
But from what I know in order to check if two objects are intersecting you
have to select the first, then the second one, both selection could be
made by VBA, and apply a function always by VBA with thecsame procedure,
which check if the two objects are intersecting, if yes the function return
an array with 3 points coordinates, if not function will return a different
value.
I don't know how it's possibile apply to all objects in the drawing in the
same time.

[grobnik]

Here below an example without the Excel Export side, but only msgbox with intersection points

If you select as first object the rectangle and as second object the intersecting line you will get 2 coordinates points inside the array intPoints variable (total 6 value X,Y,Z first intersection point, and X,Y,Z second intersection point).

Sub test_of_intersection()
Dim Object_First As AcadObject
Dim Object_Second As AcadObject
Dim BasePnt1 As Variant
Dim BasePnt2 As Variant
ThisDrawing.Utility.GetEntity Object_First, BasePnt1, "Select First object"
ThisDrawing.Utility.GetEntity Object_Second, BasePnt2, "Select Second object"
' Find the intersection points between the line and the rectangle
    Dim intPoints As Variant
    intPoints = Object_First.IntersectWith(Object_Second, acExtendNone)

    ' Print all the intersection points
    Dim I As Integer, j As Integer, k As Integer
    Dim str As String
    If VarType(intPoints) <> vbEmpty Then
        For I = LBound(intPoints) To UBound(intPoints)
            str = "Intersection Point[" & k & "] is: " & intPoints(j) & " , " & intPoints(j + 1) & " , " & intPoints(j + 2)
            MsgBox str, , "IntersectWith Example"
            str = ""
            I = I + 2
            j = j + 3
            k = k + 1
        Next
    End If
End Sub

Later I'll show you a code for exporting into Excel

[Anonymous]

Thank you for yout  attention, I got to find an answer.

Option Explicit
Sub findIntersect()
Dim acadApp As AcadApplication
Dim acadDoc As AcadDocument
Dim acObject As AcadObject
Dim lineObj1, lineObj2 As AcadLine
Dim intPoints As Variant
Dim objss, ssetObj As AcadSelectionSet
Dim n, i, x, Lline As Integer
Dim intersection As Variant
Dim location(0 To 2) As Double

'get access to autocad application
Set acadApp = GetObject(, "AutoCAD.Application")
Set acadDoc = acadApp.ActiveDocument

On Error Resume Next
'try to create a new selectionset
'if it exists, delete it and recreate a new one
Set objss = acadDoc.SelectionSets("sset")
If Err Then Set objss = acadDoc.SelectionSets.Add("sset")
'if it exists, erase it's content
objss.Clear

Set objss = acadDoc.SelectionSets.Add("sset")
objss.Select acSelectionSetAll
x = objss.Count
Lline = 3
For i = 0 To x - 1
Set lineObj1 = objss.Item(i)
For n = i + 1 To x - 1
Set lineObj2 = objss.Item(n)
intersection = lineObj1.IntersectWith(lineObj2, acExtendNone)
location(0) = intersection(0): location(1) = intersection(1): location(2) = 0
If UBound(intersection) = 2 Then
Range("Xcoord").Cells(Lline, 1) = intersection(0)
Range("Ycoord").Cells(Lline, 1) = intersection(1)
Lline = Lline + 1
End If
Next
Next
End Sub

[info9ATN7]

did you ever show the code for exporting into excel?

[info9ATN7]

oops

[grobnik]

@info9ATN7 

Hi, if you look at code posted by Anonymous on last "09-15-2021 08:10 PM", such code shall be written into Excel VBA Module, in addition two names like "Xcoord" and "Ycoord" both at least by 3 rows and 1 column shall be defined, inside Excel workbook.

On Autocad side (see below image as test) two oblique lines, intersecting a vertical one, like picture below just to test the intersection.

Finally you will achieve your goal of get the intersection coordinates, after running the Excel procedure.

As suggestion replace this part of code, sometimes Excel require the Workbook, and sheet where cells shall be filled with results value.

ActiveWorkbook.Sheets("Foglio1").Range("Xcoord").Cells(Lline, 1) = intersection(0)
ActiveWorkbook.Sheets("Foglio1").Range("Ycoord").Cells(Lline, 1) = intersection(1)

instead 

Range("Xcoord").Cells(Lline, 1) = intersection(0)
Range("Ycoord").Cells(Lline, 1) = intersection(1)

I'm sorry for Italian Excel Version with sheet name "Foglio1", but of course it's referenced to the Name of Sheet where the intersection coordinates shall be indicated.

Bye