Attribute VB_Name = "Standard_definieren"
Sub Standard_definieren()


' Durchsucht die Properties nach dem Eintrag Standard
' in Abhängigkeit vom PartSubType:
' - Bei Blechteilen wird die Blechdicke des Bauteils ausgelesen.
'     Die dazugehörige Norm wird in Abhängigkeit von der Blechdicke dazu formatiert.
' - Bei anderen Teilen wird der Eintrag nur ausgelesen.
'
' Die Vorhandenen Einträge, können editiert werden.
'
'---------------------------------------------------------------------------------
'
'(c) Lothar Boekels Ingenieurbüro für Maschinenbau 2004
'    Schroerskamp 74
'    41069 Mönchengladbach
'    kontakt@boekels-online.de
'
'    2004 02 10  Programmerstellung
'
'---------------------------------------------------------------------------------
'


Dim oDoc As Inventor.Document
Set oDoc = ThisApplication.ActiveDocument

' Check the Document type is a part
If (oDoc.DocumentType <> kPartDocumentObject) _
    And (oDoc.DocumentType <> kAssemblyDocumentObject) _
Then
    Beep
    MsgBox " kein Part oder Assembly-Document"
    Set oDoc = Nothing
    Exit Sub
End If
 
 
Dim Mldg, Stil, Titel, Hilfe, Ktxt, Antwort, Text1
Mldg = "Möchten Sie fortfahren ?"                  ' Meldung definieren.
Stil = vbOKOnly                                    ' Schaltflächen definieren.
        ' vbYesNo _
        ' vbCritical _
        ' vbDefaultButton2
Titel = "MsgBox-Demonstration"                     ' Titel definieren.
Hilfe = ""                                         ' Hilfedatei definieren.
Ktxt = 1000                                        ' Kontext für Thema definieren.
'Antwort = MsgBox(Mldg, Stil, Titel, Hilfe, Ktxt)   ' Meldung anzeigen.
 
Dim sStandard As String
Dim Voreinstellung As String

' Voreinstellung auslesen
Voreinstellung = Voreinstellung_auslesen(oDoc)
'MsgBox """" + Voreinstellung + """"


' Auffächern nach SubType
Select Case oDoc.SubType

    Case "{9C464203-9BAE-11D3-8BAD-0060B0CE6BB4}"
        'MsgBox " Blechteil "
        
        Dim sNorm  As String
        Dim sDicke As String
        Dim rDicke As Double
        
        Dim sAbwicklung As String
        Dim sX As String
        Dim sY As String
        Dim sZ As String
        
                
        sDicke = Blechteil_Dicke_auslesen(oDoc)
        rDicke = Val(sDicke)
        
        Select Case rDicke
            Case Is <= 3
                sNorm = "DIN 1541 - Blech "
            Case Else
                sNorm = "DIN 1543 - Blech "
        End Select
        
        sStandard = sNorm + sDicke
        
        sAbwicklung = IPropEintraege.Property_lesen(oDoc, "Groesse_Abwicklung")
        
        sX = Left(sAbwicklung, InStr(1, sAbwicklung, " x ", vbTextCompare) - 1)
        sAbwicklung = Mid(sAbwicklung, InStr(1, sAbwicklung, " x ", vbTextCompare) + 3)
        sY = Left(sAbwicklung, InStr(1, sAbwicklung, " x ", vbTextCompare) - 1)
        sZ = Mid(sAbwicklung, InStr(1, sAbwicklung, " x ", vbTextCompare) + 3)
        
        'MsgBox "sX = " + sX + vbCrLf + _
               "sY = " + sY + vbCrLf + _
               "sZ = " + sZ + vbCrLf
               
        sAbwicklung = ""
        
        Dim bAbmessungDa As Boolean
        bAbmessungDa = False
        
        If sX <> sDicke Then
            sAbwicklung = sAbwicklung & sX
            bAbmessungDa = True
        End If
        If sY <> sDicke Then
            If bAbmessungDa Then
                sAbwicklung = sAbwicklung & " x "
                bAbmessungDa = False
            End If
            sAbwicklung = sAbwicklung & sY
            bAbmessungDa = True
        End If
        If sZ <> sDicke Then
            If bAbmessungDa Then
                sAbwicklung = sAbwicklung & " x "
                bAbmessungDa = False
            End If
            sAbwicklung = sAbwicklung & sZ
            bAbmessungDa = True
        End If
        
        sStandard = sStandard & " - " & sAbwicklung
        
    Case "{4D29B490-49B2-11D0-93C3-7E0706000000}"
        ' MsgBox " Profil Part-Document"
        
        Dim sLaenge As String
        Dim sNennmass As String
        Dim sZusatz As String
        
        sLaenge = IPropEintraege.Property_lesen(oDoc, "Laenge")
        sNennmass = IPropEintraege.Property_lesen(oDoc, "Nennmass")
        
        If Not InStr(1, Voreinstellung, " - ") = 0 Then
        
            'suchen der DIN
            Dim sDIN As String
            sDIN = Left(Voreinstellung, InStr(1, Voreinstellung, " - ") - 1)
            'sStandard = Voreinstellung & " - " & sLaenge
        
            Dim bRegDIN As Boolean
            bRegDIN = False
        
            Select Case sDIN
            Case "DIN 1025-1"
                sZusatz = " - INP " & sNennmass & " - "
                bRegDIN = True
            Case "DIN 1025-2"
                sZusatz = " - HE-B " & sNennmass & " - "
                bRegDIN = True
            Case "DIN 1025-3"
                sZusatz = " - HE-A " & sNennmass & " - "
                bRegDIN = True
            Case "DIN 1025-4"
                sZusatz = " - HE-M " & sNennmass & " - "
                bRegDIN = True
            Case "DIN 1025-5"
                sZusatz = " - IPE " & sNennmass & " - "
                bRegDIN = True
            Case "DIN 1026"
                sZusatz = " - UNP " & sNennmass & " - "
                bRegDIN = True
            Case "DIN 2448"
                sZusatz = " - Rohr " & sNennmass & " - "
                bRegDIN = True
            Case "EN 10219-2"
                sZusatz = " - RRohr " & TrimExtended(sNennmass) & " - "
                bRegDIN = True
            Case "EN 10210-2"
                sZusatz = " - RRohr " & TrimExtended(sNennmass) & " - "
                bRegDIN = True
            Case "EN 10056-1"
                sZusatz = " - Winkel " & sNennmass & " - "
                bRegDIN = True
            Case Else
                sZusatz = " - "
                MsgBox "keine registrierte DIN"
                bRegDIN = False
            End Select
        
            If bRegDIN Then
                sStandard = sDIN & sZusatz & sLaenge
            Else
                sStandard = Voreinstellung
            End If
        Else
            sStandard = Voreinstellung
        End If
         
    Case Else
        'eigenes Teil
        sStandard = Voreinstellung ' alles bleibt, wir es ist
        
End Select


Titel = "Festlegen des IProperty-Eintags 'Standard'"

Mldg = Chr(13) & Chr(10) + "Soll die Voreinstellung " _
     + Chr(13) & Chr(10) + """" + Voreinstellung + """" _
     + Chr(13) & Chr(10) + "mit dem Eintrag unten überschrieben werden ?" _
     + Chr(13) & Chr(10) _
     + Chr(13) & Chr(10) + " 'ESC' = Abbruch : Voreinstellung wird behalten." _
     + Chr(13) & Chr(10)

Antwort = InputBox(Mldg, Titel, sStandard)

       
If Antwort = "" Then
    sStandard = Voreinstellung
    Exit Sub
Else
    sStandard = Antwort
End If
        


' iProperty mit Wert belegen
Call Standard_setzen(oDoc, sStandard)


Set oDoc = Nothing


endeSub:
End Sub

Private Sub Standard_setzen(oDoc, sStandard As String)


    Dim bStandardDa As Boolean
    Dim oProp As Property
    bStandardDa = False
    For Each oProp In oDoc.PropertySets("{32853F0F-3444-11D1-9E93-0060B03C1CA6}") 'DesignTracking Properties
        If oProp.Name = "Standard" Then
        bStandardDa = True
        Exit For
        End If
    Next
  
  
    'Standard eintragen oder ändern
    If bStandardDa Then
        oDoc.PropertySets("{32853F0F-3444-11D1-9E93-0060B03C1CA6}").Item("Standard").Value = sStandard
    Else
        oDoc.PropertySets("{32853F0F-3444-11D1-9E93-0060B03C1CA6}").Add sStandard, "Standard"
    End If


End Sub

Private Function Voreinstellung_auslesen(oDoc) As String
        
        Dim Voreinstellung As String
        
        Voreinstellung = "xxxx"
        
        
        'Standard vorhanden?
        Dim oProp As Property
        
        For Each oProp In oDoc.PropertySets("{32853F0F-3444-11D1-9E93-0060B03C1CA6}") 'DesignTracking Properties
            If oProp.Name = "Standard" Then
                Voreinstellung = oProp.Value
                Exit For
            End If
        Next
        
        Set oProp = Nothing
        
        Voreinstellung_auslesen = Voreinstellung

End Function
Private Function Standard_auslesen(oDoc) As String
        
        Dim Voreinstellung As String
        
        Voreinstellung = ""
        
        
        'Standard vorhanden?
        Dim oProp As Property
        
        For Each oProp In oDoc.PropertySets("{32853F0F-3444-11D1-9E93-0060B03C1CA6}") 'DesignTracking Properties
            If oProp.Name = "Standard" Then
                Voreinstellung = oProp.Value
                Exit For
            End If
        Next
        
        Set oProp = Nothing
        
        Standard_auslesen = Voreinstellung

End Function

Private Function Blechteil_Dicke_auslesen(oDoc) As String
    
        Dim sDickeWert As String
        Dim sDickeEinheit As String
  
        sDicke = oDoc.UnitsOfMeasure.GetStringFromValue _
            ( _
            oDoc.ComponentDefinition.ActiveSheetMetalStyle.Thickness.Value, _
            oDoc.UnitsOfMeasure.LengthUnits _
            )
        ' String auseinandernehmen
        sDickeWert = Left$(sDicke, InStr(1, sDicke, " ", vbTextCompare) - 1)
        sDickeEinheit = Right$(sDicke, Len(sDicke) - InStr(1, sDicke, " ", vbTextCompare))
            
            
        ' rechte Nullen löschen, falls es Nachkommastellen sind
        If InStr(1, sDickeWert, ",", vbTextCompare) Then
    
            While Right$(sDickeWert, 1) = "0"
                sDickeWert = Left$(sDickeWert, Len(sDickeWert) - 1)
            Wend
    
            ' rechtes Komma bei bedarf auch löschen
            If Right$(sDickeWert, 1) = "," Then
                sDickeWert = Left$(sDickeWert, Len(sDickeWert) - 1)
            End If
    
    
        End If
  
        ' String zusammensetzen
        'Blechteil_Dicke_auslesen = "Blech " + sDickeWert + " " + sDickeEinheit
        Blechteil_Dicke_auslesen = sDickeWert

    

End Function
Sub TestTrimExtended()
    MsgBox TrimExtended("   Das   ist   ein   Test!   ")
End Sub

Public Function TrimExtended(ByVal strReplace As Variant)

'Diese Function schneidet alle Leerzeichen vor und hinter dem übergebenen String ab.
'Ausserdem werden innerhalb des Strings mehrfach vorkommende Leerzeichen
'bis auf die angegebene Anzahl reduziert bzw entfernt.
'
'
'Der Aufruf erfolgt wie folgt:
'MsgBox TrimExtended("   Das   ist   ein   Test!   ")


    
    Dim i, j As Integer
 
    If IsNull(strReplace) Then Exit Function
     
    strReplace = Trim(strReplace)
    
    'Angabe wieviel Spaces am Stück verbleiben sollen
    j = 0
    
    i = InStr(1, strReplace, Space(j + 1))
 
    While i > 0
      strReplace = Left(strReplace, i - 1) & Mid(strReplace, i + 1)
      i = InStr(1, strReplace, Space(j + 1))
    Wend
 
    TrimExtended = strReplace
 
End Function


Sub dummy()

End Sub