12-16-2015
04:19 AM
- Marcar como nuevo
- Favorito
- Suscribir
- Silenciar
- Suscribirse a un feed RSS
- Resaltar
- Imprimir
- Denunciar
12-16-2015
04:19 AM
Hi,
I created now 3D-Solids between attributes ABSHMIN and ABSHMAX, I hope that is what you are looking for.
The code (VBA, so maybe installing the VBA Enabler for AutoCAD is required) which does this (only done for exact this drawing structure) can be found here:
Spoiler
Spoiler
Option Explicit
Public Sub ExtToAttHeight()
Dim tEnt As AcadEntity
For Each tEnt In ThisDrawing.ModelSpace
If TypeOf tEnt Is AcadBlockReference Then
Call handleBlockRef(tEnt)
End If
Next
End Sub
Private Sub handleBlockRef(ByRef BlRef As AcadBlockReference)
If BlRef.HasAttributes Then
Dim tH1 As Double: tH1 = -1
Dim tH2 As Double: tH2 = -1
Dim tAtts As Variant: tAtts = BlRef.GetAttributes
Dim i As Integer
For i = LBound(tAtts) To UBound(tAtts)
Select Case UCase(tAtts(i).TagString)
Case "ABSHMIN": tH1 = Val(tAtts(i).TextString)
Case "ABSHMAX": tH2 = Val(tAtts(i).TextString)
End Select
If (tH1 >= 0) And (tH2 >= 0) Then Exit For
Next
If (tH1 >= 0) And (tH2 >= 0) Then
'ok, there exits valid data
Dim tBlDef As AcadBlock: Set tBlDef = ThisDrawing.Blocks(BlRef.Name)
Dim tEnt As AcadEntity
For Each tEnt In tBlDef
'search polyline within the blockdefinition
If (TypeOf tEnt Is AcadPolyline) Or (TypeOf tEnt Is AcadLWPolyline) Then
Dim tCurves(0) As AcadEntity: Set tCurves(0) = tEnt
Dim tRegion As AcadRegion: Set tRegion = tBlDef.AddRegion(tCurves)(0)
'create solid and move it to base-elevation
Dim tSolid As Acad3DSolid: Set tSolid = tBlDef.AddExtrudedSolid(tRegion, tH2 - tH1, 0#)
Dim tPnt1(0 To 2) As Double
Dim tPnt2(0 To 2) As Double: tPnt2(2) = tH1
Call tSolid.Move(tPnt1, tPnt2)
tRegion.Delete
'Exit For
End If
Next
End If
Else
'nothing to do
End If
End Sub
The finished drawing can be downloaded from >>>here<<<.
There is one object extruded down to Z=0 .. because there the attribues are not filled correctly.
HTH, - alfred -
------------------------------------------------------------------------------------
Alfred NESWADBA
ISH-Solutions GmbH / Ingenieur Studio HOLLAUS
www.ish-solutions.at ... blog.ish-solutions.at ... LinkedIn ... CDay 2025
------------------------------------------------------------------------------------

(not an Autodesk consultant)
Alfred NESWADBA
ISH-Solutions GmbH / Ingenieur Studio HOLLAUS
www.ish-solutions.at ... blog.ish-solutions.at ... LinkedIn ... CDay 2025
------------------------------------------------------------------------------------
(not an Autodesk consultant)