Code:
' **********************************************************************
' * Macro iterates through all views of all sheets of active drawing
' * and set the display mode to "high quality". This is espacially
' * useful for exporting, since there is no option in the "Save as"
' * dialog to autoconvert to high-quality prior to saving.
' * It is also useful for SW2003 FastHLR views (which is the same as
' * SW2004 draft mode views)
' *
' * Makro durchläuft alle Ansichten auf allen Blättern der aktiven
' * Zeichnung und stellt die Anzeigeart derausgeblendeten Ansichten auf
' * "Entwurfsqualität".
' *
' * 12.09.2003 Stefan Berlitz
' * http://solidworks.cad.de
' * http://swtools.cad.de
' *
' * 05.05.2021 TKL
' *
' **********************************************************************Dim swApp As Object
Dim DrawingDoc As Object
Dim ActiveSheet As Object
Dim ActiveSheetName As String
Dim Names As Variant
Dim SheetCount As Long
Dim View As Object
Dim ViewName As String
Dim ViewCount As Long
Dim displayMode As Integer
Dim displayEdgesInShadedMode As Boolean
Dim displayUseParentDisplayMode As Boolean
Dim i As Long ' loop counter
Dim msgtext(2) As String ' some texts for multi-language support
Const swDocNONE = 0 ' Used to be TYPE_NONE
Const swDocPart = 1 ' Used to be TYPE_PART
Const swDocASSEMBLY = 2 ' Used to be TYPE_ASSEMBLY
Const swDocDRAWING = 3 ' Used to be TYPE_DRAWING
Const swDocSDM = 4 ' Solid data manager.
Sub main()
' get the SolidWorks Object
' an SolidWorks anklinken
Set swApp = CreateObject("SldWorks.Application")
' choose active language
' und die Spracheinstellung überprüfen
CheckLanguage
'
' get active document, should be a drawing
' das aktive Dokument holen, sollte eine Drawing sein
Set DrawingDoc = swApp.ActiveDoc
'
' if no active document, exit; it is userfriendly to
' pop up an error message ;-)
' kein Dokumewnt -> User benachrichtigen
If DrawingDoc Is Nothing Then
MsgBox msgtext(0)
Exit Sub
End If
'
' check if a drawing is active
' dito wenn es keine Zeichnung ist
If (DrawingDoc.GetType <> swDocDRAWING) Then
MsgBox msgtext(1)
Exit Sub
End If
'
' Now iterate through sheets. We should remember which sheet was
' active so we can avtivate it after the process
' Jetzt durch alle Blätter laufen. Wir merken uns das gerade aktive
' Blatt um anschließend dahin zurück zu kehren
Set ActiveSheet = DrawingDoc.GetCurrentSheet
ActiveSheetName = ActiveSheet.GetName
'
' get the sheet count and loop over all sheets
' dann die Anzahl der Blätter holen und alle nacheinander anspringen
SheetCount = DrawingDoc.GetSheetCount
Names = DrawingDoc.GetSheetNames
For i = 0 To SheetCount - 1
' activate sheet
' nächstes Blatt aktivieren
DrawingDoc.ActivateSheet Names(i)
' now iterate over the drawing views; the first view is
' always the sheet itself and there is never a model in
' it, but it's easier to check every view the same way
' alle Ansichten nacheiander durchlaufen; die erste View ist immer
' das Blatt selbst und enthält kein Modell, aber der Einfachheit
' halber machen wir für alle Ansichten das Gleiche
Set View = DrawingDoc.GetFirstView
' as long as there is a valid view
' solange es noch eine Ansicht gibt
While Not View Is Nothing
' check whether view is displayed facetted (= draft quality)
' überprüfen, ob der View überhaupt facettiert (= Entwurfsmodus) ist
'
'If View.GetFacettedHlrDisplay = False Then
If View.GetVisible = False Then
' get the current display mode (wireframe, HLG or HLR)
' dann den aktuelle Anzeigeart holen
displayMode = View.GetDisplayMode
' and whether the edges should be displayed if view is shaded
' und überprüfen, ob die Kanten bei schattierter Ansicht dargestellt werden
displayEdgesInShadedMode = View.GetDisplayEdgesInShadedMode
'
' set the view to non-facetted
' die Ansicht auf Entwurfsqualität setzen
'
displayUseParentDisplayMode = View.GetUseParentDisplayMode
View.SetDisplayMode3 False, displayMode, True, True
Else
View.SetDisplayMode3 False, displayMode, False, displayEdgesInShadedMode
End If
' ... and go for the next view
' ... und die nächste Ansicht
Set View = View.GetNextView
Wend
Next i
' reactivate sheet which was active
' dann das vorher aktuelle Blatt reaktivieren
DrawingDoc.ActivateSheet ActiveSheetName
MsgBox msgtext(2)
End Sub
Private Sub CheckLanguage()
' check which language to apply. To make another language
' copy one of Subs called XyzString and make your changes
'
' Hier ausgucken welche Sprache benutzt wird. Um weitere
' Sprachen zu unterstützen unten einer der Subs kopieren
' Anpassungen machen und aufrufen
' Set swApp = CreateObject("SldWorks.Application") ' set by Sub main()
Select Case swApp.GetCurrentLanguage
Case "german"
msgtext(0) = "Kein Dokument offen, was sollte ich denn wohl tun?"
msgtext(1) = "Nur sinnvoll bei Zeichnungen"
msgtext(2) = "Bearbeitung abgeschlossen!"
' Case "english"
' english is default, so change there
' Case "spanish"
' Case "french"
' Case "italian"
' Case "japanese"
Case Else
' english is default
msgtext(0) = "Nothing opened, so what should I look at?"
msgtext(1) = "Only useful with drawing"
msgtext(2) = "Editing finished!"
End Select
End Sub