Need a book? Engineering books recommendations...

Return to index: [Subject] [Thread] [Date] [Author]

use acad coordinates

[Subject Prev][Subject Next][Thread Prev][Thread Next]
Proven on Autocad 14


the following is the macro
to run in excel. turn on autocad and excel
hi-light autocad lines representing shear walls
save to file with lines hi-lighted keep autocad running with hi-lights
switch to excel and run the  macro
it creates a new sheet to avoid overwriting used sheets.
I had reduced the previously delivered macro to just x and y and sent
numbers
 to the sheet address needed for analaysis.

' ExtractLineCoords
' By Hans Kellner employee of autodesk - Feb. 1999
Hans is also a programer for the architectural autocad stuff
' Hans gave David Merrick permission to share this with others.
' The intent is to merge this in with the
' This subroutine extracts the startpoint and endpoint coordinates
' of all line entities in the current AutoCAD document selection set.
' It places these coordinates in a new worksheet.
Public Sub ExtractAcadLineCoords()

    ' Get the running version of AutoCAD
    Dim acadApp As Object
    On Error Resume Next    ' Defer error trapping.
    Set acadApp = GetObject(, "AutoCAD.Application")
    Err.Clear   ' Clear Err object in case error occurred.
    
    If acadApp Is Nothing Then
        MsgBox "AutoCAD is not running.  Please run AutoCAD, load drawing,
and select lines."
        Exit Sub
    End If
    
    acadApp.Visible = True
    
    ' Get the active document
    Dim acadDoc As Object
    Set acadDoc = acadApp.ActiveDocument
    If acadDoc Is Nothing Then
        MsgBox "Unable to find AutoCAD document.  Unable to continue."
        Exit Sub
    End If
    
    ' Get the selection set from the document
    Dim acadSSet As Object
    Set acadSSet = acadDoc.ActiveSelectionSet
    
    If acadSSet Is Nothing Or acadSSet.Count = 0 Then
        MsgBox "There is no selection.  Please select lines first."
        Exit Sub
    End If
    
    ' Now we need to create a new worksheet to insert the extracted
    ' line coordinates.  Start by checking if there is an existing
    ' workbook.
    Dim xlWb As Workbook
    If ActiveWorkbook Is Nothing Then
        ' Nope, so create a new workbook
        Set xlWb = Workbooks.Add(xlWBATWorksheet)
    Else
        ' use active workbook
        Set xlWb = ActiveWorkbook
        xlWb.Worksheets.Add
    End If
    
    ' get the new worksheet and make it visible
    Dim xlWs As Worksheet
    Set xlWs = xlWb.ActiveSheet
    xlWs.Visible = xlSheetVisible
    
    ' Set the title of the sheet
    xlWs.Cells(1, 1).Value = "Coordinates of Selected Lines for document: "
& acadDoc.Name
    xlWs.Cells(1, 1).Font.Bold = True
    
    ' Set the captions for the columns
    xlWs.Cells(3, 1).Value = "X1"
    xlWs.Cells(3, 2).Value = "Y1"
    xlWs.Cells(3, 3).Value = "Z1"
    xlWs.Cells(3, 4).Value = "X2"
    xlWs.Cells(3, 5).Value = "Y2"
    xlWs.Cells(3, 6).Value = "Z2"
    
    ' Change the format of the captions.
    With xlWs.Rows("3:3")
        .Font.Bold = True
        .HorizontalAlignment = xlCenter
    End With
        
    ' Now we will iterate over the selection set and fill the table
    ' with the coordinates of all lines in the set.
    Dim startPt As Variant, endPt As Variant
    Dim acadEntity As Object
    Dim iRow As Integer
    iRow = 4
    For Each acadEntity In acadSSet
        With acadEntity
            ' Is this a line?
            If .EntityName = "AcDbLine" Then
            
                ' Yes, so we can grab the information
                ' Place these coordinates in the table
                startPt = .startPoint
                endPt = .endPoint
                xlWs.Cells(iRow, 1).Value = startPt(0)
                xlWs.Cells(iRow, 2).Value = startPt(1)
                xlWs.Cells(iRow, 3).Value = startPt(2)
                xlWs.Cells(iRow, 4).Value = endPt(0)
                xlWs.Cells(iRow, 5).Value = endPt(1)
                xlWs.Cells(iRow, 6).Value = endPt(2)
                
                ' Next row
                iRow = iRow + 1
            End If
        End With
    Next acadEntity
    
    xlWs.Activate   ' Now we activate the sheet
    
End Sub