|
SolidWorks MakroMania ist eine Beispielsammlung einiger Makros, die Ihnen eine Vorstellung davon geben soll, was man auch schon mit Makros in SolidWorks alles anstellen kann. Der Code des Makros sollte so gut dokumentiert sein, dass Sie damit ohne weitere Anleitung verstehen, was gemacht wird. |
< voriges |
MakroMania Übersicht |
Nummer 29 Blattformate austauschen |
|
Ich übernehme keine Haftung für die korrekte Funktion der Routinen oder irgendwelcher Schäden bei der Anwendung dieser Beispiele. Das gesamte Risiko trägt der Benutzer selbst. - Sorry, muss sein.
Das Makro tauscht die Blattformate (also praktisch die Zeichenfläche) für alle Blätter der aktiven Zeichnung aus. Dabei ist im Makro der Pfad zu den "neuen" Blattformaten fest verankert und muss für Ihre Umgebung angepasst werden. Nach erfolgreichem Änderung wird die Zeichnung unter dem aktuellen Namen gespeichert.
ACHTUNG: mit diesem Makro kann nicht die Zeichnungsvorlage geändert werden, das ist nicht möglich, da diese nur für neue Zeichnungen genutzt wird. Alle Blätter sind nachher auf "benutzerdefiniert" umgestellt, wenn Sie die "normalen" A-A0 Einstellungen benötigen ändern Sie unten die entsprechenden Calls ab oder nutzen das abgewandelte Makro, dass die Standardvorlagen erneut lädt
Das Makro ist darauf ausgelegt in Batchmodus mit PAC4SWX zu arbeiten, um Blattvorlage automatisiert auszutauschen. Dies kann z.B. notwendig sein, wenn das Firmenlogo geändert wird oder am Schriftkopf geändert wurde. Das Makro läuft aber auch, wenn es aus SolidWorks gestartet wird und müsste auch mit dem TaskPlaner laufen (aber nicht getestet); aber besser wäre es natürlich, Sie benutzen PAC4SWX
' **********************************************************************
' * BITTE die Pfade und Dateinamen für die Blattformate anpassen
' **********************************************************************
' * PLEASE change the path/filename for the sheet templates (see below)
' **********************************************************************
' *
' * Makro tauscht die Blattformate (also praktisch die Zeichenfläche)
' * für alle Blätter der aktiven Zeichnung aus. Dabei ist im Makro der
' * Pfad zu den "neuen" Blattformaten fest verankert und muss für Ihre
' * Umgebung angepasst werden. Nach erfolgreichem Änderung wird die
' * Zeichnung unter dem aktuellen Namen gespeichert.
' * ACHTUNG: mit diesem Makro kann NICHT die Zeichnungsvorlage geändert
' * werden, das ist nicht möglich, da diese nur für neue Zeichnungen
' * genutzt wird. Alle Blätter sind nachher auf "benutzerdefiniert"
' * umgestellt, wenn Sie die "normalen" A-A0 Einstellungen benötigen
' * ändern Sie unten die entsprechenden Calls ab oder nutzen das
' * abgewandelte Makro, dass die Standardvorlagen erneut lädt
' *
' * Das Makro ist darauf ausgelegt in Batchmodus mit PAC4SWX zu arbeiten,
' * um Blattvorlage automatisiert auszutauschen. Dies kann z.B. notwendig
' * sein, wenn das Firmenlogo geändert wird oder am Schriftkopf geändert
' * wurde. Das Makro läuft aber auch, wenn es aus SolidWorks gestartet
' * wird und müsste auch mit dem TaskPlaner laufen (aber nicht getestet);
' * aber besser wäre es natürlich, Sie benutzen PAC4SWX
' *
' * Macro changes the sheetformat (= the "paper" of your drawing) for
' * all sheets of the active drawing. You have to adjust the path and
' * the file names to the new sheet formats. After successfully changing
' * the sheetformat the drawing is saved with its current name.
' * ATTENTION: you CAN'T change the drawing template, this is not
' * possible. So with this macro you can't update document properties.
' * All sheet formats will be "userdefinied" after updating with this
' * macro. If you want to have the "standard" A-A0 formats and not
' * userdefinied you have to change the macro accordingly or use its
' * "compagnion" which reloads a standard sheettemplate
' *
' * This macro is intended to be used with PAC4SWX for batch reloading
' * of sheetformats, in case you changed you sheetformat with a new
' * company logo, new title block layout or similar. But it will also
' * word if fired from the GUI (taskplaner not tested, but should work;
' * but I would like to see you using PAC4SWX instead of taskplaner ;-))
' *
' * PAC4SWX - http://swtools.cad.de/prog_pac.htm
' *
' * 17.12.2003 Stefan Berlitz
' * SolidWorks Solution Partner
' * http://swtools.cad.de
' * Inoffizielle deutsche SolidWorks Hilfeseite
' * http://solidworks.cad.de
' *
' **********************************************************************
Dim msgtext(6) As String ' some texts for multi-language support
Sub main()
Dim sheetformatpath(12) As String
Dim sheetformatdir As String
' choose active language
' und die Spracheinstellung überprüfen
CheckLanguage
' ************ EDIT path and file name HERE ************************
' After editing the sheetformats delete the next line or comment it
' Bitte nach dem Editieren der nächste Zeile löschen oder auskommentieren
If MsgBox(msgtext(6), vbOKOnly, "Please Edit Macro") = vbOK Then End
' Path to directory with sheetformats
sheetformatdir = "q:\solidworks\sw2003\china\"
' path to the various sheet formats from A to A0, you may also use
' full pathnames, but if they are all in teh same subdir it's easier this way
' Vollständigen Pfad für die verschiedenen Blattformate
sheetformatpath(0) = sheetformatdir & "temp_a.slddrt"
sheetformatpath(1) = sheetformatdir & "temp_av.slddrt"
sheetformatpath(2) = sheetformatdir & "temp_b.slddrt"
sheetformatpath(3) = sheetformatdir & "temp_c.slddrt"
sheetformatpath(4) = sheetformatdir & "temp_d.slddrt"
sheetformatpath(5) = sheetformatdir & "temp_e.slddrt"
sheetformatpath(6) = sheetformatdir & "temp_a4.slddrt"
sheetformatpath(7) = sheetformatdir & "temp_a4v.slddrt"
sheetformatpath(8) = sheetformatdir & "temp_a3.slddrt"
sheetformatpath(9) = sheetformatdir & "temp_a2.slddrt"
sheetformatpath(10) = sheetformatdir & "temp_a1.slddrt"
sheetformatpath(11) = sheetformatdir & "temp_a0.slddrt"
' already user defined
' ist schon benutzerdefiniert
sheetformatpath(12) = sheetformatdir & "blank.slddrt"
' ************************* EDIT END *******************************
' zunächst mal ein paar Deklarartionen die gebraucht werden
Dim SwApp As Object
Dim DrawingDoc As Object
Dim Sheet As Object
Dim Titel As String
Dim Datei As String
Dim temp As String
Dim pfad As String
Dim msgtxt As String
Dim Name As String
Dim paperSize As Long
Dim templateIn As Long
Dim scale1 As Double
Dim scale2 As Double
Dim firstAngle As Boolean
Dim templateName As String
Dim Width As Double
Dim Height As Double
Dim propertyViewName As String
Dim i As Long
Dim AnzahlBl As Long
Dim SheetNames As Variant
Dim SheetProperties As Variant
Const swDocDRAWING = 3
Const swDwgTemplateCustom = 12
Const swDwgTemplateNone = 13
' an SolidWorks anhängen
' attach to SolidWorks
Set SwApp = CreateObject("SldWorks.Application")
Set DrawingDoc = SwApp.ActiveDoc
If DrawingDoc Is Nothing Then
' check if document is open
' dann war gar kein Dokument geöffnet, wie soll da was funktionieren
MsgBox msgtext(0)
Exit Sub
End If
If (DrawingDoc.GetType <> swDocDRAWING) Then
' check if document is a drawing
' wenn keine Zeichnung aktiv wird das Makro wieder beendet
MsgBox msgtext(1)
Exit Sub
End If
' get sheet count and traverse all sheets to reload sheetfromat
'
' die Anzahl der Blätter holen, und dann in der Schleife eines nach
' dem anderen neues Blattformat laden. Dazu Handle auf das aktuelle Blatt holen
AnzahlBl = DrawingDoc.GetSheetCount
SheetNames = DrawingDoc.GetSheetNames
' reset error messages
' Fehlermeldung zurücksetzen
msgtxt = ""
For i = 0 To AnzahlBl - 1
' activate next sheet
' das nächste Blatt aktivieren
If DrawingDoc.ActivateSheet(SheetNames(i)) Then
' attach to sheet object
' Objektzeiger für das Blatt holen
Set Sheet = DrawingDoc.GetCurrentSheet
SheetProperties = Sheet.GetProperties
' first we have to set the sheet to use "no sheetformat", for SolidWorks
' wont reload a sheetformat if it is the same name as before
' und im ersten Schritt das Blatt erst einmal ganz ohne Vordruck
' setzen, da SolidWorks das Blattformat nicht tauscht, wenn es
' vorher und nachher gleich heißt!
Name = Sheet.GetName
paperSize = SheetProperties(0)
' set NO SHEETFORMAT
' Hier jetzt erst einmal KEIN Format setzen
templateIn = swDwgTemplateNone
scale1 = SheetProperties(2)
scale2 = SheetProperties(3)
firstAngle = CBool(SheetProperties(4))
' no sheetformat = no path
' infolgedessen auch keinen Blattformatpfad
templateName = ""
' but we need the sheet size
' aber dann brauchen wir die Blattgröße
Width = SheetProperties(5)
Height = SheetProperties(6)
propertyViewName = Sheet.CustomPropertyView
retval = DrawingDoc.SetupSheet4( _
Name, _
paperSize, _
templateIn, _
scale1, _
scale2, _
firstAngle, _
templateName, _
Width, _
Height, _
propertyViewName)
If retval = False Then
msgtxt = msgtxt & msgtext(2) & vbCrLf
Else
' and now we set the new sheetformat; it is necessary to set
' USER DEFINIED sheetformat for SolidWorks will look for the
' standard templates temp_??.slddrt in your spefified folder
' if using the standard sheet sizes.
' und dann das neue Blattformat (Vorlage) einsetzen
' benutzerdefinierte Format einstellen, da ansonsten IMMER nach
' den entsprechenden Vordrucken temp_??.slddrt im eingestellten
' Blattformatverzeichnis gesucht wird
templateIn = swDwgTemplateCustom
' get correct sheetformat for this size depending on the
' papersize, this will allow aleady userdefined sheetformats
' to properly be reloaded
' zur Blattgröße passenden Vordruck raussuchen, das passiert
' aufgrund der Blattgröße, damit auch Blätter, die bereits
' benutzerdefiniert sind, korrekt nachgeladen werden
paperSize = GetSheetSizeFromPaperSize(Width, Height)
templateName = sheetformatpath(paperSize)
retval = DrawingDoc.SetupSheet4( _
Name, _
paperSize, _
templateIn, _
scale1, _
scale2, _
firstAngle, _
templateName, _
Width, _
Height, _
propertyViewName)
If retval = False Then
' Fehler: konnte neuen Vordruck nicht laden
' ERROR : can't load new sheetformat
msgtxt = msgtxt & msgtext(3) & templateName & vbCrLf
Else
' everything worked fine, no message here for automation
' dann hat ja alles geklappt
' save the document without backup
' und das Dokument noch speichern
If DrawingDoc.Save2(True) > 0 Then
' error saving file
' Fehler beim Speichern
msgtxt = msgtxt & msgtext(5) & vbCrLf
End If
End If
End If
Else
msgtxt = msgtxt & msgtext(4) & Name & vbCrLf
End If
Next i
' und noch die Zusammenfassung übers Speichern ausgeben
If Len(msgtxt) Then
MsgBox msgtxt
End If
End Sub
Private Sub CheckLanguage()
' check which language to apply. To make another language
' copy one of the CASE fileds and make your changes
'
' Hier ausgucken welche Sprache benutzt wird. Um weitere
' Sprachen zu unterstützen unten einer der CASE Bereiche
' 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) = "*** FEHLER: konnte Blatt nicht zurücksetzen "
msgtext(3) = "*** FEHLER: konnte Blatt nicht auf neuen Vordruck setzen. Vordruck vorhanden? "
msgtext(4) = "*** FEHLER: konnte Blatt nicht aktivieren "
msgtext(5) = "*** FEHLER: konnte Dokument nicht speichern "
msgtext(6) = "Bitte erst das Makro anpassen, dazu auf Extras/Makros/Editieren klicken"
' 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) = "*** ERROR: can't reset sheet "
msgtext(3) = "*** ERROR: can't set new sheetformat for drawing. Sheetformat file exists? "
msgtext(4) = "*** ERROR: cant activate sheet "
msgtext(5) = "*** ERROR: cant save document "
msgtext(6) = "Please edit macro first (Extras/Macros/Edit)"
End Select
End Sub
Function GetSheetSizeFromPaperSize(SheetWidth, SheetHeight)
' Function returns the SheetSize constant based on the width and heigth
' useful for userdefined sheetformats
' Funktion ermittelt die Blattgröße (als Konstante) aus der Breite und
' Höhe des Blattes; nützlich für benutzerdefierte Blattformate
Const swDwgPaperAsize = 0
Const swDwgPaperAsizeVertical = 1
Const swDwgPaperBsize = 2
Const swDwgPaperCsize = 3
Const swDwgPaperDsize = 4
Const swDwgPaperEsize = 5
Const swDwgPaperA4size = 6
Const swDwgPaperA4sizeVertical = 7
Const swDwgPaperA3size = 8
Const swDwgPaperA2size = 9
Const swDwgPaperA1size = 10
Const swDwgPaperA0size = 11
Const swDwgPapersUserDefined = 12
If (Round(SheetWidth, 4) = 0.2794) And (Round(SheetHeight, 4) = 0.2159) Then
GetSheetSizeFromPaperSize = swDwgPaperAsize
ElseIf (Round(SheetWidth, 4) = 0.2159) And (Round(SheetHeight, 4) = 0.2794) Then
GetSheetSizeFromPaperSize = swDwgPaperAsizeVertical
ElseIf (Round(SheetWidth, 4) = 0.4318) And (Round(SheetHeight, 4) = 0.2794) Then
GetSheetSizeFromPaperSize = swDwgPaperBsize
ElseIf (Round(SheetWidth, 4) = 0.5588) And (Round(SheetHeight, 4) = 0.4318) Then
GetSheetSizeFromPaperSize = swDwgPaperCsize
ElseIf (Round(SheetWidth, 4) = 0.8636) And (Round(SheetHeight, 4) = 0.5588) Then
GetSheetSizeFromPaperSize = swDwgPaperDsize
ElseIf (Round(SheetWidth, 4) = 1.1176) And (Round(SheetHeight, 4) = 0.8636) Then
GetSheetSizeFromPaperSize = swDwgPaperEsize
ElseIf (Round(SheetWidth, 4) = 0.297) And (Round(SheetHeight, 4) = 0.21) Then
GetSheetSizeFromPaperSize = swDwgPaperA4size
ElseIf (Round(SheetWidth, 4) = 0.21) And (Round(SheetHeight, 4) = 0.297) Then
GetSheetSizeFromPaperSize = swDwgPaperA4sizeVertical
ElseIf (Round(SheetWidth, 4) = 0.42) And (Round(SheetHeight, 4) = 0.297) Then
GetSheetSizeFromPaperSize = swDwgPaperA3size
ElseIf (Round(SheetWidth, 4) = 0.594) And (Round(SheetHeight, 4) = 0.42) Then
GetSheetSizeFromPaperSize = swDwgPaperA2size
ElseIf (Round(SheetWidth, 4) = 0.841) And (Round(SheetHeight, 4) = 0.594) Then
GetSheetSizeFromPaperSize = swDwgPaperA1size
ElseIf (Round(SheetWidth, 4) = 1.189) And (Round(SheetHeight, 4) = 0.841) Then
GetSheetSizeFromPaperSize = swDwgPaperA0size
Else
GetSheetSizeFromPaperSize = swDwgPapersUserDefined
End If
End Function
| Kritik und Anregungen bitte an Stefan Berlitz. Letzte Änderung dieser Seite am Donnerstag, 01. Februar 2007 17:40 |