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 DrawingDocument 'Drawing eingefügt !!
  Dim EE_Objekt As Object
  
  'PAUL begin
  Dim oTextboxes As TextBoxes
  Dim oChTextbox As Inventor.TextBox
  'PAUL end
  
  
  'Objekt herstellen
  Set oDoc = ThisApplication.ActiveDocument
  
  
  
  Dim oSheets As Sheets
  Set oSheets = oDoc.Sheets
  
  Dim oSheet As Sheet
  
  For Each oSheet In oSheets
 
  oSheet.Activate
  
  
  '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 = "Massstab" Then
'      EE_Da = True
'      Exit For
'    End If
'  Next
'  If EE_Da Then
'    oDoc.PropertySets("{D5CDD505-2E9C-101B-9397-08002B2CF9AE}").Item("Massstab").Value = EE_Text
  

  Dim oSketch As DrawingSketch
  
  
  'PAUL begin
  Dim oSketches As DrawingSketches
  Set oSketches = oDoc.ActiveSheet.Sketches
  
  For Each oSketch In oSketches
   ' Dim oTextboxes As Inventor.TextBoxes
    Set oTextboxes = oSketch.TextBoxes
    'Dim oChTextbox As Inventor.TextBox
   ' Set oChTextbox = oText
    
 On Error Resume Next
    For Each oChTextbox In oTextboxes
    If oChTextbox.Text = "AAAA" Then
      oSketch.Delete
    End If
    Next oChTextbox
  Next oSketch
  'PAUL end
  
  
  Set oSketch = oDoc.ActiveSheet.Sketches.Add

  
  oSketch.Edit
  
  Dim oTG As TransientGeometry
  Set oTG = ThisApplication.TransientGeometry


  'PAUL begin
  Dim FSize As Double
  FSize = 0.25
  
  EE_Text = "<StyleOverride FontSize='" & FSize & "'>" & EE_Text & "</StyleOverride>"
  
  Set oTextboxes = oSketch.TextBoxes
  
  On Error Resume Next
  Set oChTextbox = oSketch.TextBoxes.AddFitted(oTG.CreatePoint2d(-10, -10), "AAAA")
  
  'PAUL end
 
 
 
  Dim oTextbox As Inventor.TextBox

  Set oTextbox = oSketch.TextBoxes.AddFitted(oTG.CreatePoint2d(51.3, 5.8), EE_Text)
  
  
  oSketch.ExitEdit
    
'    Else
'    oDoc.PropertySets("{D5CDD505-2E9C-101B-9397-08002B2CF9AE}").Add EE_Text, "Massstab"
  'End If


Next oSheet


End Sub