Изменение высоты Acad3DSolid

Option Explicit

    Public Sub WriteSolidsToFile()
     Dim oSset As AcadSelectionSet
     Dim oEnt As Variant
     Dim oSolid As Acad3DSolid
     Dim i As Integer
     Dim solType As String
     Dim gpCode(0) As Integer
     Dim dataValue(0) As Variant
     Dim dxfCode, dxfdata
     Dim setName As String
     setName = "@Solids@"
     Dim txtFileName As String
     txtFileName = "C:\\Test\\SolidInfos.txt"    '<---- Change File Name
     On Error GoTo SayMeAbout
     
     gpCode(0) = 0
     dataValue(0) = "3DSOLID"
     dxfCode = gpCode: dxfdata = dataValue
          With ThisDrawing.SelectionSets
               While .Count > 0
                    .Item(0).Delete
               Wend
          Set oSset = .Add(setName)
          End With

 oSset.SelectOnScreen dxfCode, dxfdata

 If oSset.Count = 0 Then
  MsgBox "Nothing Selected. Exit...", , "Error"
  Exit Sub
 End If


Open txtFileName For Output As #1
Print #1, "Selected=" & CStr(oSset.Count) & " 3dSolid objects"
 For Each oEnt In oSset

  Print #1, "Handle=" & oEnt.Handle
  Print #1, "Name=" & oEnt.ObjectName

    Set oSolid = oEnt
    Dim pos As Variant
    pos = oSolid.Position

    solType = oEnt.SolidType
    Print #1, "SolidType=" & solType
    Print #1, "Position=" & CStr(Round(pos(0), 3)) & "," & CStr(Round(pos(1), 3))
    Print #1, "Volume=" & CStr(Round(oSolid.Volume, 3))
    Dim minp, maxp
    oSolid.GetBoundingBox minp, maxp
    Print #1, "Height=" & CStr(Round(maxp(2) - minp(2), 3))
    Select Case LCase(oEnt.SolidType)
    Case "cylinder"
    
    Print #1, "Radius=" & CStr(Round(maxp(0) - minp(0) / 2, 3))
    Case "box"
    Print #1, "Length=" & Round(IIf(maxp(0) - minp(0) > maxp(1) - minp(1), CStr(maxp(0) - minp(0)), CStr(maxp(1) - minp(1))), 3)
    Print #1, "Width=" & Round(IIf(maxp(0) - minp(0) > maxp(1) - minp(1), CStr(maxp(1) - minp(1)), CStr(maxp(0) - minp(0))), 3)
    Case Else
    MsgBox "Add your calculation for type of " & solType
End Select
Print #1, "''------------------------------------''"
Next oEnt

 Close
 Dim cmd As String
 cmd = "(startapp " & Chr(34) & "notepad" & Chr(34) & " " & Chr(34) & txtFileName & Chr(34) & ")" & vbCr

 ThisDrawing.SendCommand cmd
 
SayMeAbout:
If Err.Number <> 0 Then
MsgBox Err.Description
End If

End Sub