Hallo
Ich muss eine Montage von 30 Teilen (200 Komponenten mit den Schrauben) symmetrisch gestalten. Jedes Teil verfügt über einen 2D-Plan für die Fertigung.
Wissen Sie, ob es möglich ist, die Pläne der neuen symmetrischen Teile automatisch zu erstellen? (mit mycadtools oder anderen...)
Das würde mir viel Zeit sparen!
Vielen Dank für Ihre Hilfe und einen schönen Tag.
Allein durch die Integration (mycad) wird es kompliziert.
Dies können Sie mit einem Makro tun, das Sie per Integration auf einer Zeichnungsliste ausführen.
Für das Makro benötigen Sie natürlich Grundlagen in VBA.
Hier ist ein Beispiel, das ich in meinem Unternehmen implementiert habe, das alle Blätter eines MEP mit -SYM zusätzlich zum vorhandenen Blattnamen kopiert, wenn eine symmetrische Konfiguration des referenzierten Teils vorhanden ist, die eine Eigenschaft des referenzierten Dokuments ändert, die jede Ansicht von MEp in die symmetrische Konfiguration ändert:
Option Explicit
'MAJ 2022-09-30 Ajout de la laison de la vue avec la nomenclature: voir -> On récupère le nom de la dernière nomenclature pour les feuilles SYM
'Const iDrwTempSize As Long = swDwgPaperSizes_e.swDwgPaperA0size
Const suffixFeuille As String = "-SYM"
Const suffixNomFichier As String = "-SYM"
Dim swApp As SldWorks.SldWorks
Dim swDraw As DrawingDoc
Dim swModel As ModelDoc2
Dim swModel2 As ModelDoc2
Dim bret As Boolean
Dim swView As SldWorks.View
Dim swRefModel As SldWorks.ModelDoc2
Dim longstatus As Long
Dim longwarnings As Long
Sub copyDrawingSheetSYM()
sDrTemplateLaser = "U:\Entreprise\Service BE\1-Commun service\Solidworks\Configuration\Modèle de documents\Modèle SW 2020\Fond de plan C\A4-DECOUPE-c.DRWDOT"
Set swApp = Application.SldWorks
Set swModel = swApp.ActiveDoc
Set swDraw = swModel
If (swDraw Is Nothing) Then
MsgBox "ouvrir une MEP"
End
End If
Dim sheetCount As Integer
sheetCount = swDraw.GetSheetCount
Dim vSheetName As Variant
'vSheet = swDraw.GetSheetNames
Dim sheetName As String
Dim i As Integer
'1-) PARTIE SUPPRESSION FEUILLES SYM EXISTANTE
Debug.Print "1-) PARTIE SUPPRESSION FEUILLES SYM EXISTANTE"
Dim selection As Boolean
selection = False
'On vide la sélection de feuille en cours
swModel.ClearSelection2 True
vSheetName = swDraw.GetSheetNames
'On boucle sur les feuilles
For i = 0 To UBound(vSheetName)
sheetName = vSheetName(i)
'Debug.Print "Nom de feuille:" & sheetName
If sheetName Like "*" & suffixFeuille & "*" Then
'Debug.Print "On entre dans la partie suppression"
selection = True
'Sélection des feuilles Sym
bret = swModel.Extension.SelectByID2(sheetName, "SHEET", 0, 0, 0, True, 0, Nothing, 0)
End If
Next i
If selection = True Then
'On demande si on supprime la feuille
If MsgBox("Voulez vous supprimer les feuilles Sym?", vbYesNo + vbDefaultButton1, "Basculer la vue de découpe?") = vbYes Then 'Si le bouton Oui est cliqué
'Suppression des feuilles
bret = swModel.Extension.DeleteSelection2(0)
'Debug.Print "Feuilles supprimées"
Else
MsgBox "On quitte la macro"
Exit Sub
End If
End If
'2-) PARTIE CREATION FEUILLES SYM
Debug.Print "2-) PARTIE CREATION FEUILLES SYM"
sheetCount = swDraw.GetSheetCount
vSheetName = swDraw.GetSheetNames
'On boucle sur les feuilles
For i = 1 To sheetCount
sheetName = vSheetName(i - 1)
Debug.Print "Nom de feuille:" & sheetName
If i = 1 Then
Set swView = swDraw.GetFirstView().GetNextView
'On vérifie si la feuille contient un ou plusieur fraisage -> <HOLE-SINK>
Debug.Print " View = " & swView.Name
Dim swDispDim As SldWorks.DisplayDimension
Dim swDim As SldWorks.Dimension
Dim swAnn As SldWorks.Annotation
Dim threadPrefix As String
Set swDispDim = swView.GetFirstDisplayDimension5
Do While Not swDispDim Is Nothing
Set swAnn = swDispDim.GetAnnotation
Set swDim = swDispDim.GetDimension
threadPrefix = CStr(swDispDim.GetText(swDimensionTextPrefix))
Debug.Print threadPrefix
Set swDispDim = swDispDim.GetNext3
'Si le suffixe de la côte est fraisée -> <HOLE-SINK>
Dim fraisage As String
fraisage = "Non"
If Left(threadPrefix, 11) = "<HOLE-SINK>" Then
Debug.Print "Fraisage"
fraisage = "Oui"
Else
Debug.Print "Pas de fraisage"
fraisage = "Non"
End If
Loop
Set swRefModel = swView.ReferencedDocument
Dim sModelName As String
sModelName = swView.GetReferencedModelName
Debug.Print "File = " & swModel.GetPathName
Debug.Print " View = " & swView.Name
Debug.Print " Referenced model name = " & sModelName
Debug.Print " Model path = " & swDraw.GetPathName
Dim vConfs As Variant
vConfs = swRefModel.GetConfigurationNames
Dim confSymName As String
confSymName = ""
Dim j As Integer
'On boucle sur les config
For j = 0 To UBound(vConfs)
Dim confName As String
confName = vConfs(j)
If confName Like "*Sym*" And Not confName Like "*Sym*Sym*" And Not confName Like "Sym*Flat*" Then
confSymName = confName
Dim saveJ As String
saveJ = j
End If
'Debug.Print confName
swModel.ForceRebuild3 False
Next j
End If
If confSymName <> "" Then
'On lance la macro pour ajouter le suffix au model auquel la MEP fait référence
'On active le model
Debug.Print sModelName
'Set swModel2 = swApp.OpenDoc6(sModelName, 3, 0, "", longstatus, longwarnings)
'ici rendre le model actif
Set swModel2 = swApp.ActivateDoc3(sModelName, swRebuildOnActivation_e.swDontRebuildActiveDoc = 1, 0, 0)
'On lance le code pour modifier la propriété du modèle référencé
zSmartCat_SYM1.smartCat_SYM
'On active la mise en plan
'Set swModel = swApp.OpenDoc6(swDraw.GetPathName, 3, 0, "", longstatus, longwarnings)
Set swModel = swApp.ActivateDoc3(swDraw.GetPathName, swRebuildOnActivation_e.swDontRebuildActiveDoc = 1, 0, 0)
'Set swDraw = swModel
swDraw.ActivateSheet sheetName
'Debug.Print "Feuille active:" & sheetName
bret = swDraw.Extension.SelectByID2(sheetName, "SHEET", 0, 0, 0, False, 0, Nothing, 0)
swModel.EditCopy
bret = swDraw.PasteSheet(swInsertOption_AfterSelectedSheet, swRenameOption_No)
swDraw.GetCurrentSheet.SetName sheetName & suffixFeuille
Debug.Print "Nom de la feuille active: " & swDraw.GetCurrentSheet.GetName
'On récupère le nom de la dernière nomenclature pour les feuilles SYM
Dim swFeat As SldWorks.Feature
Dim swBomFeat As SldWorks.BomFeature
Dim BomName As String
Set swFeat = swDraw.FirstFeature
Do While Not swFeat Is Nothing
If (swFeat.GetTypeName = "BomFeat") Then
Debug.Print "******************************"
Debug.Print "Feature Name = " & swFeat.Name
BomName = swFeat.Name
End If
Set swFeat = swFeat.GetNextFeature
Loop
'On parcourt toute les vue de la feuille et on change la config
Set swView = swDraw.GetFirstView.GetNextView
Do While Not swView Is Nothing
'Debug.Print " Drawing view = " + swView.Name
'Debug.Print " Referenced model name = " & swView.GetReferencedModelName
'Debug.Print " Referenced configuration name = " & swView.ReferencedConfiguration
'Debug.Print " Referenced configuration persistent reference ID = " & swView.ReferencedConfigurationID
'Changement de configuration (Symétrique) si la vue d'est pas une vue déplié (Flat-Pattern)
If Not swView.ReferencedConfiguration Like "*PATTERN*" Then
'Debug.Print "On change la config"
swView.ReferencedConfiguration = vConfs(saveJ)
'On lie la vue à la nomenclature
If BomName <> vbNullString Then
bret = swView.SetKeepLinkedToBOM(True, BomName)
End If
Else
'On retourne la vue si pas pièce pas fraisée
If fraisage = "Non" Then
'Debug.Print "On retourne la vue"
If swView.FlipView = False Then
swView.FlipView = True
Else
swView.FlipView = False
End If
Else 'Fraisage="Oui"
'Cocher Symétrie de la vue horizontal
Dim mirrored As Boolean
Dim orientation As Long
swView.SetMirrorViewOrientation True, swMirrorViewPositions_e.swMirrorViewPosition_Horizontal
swView.GetMirrorViewOrientation mirrored, orientation
Debug.Print "Mirrored? " & mirrored
Debug.Print "Orientation (0 = horizontal)? " & orientation
End If
End If
'Get next drawing view
Set swView = swView.GetNextView
Loop
End If
Next
'3-) PARTIE CREATION ANNOTATION AJOUT DU SUFFIX NOM DE FICHIER POUR SYM
Debug.Print "3-) PARTIE CREATION FEUILLES SYM"
sheetCount = swDraw.GetSheetCount
vSheetName = swDraw.GetSheetNames
'On boucle sur les feuilles
For i = 1 To sheetCount
sheetName = vSheetName(i - 1)
Debug.Print i & "-Nom de feuille:" & sheetName
If sheetName Like "*" & suffixFeuille & "*" Then
swDraw.ActivateSheet sheetName
Set swView = swDraw.GetFirstView()
'On boucle sur les notes
Dim swNote As Note
'Dim swAnn As SldWorks.Annotation
Dim sValue As String
Set swNote = swView.GetFirstNote
swModel.ClearSelection2 (True)
Do While Not swNote Is Nothing
Set swAnn = swNote.GetAnnotation
sValue = "$PRP:""SW-Nom de fichier(File Name)""" 'Mettre le nom de la propriété recherchée
Debug.Print swNote.PropertyLinkedText
If swNote.PropertyLinkedText = sValue Then
Debug.Print "Propriété trouvé"
swNote.PropertyLinkedText = sValue & suffixNomFichier
Exit Do
End If
swModel.ClearSelection2 (True)
Set swNote = swNote.GetNext
Loop
End If
Next i
zBomMaterials.bomMaterials
'swModel.EditRebuild3
'swModel.Save
Set swApp = Nothing
Set swModel = Nothing
Set swDraw = Nothing
Set swRefModel = Nothing
End Sub
Damit dies funktioniert, ist es zwingend erforderlich, dass die Symmetrie in einer Konfiguration ausgeführt wird, die mit dem Namen Symmetrie beginnt.