TheSwamp
Code Red => VB(A) => Topic started by: michael_h on April 25, 2008, 01:03:08 PM
-
Hi folks,
I'm an architectural researcher (not an architect), who's having some trouble figuring out how to write a small program. On some AutoCad stuff, I'm fairly knowledgeable, but since I'm self-taught, there are bound to be some holes in my knowledge, so no advice is too dumb.
I have a number of floorplans that I need to analyze using a program called DepthMap (it's basically a visual analysis program). This program can output data into a text file, and I have created a awk (Linux-based) program that turns the data into an AutoCad script. When run, this script "draws" the data from the DepthMap program on a new layer in the AutoCad model. Each data point is in the form of a three dimensional rectangle, where x and y give the x and y locations, and the thickness represents data from the DepthMap program. Each datapoint is colored with a particular algorithm--I've given an example below.
color 180
_rectang thickness 3.18203 0,15 0.99,15.99
I tend to have a lot of these little data points (typically >30,000). What I would like to do is to be able to draw an region on a separate layer (ideally a polygon), and then create an AutoCad program that would automatically select all of the datapoints that fall within that region. Then I would like to export properties of those datapoints to Excel (I know how to export to Excel, thankfully).
The reason I'd like to draw these regions on a separate layer is because sometimes, I need to go back and select the same data points for a different analysis, and I need to make sure that I got the same ones each time. Also, because some of these plans have a lot of repetitive, strangely shaped rooms, I would love to be able to draw a polygon region one time and copy/paste it, rather than trying to do a lot of tedious selection of data points by hand.
So, in short:
I have lots of small rectangles on layer A.
I have regions defined by polygons on layer B.
I want to write a script that exports the properties of every rectangle on layer A that falls within the limit of each polygon on layer B.
Any advice would be most welcome--even if it's just a reference to a function that might be useful. Thanks,
Michael
-
Try this one, it was written for one guy from
Italy two years ago, looks like it's the same task
you want to solve :)
(defun c:WPL (/ Collector Color Coors Data Dz Elist En First_String Fn Fname I P1 P3 Ptlist Rect Second_String Ss
Thick Tmpss)
(setq dz (getvar "dimzin"))
(setvar "dimzin" 8)
(command "_zoom" "_e")
(if (setq ss (ssget "_X"
(list
(cons -4 "<AND")
(cons 0 "*POLYLINE,*CONTOUR")
(cons 8 "PARTICELLA") ; change layer of polygons here
(cons 410 (getvar "ctab")) ; current tab only
(cons 70 1) ; flag (1 - for closed polyline)
(cons -4 "AND>")
)
)
)
(progn
(setq i -1)
(repeat (sslength ss)
(setq en (ssname ss (setq i (1+ i))))
(setq
ptlist (vl-remove-if
(function not)
(mapcar
(function (lambda (x)
(if (= 10 (car x))
(list (car (cdr x)) (cadr (cdr x)))
)
)
)
(entget en)
)
)
)
(setq tmpss (ssget "_CP"
ptlist
(list
(cons -4 "<AND")
(cons 0 "*POLYLINE,*CONTOUR")
(cons 8 "TESTIPARTICELLA") ; change layer of rectangles here
(cons 90 4) ; four vertices only
(cons 70 1) ; closed
(cons -4 "AND>")
)
)
)
(if tmpss
(while
(setq rect (ssname tmpss 0))
(setq collector (cons rect collector))
(ssdel rect tmpss)
)
)
)
)
(alert "No boundaries with \nthese properties")
)
(command "_zoom" "_p")
(foreach itm collector
(setq elist (entget itm))
(setq coors (vl-remove-if
(function not)
(mapcar (function (lambda (x)
(if (equal 10 (car x))
(cdr x)
)
)
)
elist
)
)
)
(setq p1 (car coors)
;;; p2 (cadr coors)
p3 (caddr coors)
;;; p4 (cadddr coors)
)
(setq thick (cdr (assoc 40 elist))
color (cdr (assoc 62 elist))
)
(setq first_string (strcat "color " (itoa color))
second_string (strcat "_rectang thickness "
(rtos thick 2 5)
" "
(rtos (car p1) 2 2)
","
(rtos (cadr p1) 2 2)
" "
(rtos (car p3) 2 2)
","
(rtos (cadr p3) 2 2)
)
)
(setq data (cons first_string data)
data (cons second_string data))
)
(setq data (reverse data))
(setq fname (strcat (getstring
"\nEnter text file name w/o extension to save data: ")
".txt"))
(setq fn (open (strcat (getvar "dwgprefix") fname) "w"))
(mapcar (function (lambda (x) (write-line x fn)))
data
)
(close fn)
(alert "done")
(setvar "dimzin" dz)
(princ)
)
(princ "\n >> Start command with WPL")
(prin1)
~'J'~
-
.................
So, in short:
I have lots of small rectangles on layer A.
I have regions defined by polygons on layer B.
I want to write a script that exports the properties of every rectangle on layer A that falls within the limit of each polygon on layer B.
Any advice would be most welcome--even if it's just a reference to a function that might be useful. Thanks,
Michael
Sorry, Michael, i forgot about this is VBA branch
Try this instead
Option Explicit
Sub WriteLotsToFile()
Dim oPolySset As AcadSelectionSet
Dim oTempSset As AcadSelectionSet
Dim ftype() As Integer
Dim fdata() As Variant
Dim dxfCode, dxfValue
With ThisDrawing.SelectionSets
While .Count > 0
.Item(0).Delete
Wend
Set oPolySset = .Add("$Polygons$")
Set oTempSset = .Add("$Rectangles$")
End With
ReDim ftype(4) As Integer
ReDim fdata(4) As Variant
ftype(0) = -4: ftype(1) = 0: ftype(2) = 8: ftype(3) = 70: ftype(4) = -4
fdata(0) = "<and": fdata(1) = "LWPOLYLINE": fdata(2) = "B": fdata(3) = 1: fdata(4) = "and>"
dxfCode = ftype: dxfValue = fdata
oPolySset.Select acSelectionSetAll, , , dxfCode, dxfValue
If oPolySset.Count = 0 Then
MsgBox "0 contours found"
Exit Sub
End If
' open text file
Open ThisDrawing.Path & "\mydata.txt" For Output As #1 '<--change file name here
'
Dim oEnt As AcadEntity
Dim oRecEnt As AcadEntity
Dim oPline As AcadLWPolyline
Dim oRect As AcadLWPolyline
ReDim ftype(5)
ReDim fdata(5)
Dim selMod As Long
selMod = acSelectionSetCrossingPolygon
ftype(0) = -4: ftype(1) = 0: ftype(2) = 8: ftype(3) = 70: ftype(4) = 90: ftype(5) = -4
fdata(0) = "<and": fdata(1) = "LWPOLYLINE": fdata(2) = "A": fdata(3) = 1: fdata(4) = 4: fdata(4) = "and>"
dxfCode = ftype: dxfValue = fdata
For Each oEnt In oPolySset
If Not TypeOf oEnt Is AcadLWPolyline Then
MsgBox "It is not a lightweight polyline", vbExclamation, "Programm stopped"
Exit Sub
Else
Set oPline = oEnt
Dim vertPts() As Double
Dim dblElv As Double
Dim selPts As Variant
dblElv = oPline.Elevation
vertPts = oPline.Coordinates
selPts = ConvTo3dPoints(vertPts, dblElv)
'\\' An array of 3D WCS coordinates specifying the selection fence
' :ugly:Debug.Print UBound(selPts) 'debug only
selMod = acSelectionSetWindowPolygon 'acSelectionSetCrossingPolygon '
'\\' change mode by suit
oTempSset.SelectByPolygon selMod, selPts ', dxfcode, dxfdata
oTempSset.Highlight True 'optional
'Debug.Print "Selected: " & CStr(oTempSset.Count)
For Each oRecEnt In oTempSset
If Not TypeOf oRecEnt Is AcadLWPolyline Then
MsgBox "It is not a lightweight polyline", vbExclamation, "Programm stopped"
Exit Sub
Else
Set oRect = oRecEnt
vertPts = oRect.Coordinates
Dim strFirst As String
Dim strSnd As String
strFirst = "color " & oRect.TrueColor.ColorIndex
strSnd = "_rectang thickness " & _
DSTR(oRect.ConstantWidth, acDecimal, 5) & Chr(32) & _
DSTR(vertPts(0), acDecimal, 2) & Chr(44) & _
DSTR(vertPts(1), acDecimal, 2) & Chr(32) & _
DSTR(vertPts(4), acDecimal, 2) & Chr(44) & _
DSTR(vertPts(5), acDecimal, 2)
End If
'Debug.Print strFirst
'Debug.Print strSnd
Print #1, strFirst
Print #1, strSnd
Next oRecEnt
oTempSset.Clear
End If
Next oEnt
Close #1
End Sub
Public Function ConvTo3dPoints(objCoors As Variant, dblElv As Double) As Variant
Dim i As Long, j As Long
Dim convPts() As Double
j = 0
For i = LBound(objCoors) To UBound(objCoors) Step 2
ReDim Preserve convPts(0 To j)
convPts(j) = objCoors(i)
ReDim Preserve convPts(0 To j + 1)
convPts(j + 1) = objCoors(i + 1)
ReDim Preserve convPts(0 To j + 2)
convPts(j + 2) = dblElv
j = j + 3
Next
ConvTo3dPoints = convPts
End Function
Function DSTR(value As Double, unit As AcUnits, prec As Long) As String
DSTR = ThisDrawing.Utility.RealToString(value, unit, prec)
End Function
~'J'~
-
Fatty,
Thanks, I definitely appreciate it. We're right at the end of the semester, so grading papers and such may mean that it'll take a few days to work on this, but this is very helpful!
-
You're welcome, Michael
Wish you to kill this semester succesfully :)
~'J'~