Hi Grant, Can't remember where i got this little snippet from, but it works.
Option Explicit
'Always use X and Y in the Scale display string
'Example HowToDisplayFirstViewScale=[X:Y] will display as [1:2] in the properties
Const HowToDisplayFirstViewScale As String = "X:Y"
'Always use X and Y in the Scale display string
'Example HowToDisplayAllViewScales=X:Y will display as 1:2 in the properties
Const HowToDisplayAllViewScales As String = "X:Y"
'Set the charactor for the All View Scales list separator
'Example ListSparator="," the list will dispaly as [5:1],[1:1]
Const ListSparator As String = " "
'Value that will control if the the First View is excluded from the All View Scales list
'True: Exclude the Scale of the First View from the All View Scales list
'False: All View Scales are included in the list
Const ExcludeFirstInAllScales As Boolean = True
'True: Uses the same display style as inventor, Scale 2.5 is shown as 2.5:1
'False: Always find an integer value for both values, Scale 2.5 is shown as 5:2
Const ShowScaleAsInventor As Boolean = True
Const ShowScaleAsInventorDecimals As Integer = 2
Public Sub AutoSave_View_Scale()
Call ShowFirstViewScale
Call AddRevs
End Sub
Private Sub ShowFirstViewScale()
Dim oDrawDoc As DrawingDocument
Set oDrawDoc = ThisApplication.ActiveDocument
Dim ScaleProp As String
On Error Resume Next
'Find the Scale of the first View on the first Sheet
ScaleProp = ConvScale2Fraction(oDrawDoc.Sheets.Item(1).DrawingViews.Item(1).Scale, True)
'Add a custom property "Scale" with all the view scales
Dim oPropSet As PropertySet
Set oPropSet = ThisApplication.ActiveDocument.PropertySets("{D5CDD505-2E9C-101B-9397-08002B2CF9AE}")
Call oPropSet.Item("Drawing Scale").Delete
Call oPropSet.Add(ScaleProp, "Drawing Scale")
'Still having some problems that the last property does not update correct
Call RefreshProperties
End Sub
Private Function ConvScale2Fraction(ValScale As Double, FirstView As Boolean) As String
Dim TempStr As String
Dim sx As Long
Dim sy As Long
Dim dsx As Double
Dim dsy As Double
'Convert the deciaml value to a fraction
Call DecToFrac(ValScale, sx, sy)
dsx = sx
dsy = sy
If ShowScaleAsInventor Then
If sx > 1 And sy >= 1 Then
dsx = Round(ValScale, ShowScaleAsInventorDecimals)
dsy = 1
End If
End If
If FirstView Then
TempStr = Replace(UCase(HowToDisplayFirstViewScale), "X", CStr(dsx))
ConvScale2Fraction = Replace(TempStr, "Y", CStr(dsy))
Else
TempStr = Replace(UCase(HowToDisplayAllViewScales), "X", CStr(dsx))
ConvScale2Fraction = Replace(TempStr, "Y", CStr(dsy))
End If
End Function
Private Sub DecToFrac(DecimalNum As Double, Numerator As Long, Denom As Long)
' The BigNumber constant can be adjusted to handle larger fractional parts
Const BigNumber = 1000
Const SmallNumber = 0.0001
Dim Inverse As Double, FractionalPart As Double
Dim WholePart As Long, SwapTemp As Long
Inverse = 1 / DecimalNum
WholePart = Int(Inverse)
FractionalPart = Frac(Inverse)
If 1 / (FractionalPart + SmallNumber) < BigNumber Then
' Notice that DecToFrac is called recursively.
Call DecToFrac(FractionalPart, Numerator, Denom)
Numerator = Denom * WholePart + Numerator
SwapTemp = Numerator
Numerator = Denom
Denom = SwapTemp
Else ' If 1 / (FractionalPart + SmallNumber) > BigNumber
' Recursion stops when the final value of FractionalPart is 0 or
' close enough. SmallNumber is added to prevent division by 0.
Numerator = 1
Denom = Int(Inverse)
End If
End Sub
' This function is used by DecToFrac and DecToProperFact
Private Function Frac(x As Double) As Double
Frac = Abs(Abs(x) - Int(Abs(x)))
End Function
' This additional procedure handles "improper" fractions and returns
' them in mixed form (a b/c) when the numerator is larger than the denominator
Private Sub DecToProperFrac(x As Double, a As Long, b As Long, c As Long)
If x > 1 Then a = Int(x)
If Frac(x) <> 0 Then
Call DecToFrac(Frac(x), b, c)
End If
End Sub
Private Sub RefreshProperties()
Dim oPropSet As PropertySet
Dim oPropSets As PropertySets
Set oPropSet = ThisApplication.ActiveDocument.PropertySets("{D5CDD505-2E9C-101B-9397-08002B2CF9AE}")
Call oPropSet.Add("", "MyDummy")
oPropSet.Item("MyDummy").Delete
Call oPropSets.FlushToFile
End Sub
It creates a custom iProperty, which you can put into a test box in the right location, and updates itself on save.
Hope this helps
Jon