From: merrick group <merrickgroup(--nospam--at)compuserve.com>
Date: Mon, 22 Jan 2001 12:31:16 -0500
title from merrick's macro ?AcadModules.ExtractAcadLineCoords
Following is the macro for extracting the coordinates from acad14 to the
excel spreadsheet. I hear that acad2000 has a more direct and simpler way
of doing this. Dennis Wish never got this working. I have used it on
several projects. But not since I have updated to acad2000i.
****** Watch for my next email, where I will demonstrate a spread sheet
method for distributing forces for a flexible diaphragm that can be
expanded at will, takes up one line and can have division lines with no
shear wall. It is an iteration similar to the moment distribution method
for continuous beams and frames.
*****My next project is a two dimensional iteration for rigid diaphragms
that can expand to what ever size one needs. A piece of diaphragm has no
way of knowing where the shear walls are. So why couldn't a mathematical
module be made that can be stacked, as needed, like Legos, to work out
diaphragm responses of any shape?
*****I need programs that lets me make my own program with my own design
decisions. I still don't fully know how sold programs are managing design
decisions. It used to be that we could get, study and alter program codes
for our designs. With out that access just how liable are you for errors?
How liable are programmers that hold secrete and are the only ones that
control their proprietary codes for their programs?
*****And now the macro.
' By Hans Kellner - Feb. 1999
' Hans gave David Merrick permission to share this with others on April, 20
' This is to be merged into James Rigid Diaphragm Program.
' 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 acad14 document selection
' 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."
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."
' 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."
' Now we need to create a new worksheet to insert the extracted
' line coordinates. Start by checking if there is an existing
Dim xlWb As Workbook
If ActiveWorkbook Is Nothing Then
' Nope, so create a new workbook
Set xlWb = Workbooks.Add(xlWBATWorksheet)
' use active workbook
Set xlWb = ActiveWorkbook
' 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 shearwalls:
" & acadDoc.Name
xlWs.Cells(1, 1).Font.Bold = True
' Set the captions for the columns
xlWs.Cells(3, 1).Value = "X"
xlWs.Cells(3, 2).Value = "Y"
xlWs.Cells(3, 3).Value = "Z"
' Change the format of the captions.
.Font.Bold = True
.HorizontalAlignment = xlCenter
' 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
Dim jRow As Integer
iRow = 4
jRow = 5
For Each acadEntity In acadSSet
' 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) / 12
xlWs.Cells(iRow, 2).Value = startPt(1) / 12
xlWs.Cells(iRow, 3).Value = startPt(2) / 12
xlWs.Cells(jRow, 1).Value = endPt(0) / 12
xlWs.Cells(jRow, 2).Value = endPt(1) / 12
xlWs.Cells(jRow, 3).Value = endPt(2) / 12
' Next row
jRow = jRow + 2
iRow = iRow + 2
xlWs.Activate ' Now we activate the sheet