02-21-2018
06:05 AM
- Mark as New
- Bookmark
- Subscribe
- Mute
- Subscribe to RSS Feed
- Permalink
- Report
02-21-2018
06:05 AM
Thanks for the code, works a treat!
The only thing i noticed was that if you try and save the drawing when it is a blank, it throws up an error, so i added an 'on error resume next', and that seems to solve the problem.
Dim oDrawDoc As DrawingDocument
Dim oSheet As Sheet
Dim oCurrentSheet As Sheet
Dim oSheets As Sheets
Dim oView As DrawingView
Dim oViews As DrawingViews
Dim oScale As Double
Dim oFView As String
On Error Resume Next
'get the current drawing
oDrawDoc = ThisDoc.Document
'get the active sheet
oCurrentSheet = oDrawDoc.ActiveSheet
'get the sheets collection
oSheets = oDrawDoc.Sheets
'look at each sheet
For Each oSheet In oSheets
oFlag = True 'set flag to default value
oSheet.Activate 'activate the sheet
oViews = oSheet.DrawingViews 'get the views collection
oFView = oSheet.DrawingViews(1).Name 'adds the NAME of the first view in sheet to oFView
oScale = ActiveSheet.View(oFView).Scale 'sets the SCALE of the first view to OScale
'look at each view
For Each oView In oViews
'compare view scale to 1st view scale
If oView.Scale <> oScale Then
oFlag = False 'trip the flag
End If
Next
'alert user if flag is tripped (indicating differing scales)
If oFlag = False Then
MessageBox.Show("Some drawing views on " & _
oSheet.Name & " are not the same scale", "Check Scales")
End If
Next
'set original sheet as active
oCurrentSheet.Activate