Option Explicit


'Programm zur Ermittlung der Anzeigemaßstäbe
'(c) Event Engineering Jörgen Pisarz Berlin 2003
' www.event-engineering.de
'ergänzt auf Autodesk Inventor R7
'(c) Robby Lampe Dresden 2003
' www.cadport.de
' Ergänzung für mehrere Blätter von Paul Schuepbach und Michael Maier
'===========================================================
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
  Dim EE_Objekt As Object


  Dim oTextboxes As TextBoxes
  Dim oChTextbox As Inventor.TextBox



  'Objekt herstellen
  Set oDoc = ThisApplication.ActiveDocument



  Dim oSheets As Sheets
  Set oSheets = oDoc.Sheets

  Dim oSheet As Sheet

  For Each oSheet In oSheets ' Die einzelnen Blätter der Zeichnung werden durchlaufen

  oSheet.Activate ' Das Blatt wird aktiviert


  '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) 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

  Dim oSketch As DrawingSketch



  Dim oSketches As DrawingSketches
  Set oSketches = oDoc.ActiveSheet.Sketches

  'alle Zeichnungsskizzen werden durchlaufen, um die Zeichenfolge AXAYAZ00 zu finden. Diese sind die
  'Markierung für bereits erstellte Massstäbe, die dann gelöscht werden
  On Error Resume Next
  For Each oSketch In oSketches

    Set oTextboxes = oSketch.TextBoxes

    'Jetzt werden alle Textboxes in der Skizze durchlaufen und nach dem Markertext gesucht

    On Error Resume Next
    For Each oChTextbox In oTextboxes
    If oChTextbox.Text = "AXAYAZ00" Then
      oSketch.Delete ' wenn Textbox mit Markertext vorhanden, dann wird ganze Skizze gelöscht
    End If
    Next oChTextbox
  Next oSketch



  Set oSketch = oDoc.ActiveSheet.Sketches.Add

  'Skizze mit der Massstab-Textbox wird erzeugt
  oSketch.Edit

  Dim oTG As TransientGeometry
  Set oTG = ThisApplication.TransientGeometry



  Dim FSize As Double
  FSize = 0.25 'Textgröße des Massstabes in cm !

  EE_Text = "<StyleOverride FontSize='" & FSize & "'>" & EE_Text & "</StyleOverride>" 'Aktuellem
  'Textstil wird die neue Größe zugewiesen

  Set oTextboxes = oSketch.TextBoxes

  On Error Resume Next
  ' Hier wird der Markertext in der Skizze erzeugt und zwar auf einer Position ausserhalb des Blattes
  Set oChTextbox = oSketch.TextBoxes.AddFitted(oTG.CreatePoint2d(-10, -10), "AXAYAZ00")


  Dim oTextbox As Inventor.TextBox

 'Hier wird nun die Textbox erzeugt, die den Massstab in die Zeichnung einfügt. Hinter
  'CreatePoint2D stehen in der Klammer die Koordinaten in cm, wo das Feld eingefügt wird.
  'Muss individuell auf Zeichnungskopf angepasst werden
 'Zunächst wird aber geprüft, welche Blattgröße das gerade geöffnete Blatt hat, damit
 'die Textbox an der richtigen Stelle erzeugt wird
  'Inventor interne Codes (DrawingSheetSizeEnum) zur Bestimmung der Blattgröße
  '9993 ist A0, 9994 ist A1....
  'Blattorientierung (Hoch-, Querformat) ist noch nicht berücksichtigt, kommt vielleicht noch ?
  'Ist beim Anpassen ein bisschen "Fitzelei"

On Error Resume Next
  If oSheet.Size = "9993" Then
  Set oTextbox = oSketch.TextBoxes.AddFitted(oTG.CreatePoint2d(109.827, 6.788), EE_Text)
  ElseIf oSheet.Size = "9994" Then
  Set oTextbox = oSketch.TextBoxes.AddFitted(oTG.CreatePoint2d(75.004, 6.788), EE_Text)
  ElseIf oSheet.Size = "9995" Then
  Set oTextbox = oSketch.TextBoxes.AddFitted(oTG.CreatePoint2d(51.29, 5.8), EE_Text)
  ElseIf oSheet.Size = "9996" Then
  Set oTextbox = oSketch.TextBoxes.AddFitted(oTG.CreatePoint2d(33.9, 5.8), EE_Text)
  ElseIf oSheet.Size = "9997" Then
  Set oTextbox = oSketch.TextBoxes.AddFitted(oTG.CreatePoint2d(12.91, 5.8), EE_Text)
  Else
  MsgBox (" Kein DIN-Blatt.Bitte Massstab von Hand in den Zeichnungskopf schreiben! ")
 
  End If

 ' Skizzenbearbeitung wird beendet
  oSketch.ExitEdit




Next oSheet


End Sub