Code:
Sub Speichern()
'Parameter Definieren
Dim oApp As Inventor.Application
Dim oDoc As Document
Dim oPart As PartDocument
Dim oDrawing As DrawingDocument
Dim oAssembly As AssemblyDocument
Set oApp = ThisApplication
Set oDoc = ThisApplication.ActiveDocument
Dim oPropSets As PropertySets
Set oPropSets = oDoc.PropertySets
Dim oProp As Property
Dim oPropSet As PropertySet
' Dim oDescription As Property
Set fs = CreateObject("Scripting.FileSystemObject")
oPath = oApp.FileLocations.Workspace
'Ordner Abfragen / Erstellen
If Not fs.FolderExists(oPath & "\Assembly") Then MkDir oPath & "\Assembly"
If Not fs.FolderExists(oPath & "\Part") Then MkDir oPath & "\Part"
If Not fs.FolderExists(oPath & "\Drawing") Then MkDir oPath & "\Drawing"
If Not fs.FolderExists(oPath & "\PDF") Then MkDir oPath & "\PDF"
If Not fs.FolderExists(oPath & "\STEP") Then MkDir oPath & "\STEP"
If Not fs.FolderExists(oPath & "\DXF") Then MkDir oPath & "\DXF"
'Dokumententyp abfragen
Dim eDocumentType As DocumentTypeEnum
eDocumentType = oDoc.DocumentType
Dim sDocumentType As String
Select Case eDocumentType:
Case kAssemblyDocumentObject
sDocumentType = "Assembly Document"
Case kDesignElementDocumentObject
sDocumentType = "DesignElement Document"
Case kDrawingDocumentObject
sDocumentType = "Drawing Document"
Case kForeignModelDocumentObject
sDocumentType = "ForeignModel Document"
Case kPartDocumentObject
sDocumentType = "Part Document"
Case kUnknownDocumentObject
sDocumentType = "Unknown Document"
End Select
'Dokumenten Untergruppe abfragen
Dim sDocumentSubType As String
sDocumentSubType = oDoc.SubType
Dim sReadableType As String
'Part Dokument Untergruppen
'Part
Select Case sDocumentSubType:
Case "{4D29B490-49B2-11D0-93C3-7E0706000000}"
sReadableType = "part"
'Blech-Part
Case "{9C464203-9BAE-11D3-8BAD-0060B0CE6BB4}"
sReadableType = "sheet metal"
'Baugruppen Untergruppe
Case "{E60F81E1-49B3-11D0-93C3-7E0706000000}"
sReadableType = "assembly"
'Zeichnung Untergruppe
Case "{BBF9FDF1-52DC-11D0-8C04-0800090BE8EC}"
sReadableType = "drawing"
End Select
'Namensbestandteile auslesen bez. setzen
Dim sFullFileName As String
Dim oDescrition As PropertySet
Dim oTitel As PropertySet
Dim oProjektnummer As PropertySet
Dim oBereich As PropertySet
Dim sName1 As String
Dim sName2 As String
Dim sName3 As String
Dim sTemp1
Dim sTemp2
Dim sTemp3
'----
Set oDescription = ThisApplication.ActiveDocument.PropertySets("Design Tracking Properties")
sName1 = oDescription.Item("Description").Value
Set oTitel = ThisApplication.ActiveDocument.PropertySets("Inventor Summary Information")
Set oProjektnummer = ThisApplication.ActiveDocument.PropertySets("Inventor User Defined Properties")
sName2 = oProjektnummer.Item("Projektnummer").Value
Set oBereich = ThisApplication.ActiveDocument.PropertySets("Inventor User Defined Properties")
sName3 = oBereich.Item("Bereich").Value
If oDescription.Item("Description").Value = "" Then
sTemp1 = InputBox("Eingabe", "Beschreibung", sName1)
If sTemp1 = "" Then Exit Sub ' war Cancel
oDescription.Item("Description").Value = sTemp1
End If
If oProjektnummer.Item("Projektnummer").Value = "" Then
sTemp2 = InputBox("Eingabe", "Projektnummer", sName2)
If sTemp2 = "" Then Exit Sub ' war Cancel
oProjektnummer.Item("Projektnummer").Value = sTemp2
End If
If oBereich.Item("Bereich").Value = "" Then
sTemp3 = InputBox("Eingabe", "Bereich", sName3)
If sTemp3 = "" Then Exit Sub ' war Cancel
oBereich.Item("Bereich").Value = sTemp3
End If
'Dateinamen mit Pfad definieren
If sReadableType = "assembly" Then
sFullFileName = oPath & "\Assembly\" & oProjektnummer.Item("Projektnummer").Value & "_" & oBereich.Item("Bereich").Value & "_" & oDescription.Item("Description").Value & ".iam"
End If
If sReadableType = "part" Or sReadableType = "sheet metal" Then
sFullFileName = oPath & "\Part\" & oProjektnummer.Item("Projektnummer").Value & "_" & oBereich.Item("Bereich").Value & "_" & oDescription.Item("Description").Value & ".ipt"
End If
If sReadableType = "drawing" Then
sFullFileName = oPath & "\Drawing\" & oProjektnummer.Item("Projektnummer").Value & "_" & oBereich.Item("Bereich").Value & "_" & oDescription.Item("Description").Value & ".idw"
End If
'Dateinamen in Zwischenablage speichern
ThisApplication.CommandManager.PostPrivateEvent(kFileNameEvent, sFullFileName)
'Zwischenablage leeren
ThisApplication.CommandManager.ClearPrivateEvents()
End Sub