Step Export mit Benutzerdefenierten Eigenschaften (Custom Iproperties) (Autodesk/Inventor VBA)

Hier mal der Code zum Lesen von iProperties, den ich in Verwendung habe. Ist deutlich mehr Code als das von mir verlinkte Beispiel, ist dafür aber etwas flexibler. Ich schlage vor, das in ein eigenes Modul zu packen (damit der Rest übersichtlich bleibt).

Code:
Public Enum iPropSetNameEnum
IVSumInfo = 1
DocSumInfo = 2
DesignTrackProp = 3
UserDefProp = 4
End Enum
Public Function ReadiProperty(ByRef doc As Document, _
ByRef PropertyName As String, Optional PropSet As iPropSetNameEnum = 0&, _
Optional forceStringReturn As Boolean = False) As Variant
'Wert aus iProp lesen
' aus beliebiegem PropertySet
' erstes gefundenes Element wird zurückgegeben (sollten mehrere existieren)
' wird der Name in keinem Set gefunden, Rückgabe -> Null
' Optional: PropSetName: Es wird nur in dem angegebenen PropSet gesucht
' Optional: forceStringReturn: gibt "" zurück, (statt Null) auch wenn Prop. nicht existiert

'Default-Rückgabewert (wenn Prop nicht existiert)
If forceStringReturn Then ReadiProperty = "" Else ReadiProperty = Null

'Optional PropSet auswerten
Dim bAllSets As Boolean, PropSetName As String
If 0 = PropSet Then
bAllSets = True
Else
bAllSets = False
PropSetName = Get_iPropSetName(PropSet)
End If
Dim bSetFound As Boolean 'für Info, ob angegebenes Set gefunden wurde
bSetFound = False

Dim prop As Property
Dim customPropSet As PropertySet

For Each customPropSet In doc.PropertySets 'Schleife durch alle PropSets
If bAllSets Or customPropSet.Name = PropSetName Then
bSetFound = True
' Get the existing property, if it exists.
'Debug.Print customPropSet.Name
On Error Resume Next
Set prop = customPropSet.Item(PropertyName)
' Check to see if the above call failed. If it failed then the property doesn't exist.
If Err.Number <> 0 Then
' Failed to get the existing property
Else
'Prop existiert, Wert lesen
ReadiProperty = prop.Value
Exit For
End If
On Error GoTo 0 'setzt auch Err zurück
End If
Next 'propSet

'Auswertung bei angegebenem PropSet
If Not bAllSets Then
If bSetFound Then
'angegebenes Set wurde gefunden
Else
'angegebenes Set wurde NICHT gefunden
MsgBox "Das gesuchte iProperty " & vbCrLf _
& vbTab & PropertyName & vbCrLf _
& "konnte nicht gefunden werden, weil schon das angegebene Prop.Set" & vbCrLf _
& vbTab & PropSetName & vbCrLf _
& "nicht existiert!", vbInformation, "Info"
End If
End If

'Aufräumen
On Error GoTo 0
Set customPropSet = Nothing
Set prop = Nothing
End Function
Private Function Get_iPropSetName(e As iPropSetNameEnum) As String
' das ist der Versuch die Propsets greifbar zu machen
' in Verbindung mit obigem Enumerator
Const IVSumInfo As String = "Inventor Summary Information"
Const DocSumInfo As String = "Inventor Document Summary Information"
Const DesignTrackProp As String = "Design Tracking Properties"
Const UserDefProp As String = "Inventor User Defined Properties"

Select Case e
Case iPropSetNameEnum.DesignTrackProp
Get_iPropSetName = DesignTrackProp
Case iPropSetNameEnum.DocSumInfo
Get_iPropSetName = DocSumInfo
Case iPropSetNameEnum.IVSumInfo
Get_iPropSetName = IVSumInfo
Case iPropSetNameEnum.UserDefProp
Get_iPropSetName = UserDefProp
Case Else
'sollte nicht auftreten
MsgBox "vmtl. Fehler in Code!" & vbCrLf _
& "Case Else in Function Get_iPropSetName", vbCritical, "Fehler!?"
Get_iPropSetName = ""
End Select
End Function

und hier die Verwendung davon im StepExport (von Dir verlinktes Beispiel - leicht angepasst). Ich weiß natürlich nicht, welche iProps Du verwenden willst, das wird also nicht passen!

Code:
Public Sub ExportToSTEP()

'Verweis auf das aktive Dokument
Dim oDoc As Document
Set oDoc = ThisApplication.ActiveDocument
' Get the STEP translator Add-In.
Dim oSTEPTranslator As TranslatorAddIn
Set oSTEPTranslator = ThisApplication.ApplicationAddIns.ItemById("{90AF7F40-0C01-11D5-8E83-0010B541CD80}")
If oSTEPTranslator Is Nothing Then
MsgBox "Could not access STEP translator."
Exit Sub
End If
Dim oContext As TranslationContext
Set oContext = ThisApplication.TransientObjects.CreateTranslationContext
Dim oOptions As NameValueMap
Set oOptions = ThisApplication.TransientObjects.CreateNameValueMap
If oSTEPTranslator.HasSaveCopyAsOptions(ThisApplication.ActiveDocument, oContext, oOptions) Then
' Set application protocol.
' 2 = AP 203 - Configuration Controlled Design
' 3 = AP 214 - Automotive Design
oOptions.Value("ApplicationProtocolType") = 3
' Other options...
' -> hier Aufruf der Funktion, um iProp zu lesen
oOptions.Value("Author") = ReadiProperty(oDoc, "Author", IVSumInfo, True)
oOptions.Value("Authorization") = "bla bla - what ever"
oOptions.Value("Description") = ReadiProperty(oDoc, "Description", DesignTrackProp, True)
oOptions.Value("Organization") = ReadiProperty(oDoc, "Company", DocSumInfo, True)
oContext.Type = kFileBrowseIOMechanism
Dim oData As DataMedium
Set oData = ThisApplication.TransientObjects.CreateDataMedium
oData.FileName = "C:\temp\temptest.stp"
Call oSTEPTranslator.SaveCopyAs(oDoc, oContext, oOptions, oData)
End If
End Sub

------------------
Gruß KraBBy

Eine Antwort auf diesen Beitrag verfassen (mit Zitat/Zitat des Beitrags) IP