Makro AI2008 - vyplnit měřítko

Toto makro pro Autodesk Inventor 2008 ve výkrese doplní do uživatelských vlastností měřítko podle vybraného pohledu.

Public Sub VyplnitMeritko()
If Not ThisApplication.ActiveDocument.DocumentType = kDrawingDocumentObject Then
  MsgBox "Funkci lze použít jen ve výkrese s alepoň jedním pohledem."
  Exit Sub
 End If
 Dim oDrgDoc As DrawingDocument
 Set oDrgDoc = ThisApplication.ActiveDocument
 If oDrgDoc.SelectSet.Count < 1 Then
  MsgBox "Musí být předem vybrán určující pohled"
  Exit Sub
 End If
 Dim Vybrane As SelectSet
 Dim VybranyPohled As DrawingView
 Set Vybrane = oDrgDoc.SelectSet
 If Not Vybrane.Item(1).Type = kDrawingViewObject Then
  MsgBox "Musí být předem vybrán pohled s modelem"
  Exit Sub
 End If
 Set VybranyPohled = Vybrane.Item(1)
 Dim MeritkoPohledu As Double
 MeritkoPohledu = VybranyPohled.Scale
 Dim SpravneMeritko As String
 Select Case Round(MeritkoPohledu, 4)
  Case 0.0667
   SpravneMeritko = "1 : 15"
  Case 0.1
   SpravneMeritko = "1 : 10"
  Case 0.125
   SpravneMeritko = "1 : 8"
  Case 0.1667
   SpravneMeritko = "1 : 6"
  Case 0.2
   SpravneMeritko = "1 : 5"
  Case 0.25
   SpravneMeritko = "1 : 4"
  Case 0.3333
   SpravneMeritko = "1 : 3"
  Case 0.4
   SpravneMeritko = "2 : 5"
  Case 0.5
   SpravneMeritko = "1 : 2"
  Case 0.6667
   SpravneMeritko = "2 : 3"
  Case 0.8
   SpravneMeritko = "4 : 5"
  Case 1
   SpravneMeritko = "1 : 1"
  Case 2
   SpravneMeritko = "2 : 1"
  Case 3
   SpravneMeritko = "3 : 1"
  Case 4
   SpravneMeritko = "4 : 1"
  Case 5
   SpravneMeritko = "5 : 1"
  Case 10
   SpravneMeritko = "10 : 1"
  Case 15
   SpravneMeritko = "15 : 1"
  Case 20
   SpravneMeritko = "20 : 1"
  Case Else
   SpravneMeritko = ""
 End Select
 Dim invDTProperties As PropertySet
 Set invDTProperties = oDrgDoc.PropertySets.Item("Uživatelsky definované vlastnosti programu Inventor")
 invDTProperties.Item("Měřítko").Value = SpravneMeritko
End Sub