Anuncios

The Autodesk Community Forums has a new look. Read more about what's changed on the Community Announcements board.

Alfred.NESWADBA
en respuesta a: emma.cronin

Hi,

 

I created now 3D-Solids between attributes ABSHMIN and ABSHMAX, I hope that is what you are looking for.

 

2015-12-16 13-13-41.png

 

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)
Etiquetas (1)