Code:
' **********************************************************************
' * Makro ermittelt vom aktiver Modell alle Konfigurationen.
' * Für jede der Konfigurationen wird die Zeichnung
' * auf eben diese Konfiguration umgestellt und unter neuem Namen
' * (Name der Konfiguration) gespeichert.
' *
' * Startbedingung: Das Modell und die Zeichnung MÜSSEN denselben
' * Dateinamen haben und das Modell muss geöffnet sein (Zeichnung kann
' * geschlossen sein, muss dann aber im selben Pfad gespeichert sein
' * wie das Modell)
' *
' * 27.07.2010 Stefan Berlitz
' * http://solidworks.cad.de
' * http://swtools.cad.de
' *
' **********************************************************************
' this Constants are editable to customize behaviour
' separartor for new filename / Trenner für DateinamenConst mySeparator = "_-_"
' **********************************************************************
' do not edit below this line unless you know what you are doing ;-))
Dim swApp As Object
Dim ModelDoc As Object
Dim ModelDocType As Long
Dim ModelPathName As String
Dim DrawingDoc As Object
Dim DrawingPathName As String
Dim DrawingTitle As String
Dim DrawingSaveName As String
Dim ConfigCount As Long
Dim ConfigNames As Variant
Dim ActiveSheet As Object
Dim ActiveSheetName As String
Dim Names As Variant
Dim SheetCount As Long
Dim View As Object
Dim errors As Long
Dim warnings As Long
Dim i As Long ' loop counter
Dim j As Long ' loop counter
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.
Const swSaveAsCurrentVersion = 0
Sub main()
' an SolidWorks anklinken und aktives Assembly holen
Set swApp = CreateObject("SldWorks.Application")
Set ModelDoc = swApp.ActiveDoc
If ModelDoc Is Nothing Then
' dann war gar kein Dokument geöffnet, wie soll da was funktionieren
MsgBox "Kein Dokument aktiv"
Exit Sub
End If
If (ModelDoc.GetType = swDocDRAWING) Then
' wenn keine Modell aktiv ist wird das Makro wieder beendet
MsgBox "Bitte Basis Modell aktivieren"
Exit Sub
End If
' get path and type of model
' Pfad und Typ zu diesem Modell merken
ModelPathName = ModelDoc.GetPathName
If UCase(GetExtensionOnly(ModelPathName)) = ".SLDPRT" Then
ModelDocType = swDocPART
Else
ModelDocType = swDocASSEMBLY
End If
' get alle configuration
' dann alle Konfigurationen auslesen
ConfigCount = ModelDoc.GetConfigurationCount
ConfigNames = ModelDoc.GetConfigurationNames
' Jetzt brauchen wir gleich auch die Zeichnung dazu, die MUSS denselben Namen
' haben und im selben Verzeichnis liegen wie das Basismodell
DrawingPathName = GetFullPathNoExtension(ModelPathName) & ".slddrw"
' dann für alle Konfigurationen
For i = 0 To ConfigCount - 1
' das ursprüngliche Modell referenziert auf alle Zeichnungen
openconfig = ConfigNames(i)
' die ursprüngliche Zeichnung öffnen
Set DrawingDoc = swApp.OpenDoc6(DrawingPathName, swDocDRAWING, 0, "", errors, warnings)
' 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 und 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 j = 0 To SheetCount - 1
' activate sheet
' nächstes Blatt aktivieren
DrawingDoc.ActivateSheet Names(j)
' 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 referenced configuration of the view
' überprüfen der Konfiguration der Zeichenansicht
'
View.ReferencedConfiguration = ConfigNames(i)
' ... and go for the next view
' ... und die nächste Ansicht
Set View = View.GetNextView
Wend
' if the preview should be correct we have to rebuild the sheets
' however in this case we try to make the process fast, not pretty
' und damit auch die Vorschau für jedes Blatt richtig ist ein mal durchrechnen
' wer es also schön will einfach das Rebuild einkommentieren
' DrawingDoc.EditRebuild3
Next j
' reactivate sheet which was active
' dann das vorher aktuelle Blatt reaktivieren
DrawingDoc.ActivateSheet ActiveSheetName
' generate the name of the drawing
' Namen zusammensetzen
DrawingSaveName = GetFullPathNoExtension(ModelPathName) & mySeparator & _
ConfigNames(i) & ".slddrw"
If DrawingDoc.SaveAs2(DrawingSaveName, swSaveAsCurrentVersion, False, False) Then
If MsgBox("Fehler beim Speichern von " & DrawingSaveName & " Abbrechen?", vbYesNo) = vbYes Then
End
End If
End If
' close model and drawing
' und Model und Zeichnung wieder schließen
DrawingTitle = DrawingDoc.GetTitle
swApp.CloseDoc DrawingTitle
Next i
End Sub
Private Function GetFullPathNoExtension(strPath As String) As String
'
Dim intCounter As Integer
' rückwärts bis zum Punkt suchen
For intCounter = Len(strPath) To 1 Step -1
If Mid$(strPath, intCounter, 1) = "." Then
Exit For
End If
Next intCounter
' und den Wert zurückgeben OHNE den Punkt
GetFullPathNoExtension = Left$(strPath, intCounter - 1)
End Function
Private Function GetExtensionOnly(strPath As String) As String
Dim intCounter As Integer
' rückwärts bis zum Punkt suchen
For intCounter = Len(strPath) To 1 Step -1
If Mid$(strPath, intCounter, 1) = "." Then
Exit For
End If
Next intCounter
' und den Wert zurückgeben OHNE den Punkt
GetExtensionOnly = Mid(strPath, intCounter)
End Function
Function GetPathPart(strPath As String) As String
'
Dim intCounter As Integer
' Parse the string backwards
For intCounter = Len(strPath) To 1 Step -1
' Short-circuit when we reach the slash
If Mid$(strPath, intCounter, 1) = "\" Then
Exit For
End If
Next intCounter
' Return the value
GetPathPart = Left$(strPath, intCounter)
End Function
Foren auf CAD.de (alle Foren)
| 
, einfach nach Martin Doppler in Wien suchen.
