Makro-Öffnungsplan gemäß Konfiguration

Out of category
1

Hallo 

Neue Frage, ich möchte meine Planerstellung automatisieren. Lassen Sie mich erklären, dass ich ein Teil mit, sagen wir, 15 verschiedenen Konfigurationen habe. Ich möchte ein Makro erstellen, um eine Zeichnung mit einem Blatt nach Konfiguration zu öffnen, indem ich es aus der Konfigurationsnummer benenne. Ich habe eine kleine Vorstellung vom Code, kenne aber nicht die Funktionen zum Öffnen eines Plans und zum Erstellen neuer Blätter.

Hier ist ein Stück meines Codes, um die verschiedenen Konfigurationen zu vervollständigen:

 ConfCount = UBound(vConfigNameArr)

    Wenn ConfCount = 0, dann sub beenden

    Wenn ConfCount > 0 ist, dann
       
       i = 1
        "Wir schließen ab
        Für jeden vConfigName in vConfigNameArr
                      
            Wir zeigen die Konfiguration an
            swModel.ShowConfiguration2 vConfigName
        
            swModel.ShowNamedView2 "*Isometrisch", -1
            swModel.ViewZoomtofit2
        
            "Wir erzwingen den Wiederaufbau
            swModel.ForceRebuild3 Falsch

            Wir öffnen eine neue Zeichnung 

            Die neuen Blätter werden erstellt

Wenn jemand eine Idee hat, bin ich ganz Ohr.

Herzliche Grüße

 

Bearbeiten: Ich möchte kopieren und einfügen, ich mache meinen ersten Plan und dann starte ich das Makro, um mein erstes Blatt so oft wie die Anzahl der Konfigurationen zu kopieren und einzufügen. Indem Sie die Blätter im Namen der Konfiguration benennen.

2

Um ein neues Blatt zu erstellen, habe ich diesen Code:

(swmodel.getpathname muss natürlich auf Ihr konfiguriertes Teile- oder Baugruppenmodell verweisen)

                
Set swDraw = swApp.NewDocument(sDrTemplateLaser, 0, 0, 0)
Dim swSheet  As SldWorks.Sheet
Set swSheet = swDraw.GetCurrentSheet
bRet = swSheet.SetScale(1, 1, True, False)
Debug.Print "Modèle:" & swModel.GetPathName
Set swView = swDraw.CreateFlatPatternViewFromModelView3(swModel.GetPathName, "", 0.105, 0.184, 0#, False, False)
Dim swDrawModel As SldWorks.ModelDoc2
Set swDrawModel = swDraw
swDrawModel.ForceRebuild3 False
swDrawModel.Extension.SaveAs file, swSaveAsVersion_e.swSaveAsCurrentVersion, swSaveAsOptions_e.swSaveAsOptions_Silent, Nothing, 0, 0

Andernfalls, um ein Blatt zu kopieren und umzubenennen und dann die Referenzen (Konfigurationen) zu ändern, habe ich dieses Stück Code (ich muss schießen, aber nicht zu viel Zeit dafür)

Option Explicit

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()
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
'swModel.Extension.ClearSelection2 False
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
            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*" 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
            
            '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)
                Else
                    'On retourne la vue
                    'Debug.Print "On retourne la vue"
                    swView.FlipView = True
                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

Der Zweck dieses 2. Makros besteht darin, alle Blätter eines MEp zu kopieren (Beispiel: Blatt1 und Blatt2)

Fügen Sie -SYM zu den neuen Blättern hinzu (z. B. Tabelle1-SYM, Tabelle2-SYM), und ändern Sie dann die Referenzen aller Ansichten für die symmetrische Konfiguration.

Dieser Code sollte einige Ihrer Fragen zum Ändern von Konfigurationen beantworten. Es liegt an Ihnen, zu suchen und zu sortieren.

3

Perfekt, es ist toll, danke. zSmartCat_SYM1 und zBomMaterials sind jedoch nicht definiert. Wie soll ich sie definieren?  

Herzliche Grüße

4

Zum zSmartCat_SYM handelt es sich um ein Modul, das den Namen der Konfigurationen abruft:

Sub smartCat_SYM()
Const suffixNomFichier      As String = "-SYM"
Dim swApp                   As SldWorks.SldWorks
Dim swModel                 As SldWorks.ModelDoc2
Dim swConfig                As SldWorks.Configuration
Dim swCustPropMgr           As SldWorks.CustomPropertyManager
Dim configNames             As Variant
Dim configName              As Variant
Dim lRetVal                 As Long
Dim PathName                As String
Dim bRet                    As Boolean
Dim errorsSave              As Long
Dim warnings                As Long
Dim lectureSeule            As Boolean
Dim configSym               As Boolean
Dim fichierNotSave          As Boolean

Set swApp = Application.SldWorks
Set swModel = swApp.ActiveDoc

lectureSeule = False
configSym = False

'On vérifie si la propriété existe déjà si oui on sort de la macro
    'Pour toutes les configurations du modèle 3D
    configNames = swModel.GetConfigurationNames
        For Each configName In configNames
        Debug.Print "2-Nom de config:" & configName
        Set swConfig = swModel.GetConfigurationByName(configName)
        Set swCustPropMgr = swConfig.CustomPropertyManager
    
        If configName Like "*Sym*" Then
                If configName Like "*Sym*Sym*" Then
                    MsgBox "Attention Symétrie de Symétrie merci de corriger votre assemblage et supprimer cette configuration: " & configName
                End If
                'Dim cfg As String
                'cfg = swModel.GetActiveConfiguration.Name
                If swModel.GetCustomInfoValue(configName, "Symetrie") <> "" Then
                    Exit Sub
                End If
            End If
        Next

Für zBomMaterials handelt es sich um einige Änderungen an der Stücklistentabelle (Änderung der Konfiguration und Größenänderung einer oder 2 Spalten):

Dim swApp As SldWorks.SldWorks
Dim swDraw As SldWorks.DrawingDoc

Sub bomMaterials()

    Set swApp = Application.SldWorks
    
    Set swDraw = swApp.ActiveDoc
    
    Dim vSheetNames As Variant
    
    vSheetNames = swDraw.GetSheetNames
    
    Dim i As Integer
        
    For i = 0 To UBound(vSheetNames)
        
        Dim swSheet As SldWorks.Sheet
        Set swSheet = swDraw.Sheet(vSheetNames(i))
        Debug.Print "Feuille:" & vSheetNames(i)
        Dim swView As SldWorks.View
        Set swView = GetPropertiesView(swSheet)
        
        Dim vBomFeatures As Variant
        vBomFeatures = GetBomFeatures(swSheet)
        ProcessView swView, vBomFeatures
        'On relance pour redimensionner les colonnes
        vBomFeatures = GetBomFeatures(swSheet)
    Next
    
End Sub

Sub ProcessView(swView As SldWorks.View, vBomFeatures As Variant)
    
    If Not IsEmpty(vBomFeatures) Then
        
        Dim i As Integer
        
        For i = 0 To UBound(vBomFeatures)
            
            Dim swBomFeat As SldWorks.BomFeature
            
            Set swBomFeat = vBomFeatures(i)
            
            Dim vConfVis As Variant
            Dim vConfNames As Variant
            vConfNames = swBomFeat.GetConfigurations(False, vConfVis)

            Dim visConfIndex As Integer
            
            Dim j As Integer
            
            For j = 0 To UBound(vConfNames)
                
                vConfVis(j) = UCase(vConfNames(j)) = UCase(swView.ReferencedConfiguration)
                           Debug.Print "vConfNames=" & vConfNames(j)
            Next
            'On change la configuration
            swBomFeat.SetConfigurations False, vConfVis, vConfNames
            
        Next
        
    End If
    
End Sub

Function GetBomFeatures(swSheet As SldWorks.Sheet) As Variant
    
    Dim vSheets As Variant
    vSheets = swDraw.GetViews()
    
    Dim i As Integer
    
    For i = 0 To UBound(vSheets)
    
        Dim vViews As Variant
        vViews = vSheets(i)
        
        Dim swSheetView As SldWorks.View
        Set swSheetView = vViews(0)
        
        If UCase(swSheetView.Name) = UCase(swSheet.GetName()) Then
            
            Dim swBomFeatures() As SldWorks.BomFeature
            
            Dim vTables As Variant
            vTables = swSheetView.GetTableAnnotations()
            
            Dim j As Integer
            Dim isArrInit As Boolean
            If IsEmpty(vTables) Then
            'If vTables = "" Then
            Debug.Print "On sort de la macro"
            Exit Function
            End If
            
            For j = 0 To UBound(vTables)
                
                Dim swTableAnn As SldWorks.TableAnnotation
                Set swTableAnn = vTables(j)
                
                If swTableAnn.Type = swTableAnnotationType_e.swTableAnnotation_BillOfMaterials Then
                    If False = isArrInit Then
                        isArrInit = True
                        ReDim swBomFeatures(0)

                    Else
                        ReDim Preserve swBomFeatures(UBound(swBomFeatures) + 1)

                    End If
                    
                    Dim swBomTableAnn As SldWorks.BomTableAnnotation
                    Set swBomTableAnn = swTableAnn
                    
                    Set swBomFeatures(UBound(swBomFeatures)) = swBomTableAnn.BomFeature
                        'Ajout SD redim colonne
                        SetColumnWith swTableAnn
                        'Fin ajout SD redim colonne
                End If
                
            Next
            
            GetBomFeatures = swBomFeatures

            Exit Function
        End If
        
    Next
    
End Function

Function GetPropertiesView(swSheet As SldWorks.Sheet) As SldWorks.View
    
    Dim vViews As Variant
    
    vViews = swSheet.GetViews
    
    If Not IsEmpty(vViews) Then
        
        Dim i As Integer
        
        For i = 0 To UBound(vViews)
            
            Dim swView As SldWorks.View
            Set swView = vViews(i)
            
            If UCase(swView.Name) = UCase(swSheet.CustomPropertyView) Then
                Set GetPropertiesView = swView
                Exit Function
            End If
            
        Next
        
        Set GetPropertiesView = vViews(0) 'use first one
        
    End If
    
End Function
Sub SetColumnWith(swTable As TableAnnotation)
    Dim index As Integer
    Dim swAnnotation As Annotation
    Dim swDislplayData As DisplayData
    Dim i As Integer
    Dim UserPref As Integer
    Dim UserPrefOption As Integer
    Dim swTextFormat As SldWorks.TextFormat
     
    Set swAnnotation = swTable.GetAnnotation
    Set swDislplayData = swAnnotation.GetDisplayData
    'On dimensionne la taille de la police de document pour les nomenclatures
    Set swTextFormat = swAnnotation.GetTextFormat(1)
        swTextFormat.CharHeightInPts = "10"
        swTextFormat.TypeFaceName = "Arial"
        swTextFormat.Bold = False
        swTextFormat.Italic = False
        'on modifie la propriété font du document pour les nomenclature
        bRet = swDraw.Extension.SetUserPreferenceTextFormat(swUserPreferenceTextFormat_e.swDetailingBillOfMaterialTextFormat, swDetailingBillOfMaterial, swTextFormat)
  
        For i = 0 To swTable.ColumnCount - 1
            Dim ColumnWidth As Double
            ColumnWidth = swTable.GetColumnWidth(i)
            'Debug.Print i & ":" & ColumnWidth * 1000
            'Debug.Print "Title" & swTable.GetColumnTitle(i)
            If i = 0 Then bRet = swTable.SetColumnWidth(i, 0.005, 0)
            If i = 1 Then bRet = swTable.SetColumnWidth(i, 0.0135, 0)
            If i = 2 Then bRet = swTable.SetColumnWidth(i, 0.0295, 0)
            If i = 3 Then bRet = swTable.SetColumnWidth(i, 0.098, 0)
            If i = 4 Then bRet = swTable.SetColumnWidth(i, 0.02, 0)
            If i = 5 Then bRet = swTable.SetColumnWidth(i, 0.024, 0)
        Next
    End Sub

Bei Bedarf das gesamte Makro als Anhang


mep_decoupe__symetrie.swp
5

Danke, es ist großartig.

Schönen Tag

Herzliche Grüße