Attribute VB_Name = "EE_Maßstab"
Option Explicit

'Programm zur Ermittlung der Anzeigemaßstäbe
'(c) Event Engineering Jörgen Pisarz Berlin 2002

Private Function EE_FormatScale(ByVal S As Double) As String
  If S >= 1 Then
    EE_FormatScale = Format(S, "0") + ":1"
  Else
    EE_FormatScale = "1:" + Format(1 / S, "0")
  End If
End Function


Sub Einfügen()
  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
  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
  
  
  '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 = "Maßstab" Then
      EE_Da = True
      Exit For
    End If
  Next
  If EE_Da Then
    oDoc.PropertySets("{D5CDD505-2E9C-101B-9397-08002B2CF9AE}").Item("Maßstab").Value = EE_Text
  Else
    oDoc.PropertySets("{D5CDD505-2E9C-101B-9397-08002B2CF9AE}").Add EE_Text, "Maßstab"
  End If
 
End Sub