Plan otwarcia makr zgodnie z konfiguracją

Out of category
1

Witam 

Nowe pytanie, chciałbym zautomatyzować tworzenie mojego planu. Pozwólcie, że wyjaśnię, mam udział z, powiedzmy, 15 różnymi konfiguracjami. Chciałbym zrobić makro do otwierania rysunku z arkuszem według konfiguracji, nazywając go od numeru konfiguracji. Mam małe pojęcie o kodzie, ale nie znam funkcji do otwierania planu i tworzenia nowych arkuszy.

Oto fragment mojego kodu, aby ukończyć różne konfiguracje:

 ConfCount = UBound(vConfigNameArr)

    Jeśli ConfCount = 0, wyjdź z sub

    Jeśli ConfCount > 0, to
       
       i = 1
        – Kończymy
        Dla każdej nazwy vConfigName w vConfigNameArr
                      
            Wyświetlamy konfigurację
            swModel.ShowConfiguration2 vConfigName
        
            swModel.ShowNamedView2 "*Izometryczny", -1
            swModel.ViewZoomtofit2
        
            "Wymuszamy odbudowę
            swModel.ForceRebuild3 Fałsz

            Otwieramy nowy rysunek 

            Tworzone są nowe liście

Jeśli ktoś ma jakiś pomysł, jestem do dyspozycji.

Pozdrowienia

 

Edycja: Chcę zrobić kopiowanie i wklejanie, tworzę swój pierwszy plan, a następnie uruchamiam makro, aby skopiować/wkleić mój pierwszy arkusz tyle razy, ile jest konfiguracji. Nazywając arkusze w nazwie konfiguracji.

2

Do stworzenia nowego arkusza mam taki fragment kodu:

(swmodel.getpathname musi oczywiście wskazywać na skonfigurowany model części lub zespołu)

                
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

W przeciwnym razie, aby skopiować arkusz i zmienić jego nazwę, a następnie zmienić referencje (konfiguracje) mam ten fragment kodu (będę musiał strzelać, ale nie za dużo czasu na to)

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

Celem tego drugiego makra jest skopiowanie wszystkich arkuszy MEp (przykład: arkusz1 i arkusz2)

Dodaj -SYM do nowych arkuszy (przykład: Arkusz1-SYM, Arkusz2-SYM), a następnie zmień odwołania do wszystkich widoków dla konfiguracji symetrycznej.

Ten kod powinien odpowiedzieć na niektóre z Twoich pytań, aby zmienić konfiguracje. Od Ciebie zależy, czy spojrzysz i posortujesz.

3

Idealnie, jest świetnie, dziękuję. Jednak zSmartCat_SYM1 i zBomMaterials nie są zdefiniowane. Jak je zdefiniować?  

Pozdrowienia

4

W przypadku zSmartCat_SYM jest to moduł, który pobiera nazwy konfiguracji:

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

W przypadku zBomMaterials dotyczy to pewnych zmian w tabeli BOM (zmiana konfiguracji i zmiana rozmiaru jednej lub 2 kolumn:

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

Całe makro jako załącznik w razie potrzeby


mep_decoupe__symetrie.swp
5

Dziękuję, to świetnie.

Miłego dnia

Pozdrowienia