'VB_Name = "EE_Maßstab"

Option Explicit

'Programm zur Ermittlung der Anzeigemaßstäbe
'
'(c) Event Engineering Jörgen Pisarz Berlin 2002
'
'------------------------------------------------------------------------------
'
'(c) Lothar Boekels Ingenieurbüro für Maschinenbau
'
'    28.03.2003  Formatierung des Maßstabes so, daß auch nicht ganzzahlige Maßstäbe
'                korrekt dargestellt werden. zB. 1 : 2,5  oder 2,5 : 1
'
'------------------------------------------------------------------------------

Private Function EE_FormatScale(ByVal S As Double) As String

    Dim i As Integer

    If S >= 1 Then
        's:1
        If S = Int(S) Then
            EE_FormatScale = Format(S, "0") + ":1"
        Else
            i = 0
            Do Until S = Round(S, i)
                i = i + 1
                If i = 3 Then
                    Exit Do
                End If
            Loop
            EE_FormatScale = CStr(Round(S, i)) + ":1"
        End If
    Else
        ' 1:s
        S = 1 / S
        If S = Int(S) Then
            EE_FormatScale = "1:" + Format(S, "0")
        Else
            i = 0
            Do Until S = Round(S, i)
                i = i + 1
                If i = 3 Then
                    Exit Do
                End If
            Loop
            EE_FormatScale = "1:" + CStr(Round(S, i))
        End If
    End If
    
End Function


Sub Massstab_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
  
  
  '"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
  
  ' Maßstab eintragen oder ändern
  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