Option Explicit
'Programm zur Ermittlung der Anzeigemaßstäbe
'(c) Event Engineering Jörgen Pisarz Berlin 2003
' www.event-engineering.de
'ergänz auf Autodesk Inventor R7
'(c) Robby Lampe Dresden 2003
' www.cadport.de
'===========================================================
Private Function EE_FormatScale(ByVal S As Double) As String
' Stand: 01.09.2003
  If S >= 1 Then
    If (10 * S Mod 10) = 0 Then
      EE_FormatScale = Format(S, "0") + ":1"
    Else
      EE_FormatScale = Format(S, "0.0") + ":1"
    End If
  Else
    If (10 * (1 / S) Mod 10) = 0 Then
      EE_FormatScale = "1:" + Format(1 / S, "0")
    Else
      EE_FormatScale = "1:" + Format(1 / S, "0.0")
    End If
  End If
End Function

Sub Massstab()
  Dim I, J, K As Integer
  Dim EE_MainScale, EE_TestScale As Double
  Dim EE_SiteScale(10) As Double
  Dim EE_Text As String
  Dim EE_Da As Boolean
  Dim EE_Prop As Property
  Dim oDoc As Document
  Dim EE_Objekt As Object
  
  'Objekt herstellen
  Set oDoc = ThisApplication.ActiveDocument
  
  'Funktioniert nur, wenn Drawing und mindestens eine Ansicht vorhanden ist:
  If oDoc.DocumentType <> kDrawingDocumentObject Then Exit Sub
  If oDoc.ActiveSheet.DrawingViews.Count = 0 Then Exit Sub
  
    'Ermittle die Hauptansicht und Hauptmaßstab
    EE_MainScale = oDoc.ActiveSheet.DrawingViews(1).Scale
  
  'Ermittle weitere Ansichten
  J = 0
  For I = 1 To oDoc.ActiveSheet.DrawingViews.Count
    'Ermittle weitere Maßstäbe
    EE_TestScale = oDoc.ActiveSheet.DrawingViews(I).Scale
    'Prüfe, ob gleich hauptmaßstab
    If EE_TestScale <> EE_MainScale Then
      'Prüfe, ob schon als Nebenmaßstab vorhanden
      If J > 0 Then
        For K = 0 To J
          If EE_TestScale = EE_SiteScale(K) Then
            EE_TestScale = 0
            Exit For
          End If
        Next K
      End If
      If EE_TestScale <> 0 Then
        'Nimm in die Liste auf
        EE_SiteScale(J) = EE_TestScale
        J = J + 1
        'Die liste ist begrenzt...
        If J = 11 Then Exit For
      End If
    End If
  Next I
  'Erstelle Zeichenfolge
  ' das Original
  'EE_Text = EE_FormatScale(EE_MainScale)
  'If J > 0 Then
  '  EE_Text = EE_Text + " ("
  '  For I = 0 To J - 1
  '    If I > 0 Then
  '      EE_Text = EE_Text + " "
  '    End If
  '    EE_Text = EE_Text + EE_FormatScale(EE_SiteScale(I))
  '  Next I
  '  EE_Text = EE_Text + ")"
  'End If
  
  EE_Text = EE_FormatScale(EE_MainScale)
  If J > 0 Then
    EE_Text = EE_Text + " ["
    For I = 0 To J - 1
      If (I > 0) And (I < 2) Then
        EE_Text = EE_Text + " "
      End If
      If (I > 1) Then
        EE_Text = EE_Text + ", "
      End If
      EE_Text = EE_Text + EE_FormatScale(EE_SiteScale(I))
    Next I
    EE_Text = EE_Text + "]"
  End If

  
  
  'Füge Zeichenfolge ein
  'Maßstab vorhanden?
  EE_Da = False
  For Each EE_Prop In oDoc.PropertySets("{D5CDD505-2E9C-101B-9397-08002B2CF9AE}") 'Benutzerdefiniert
    If EE_Prop.name = "FirstViewScale" Then
      EE_Da = True
      Exit For
    End If
  Next
  If EE_Da Then
    oDoc.PropertySets("{D5CDD505-2E9C-101B-9397-08002B2CF9AE}").Item("FirstViewScale").Value = EE_Text
  Else
    oDoc.PropertySets("{D5CDD505-2E9C-101B-9397-08002B2CF9AE}").Add EE_Text, "FirstViewScale"
  End If
      ThisApplication.ActiveDocument.Update
End Sub